Skip to content

R
riscv-gcc-1
Commit a7f1b24f by Robert Dewar Committed by Arnaud Charlet
Options

checks.ads, [...]: Minor changes throughout for new overflow checking. 

2012-11-06  Robert Dewar  <dewar@adacore.com>

	* checks.ads, checks.adb, exp_ch4.adb: Minor changes throughout for
	new overflow checking.
	* exp_util.adb (Insert_Actions): Remove special casing of
	Overflow_Check.
	* gnat1drv.adb (Adjust_Global_Switches): Fixes for new handling
	of overflow checks.
	* sem.adb (Analyze): Remove special casing of Overflow_Check
	(Analyze_List): ditto.
	* sem_prag.adb (Analyze_Pragma, case Overflow_Checks): Remove
	SUPPRESSED and change CHECKED to STRICT.
	* sem_res.adb (Analyze_And_Resolve): No longer treat
	Overflow_Check specially.
	(Preanalyze_And_Resolve): ditto.
	(Resolve): ditto.
	* snames.ads-tmpl: Replace Name_Checked by Name_Strict.
	* switch-c.adb (Get_Overflow_Mode): Eliminate 0 setting,
	CHECKED => STRICT.
	* types.ads (Overflow_Check_Type): Remove Suppressed, change
	Checked to Strict (Suppress_Record): Overflow check controlled
	by Suppress array.

From-SVN: r193233
parent c4ae9877
Showing with 349 additions and 388 deletions
gcc/ada/ChangeLog
2012-11-06 Robert Dewar <dewar@adacore.com>
* checks.ads, checks.adb, exp_ch4.adb: Minor changes throughout for
new overflow checking.
* exp_util.adb (Insert_Actions): Remove special casing of
Overflow_Check.
* gnat1drv.adb (Adjust_Global_Switches): Fixes for new handling
of overflow checks.
* sem.adb (Analyze): Remove special casing of Overflow_Check
(Analyze_List): ditto.
* sem_prag.adb (Analyze_Pragma, case Overflow_Checks): Remove
SUPPRESSED and change CHECKED to STRICT.
* sem_res.adb (Analyze_And_Resolve): No longer treat
Overflow_Check specially.
(Preanalyze_And_Resolve): ditto.
(Resolve): ditto.
* snames.ads-tmpl: Replace Name_Checked by Name_Strict.
* switch-c.adb (Get_Overflow_Mode): Eliminate 0 setting,
CHECKED => STRICT.
* types.ads (Overflow_Check_Type): Remove Suppressed, change
Checked to Strict (Suppress_Record): Overflow check controlled
by Suppress array.
2012-11-06 Ed Schonberg <schonberg@adacore.com> 2012-11-06 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Preanalyze_And_Resolve): In Alfa mode do not * sem_res.adb (Preanalyze_And_Resolve): In Alfa mode do not
......
gcc/ada/checks.adb
...@@ -194,18 +194,19 @@ package body Checks is ...@@ -194,18 +194,19 @@ package body Checks is
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
procedure Apply_Arithmetic_Overflow_Checked_Suppressed (N : Node_Id); procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id);
-- Used to apply arithmetic overflow checks for all cases except operators -- Used to apply arithmetic overflow checks for all cases except operators
-- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
-- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N is always -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
-- a signed integer arithmetic operator (if and case expressions are not -- signed integer arithmetic operator (but not an if or case expression).
-- included for this case). -- It is also called for types other than signed integers.
procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id); procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id);
-- Used to apply arithmetic overflow checks for the case where the overflow -- Used to apply arithmetic overflow checks for the case where the overflow
-- checking mode is MINIMIZED or ELIMINATED (and the Do_Overflow_Check flag -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
-- is known to be set) and we have a signed integer arithmetic op (which -- arithmetic op (which includes the case of if and case expressions). Note
-- includes the case of if and case expressions). -- that Do_Overflow_Check may or may not be set for node Op. In these modes
-- we have work to do even if overflow checking is suppressed.
procedure Apply_Division_Check procedure Apply_Division_Check
(N : Node_Id; (N : Node_Id;
...@@ -766,14 +767,12 @@ package body Checks is ...@@ -766,14 +767,12 @@ package body Checks is
begin begin
-- Use old routine in almost all cases (the only case we are treating -- Use old routine in almost all cases (the only case we are treating
-- specially is the case of a signed integer arithmetic op with the -- specially is the case of a signed integer arithmetic op with the
-- Do_Overflow_Check flag set on the node, and the overflow checking -- overflow checking mode set to MINIMIZED or ELIMINATED).
-- mode is MINIMIZED or ELIMINATED).
if Overflow_Check_Mode (Etype (N)) not in Minimized_Or_Eliminated if Overflow_Check_Mode = Strict
or else not Do_Overflow_Check (N)
or else not Is_Signed_Integer_Arithmetic_Op (N) or else not Is_Signed_Integer_Arithmetic_Op (N)
then then
Apply_Arithmetic_Overflow_Checked_Suppressed (N); Apply_Arithmetic_Overflow_Strict (N);
-- Otherwise use the new routine for the case of a signed integer -- Otherwise use the new routine for the case of a signed integer
-- arithmetic op, with Do_Overflow_Check set to True, and the checking -- arithmetic op, with Do_Overflow_Check set to True, and the checking
...@@ -784,9 +783,9 @@ package body Checks is ...@@ -784,9 +783,9 @@ package body Checks is
end if; end if;
end Apply_Arithmetic_Overflow_Check; end Apply_Arithmetic_Overflow_Check;
-------------------------------------------------- --------------------------------------
-- Apply_Arithmetic_Overflow_Checked_Suppressed -- -- Apply_Arithmetic_Overflow_Strict --
-------------------------------------------------- --------------------------------------
-- This routine is called only if the type is an integer type, and a -- This routine is called only if the type is an integer type, and a
-- software arithmetic overflow check may be needed for op (add, subtract, -- software arithmetic overflow check may be needed for op (add, subtract,
...@@ -795,21 +794,28 @@ package body Checks is ...@@ -795,21 +794,28 @@ package body Checks is
-- operation into a more complex sequence of tests that ensures that -- operation into a more complex sequence of tests that ensures that
-- overflow is properly caught. -- overflow is properly caught.
-- This is used in SUPPRESSED/CHECKED modes. It is identical to the -- This is used in CHECKED modes. It is identical to the code for this
-- code for these cases before the big overflow earthquake, thus ensuring -- cases before the big overflow earthquake, thus ensuring that in this
-- that in these modes we have compatible behavior (and reliability) to -- modes we have compatible behavior (and reliability) to what was there
-- what was there before. It is also called for types other than signed -- before. It is also called for types other than signed integers, and if
-- integers, and if the Do_Overflow_Check flag is off. -- the Do_Overflow_Check flag is off.
-- Note: we also call this routine if we decide in the MINIMIZED case -- Note: we also call this routine if we decide in the MINIMIZED case
-- to give up and just generate an overflow check without any fuss. -- to give up and just generate an overflow check without any fuss.
procedure Apply_Arithmetic_Overflow_Checked_Suppressed (N : Node_Id) is procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N); Typ : constant Entity_Id := Etype (N);
Rtyp : constant Entity_Id := Root_Type (Typ); Rtyp : constant Entity_Id := Root_Type (Typ);
begin begin
-- Nothing to do if Do_Overflow_Check not set or overflow checks
-- suppressed.
if not Do_Overflow_Check (N) then
return;
end if;
-- An interesting special case. If the arithmetic operation appears as -- An interesting special case. If the arithmetic operation appears as
-- the operand of a type conversion: -- the operand of a type conversion:
...@@ -1067,7 +1073,7 @@ package body Checks is ...@@ -1067,7 +1073,7 @@ package body Checks is
when RE_Not_Available => when RE_Not_Available =>
return; return;
end; end;
end Apply_Arithmetic_Overflow_Checked_Suppressed; end Apply_Arithmetic_Overflow_Strict;
---------------------------------------------------- ----------------------------------------------------
-- Apply_Arithmetic_Overflow_Minimized_Eliminated -- -- Apply_Arithmetic_Overflow_Minimized_Eliminated --
...@@ -1075,7 +1081,6 @@ package body Checks is ...@@ -1075,7 +1081,6 @@ package body Checks is
procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id) is procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id) is
pragma Assert (Is_Signed_Integer_Arithmetic_Op (Op)); pragma Assert (Is_Signed_Integer_Arithmetic_Op (Op));
pragma Assert (Do_Overflow_Check (Op));
Loc : constant Source_Ptr := Sloc (Op); Loc : constant Source_Ptr := Sloc (Op);
P : constant Node_Id := Parent (Op); P : constant Node_Id := Parent (Op);
...@@ -1086,8 +1091,7 @@ package body Checks is ...@@ -1086,8 +1091,7 @@ package body Checks is
Result_Type : constant Entity_Id := Etype (Op); Result_Type : constant Entity_Id := Etype (Op);
-- Original result type -- Original result type
Check_Mode : constant Overflow_Check_Type := Check_Mode : constant Overflow_Check_Type := Overflow_Check_Mode;
Overflow_Check_Mode (Etype (Op));
pragma Assert (Check_Mode in Minimized_Or_Eliminated); pragma Assert (Check_Mode in Minimized_Or_Eliminated);
Lo, Hi : Uint; Lo, Hi : Uint;
...@@ -1102,7 +1106,7 @@ package body Checks is ...@@ -1102,7 +1106,7 @@ package body Checks is
-- In all these cases, we will process at the higher level (and then -- In all these cases, we will process at the higher level (and then
-- this node will be processed during the downwards recursion that -- this node will be processed during the downwards recursion that
-- is part of the processing in Minimize_Eliminate_Overflow_Checks). -- is part of the processing in Minimize_Eliminate_Overflows).
if Is_Signed_Integer_Arithmetic_Op (P) if Is_Signed_Integer_Arithmetic_Op (P)
or else Nkind (P) in N_Membership_Test or else Nkind (P) in N_Membership_Test
...@@ -1127,7 +1131,7 @@ package body Checks is ...@@ -1127,7 +1131,7 @@ package body Checks is
-- will still be in Bignum mode if either of its operands are of type -- will still be in Bignum mode if either of its operands are of type
-- Bignum). -- Bignum).
Minimize_Eliminate_Overflow_Checks (Op, Lo, Hi, Top_Level => True); Minimize_Eliminate_Overflows (Op, Lo, Hi, Top_Level => True);
-- That call may but does not necessarily change the result type of Op. -- That call may but does not necessarily change the result type of Op.
-- It is the job of this routine to undo such changes, so that at the -- It is the job of this routine to undo such changes, so that at the
...@@ -1213,7 +1217,7 @@ package body Checks is ...@@ -1213,7 +1217,7 @@ package body Checks is
-- Here we know the result is Long_Long_Integer'Base, of that it has -- Here we know the result is Long_Long_Integer'Base, of that it has
-- been rewritten because the parent operation is a conversion. See -- been rewritten because the parent operation is a conversion. See
-- Apply_Arithmetic_Overflow_Checked_Suppressed.Conversion_Optimization. -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
else else
pragma Assert pragma Assert
...@@ -1678,7 +1682,7 @@ package body Checks is ...@@ -1678,7 +1682,7 @@ package body Checks is
Left : constant Node_Id := Left_Opnd (N); Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N); Right : constant Node_Id := Right_Opnd (N);
Mode : constant Overflow_Check_Type := Overflow_Check_Mode (Typ); Mode : constant Overflow_Check_Type := Overflow_Check_Mode;
-- Current overflow checking mode -- Current overflow checking mode
LLB : Uint; LLB : Uint;
...@@ -1693,15 +1697,13 @@ package body Checks is ...@@ -1693,15 +1697,13 @@ package body Checks is
-- Don't actually use this value -- Don't actually use this value
begin begin
-- If we are operating in MINIMIZED or ELIMINATED mode, and the -- If we are operating in MINIMIZED or ELIMINATED mode, and we are
-- Do_Overflow_Check flag is set and we are operating on signed -- operating on signed integer types, then the only thing this routine
-- integer types, then the only thing this routine does is to call -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
-- Apply_Arithmetic_Overflow_Minimized_Eliminated. That procedure will -- procedure will (possibly later on during recursive downward calls),
-- (possibly later on during recursive downward calls), make sure that -- ensure that any needed overflow/division checks are properly applied.
-- any needed overflow and division checks are properly applied.
if Mode in Minimized_Or_Eliminated if Mode in Minimized_Or_Eliminated
and then Do_Overflow_Check (N)
and then Is_Signed_Integer_Type (Typ) and then Is_Signed_Integer_Type (Typ)
then then
Apply_Arithmetic_Overflow_Minimized_Eliminated (N); Apply_Arithmetic_Overflow_Minimized_Eliminated (N);
...@@ -1726,7 +1728,9 @@ package body Checks is ...@@ -1726,7 +1728,9 @@ package body Checks is
-- Deal with overflow check -- Deal with overflow check
if Do_Overflow_Check (N) and then Mode /= Suppressed then if Do_Overflow_Check (N)
and then not Overflow_Checks_Suppressed (Etype (N))
then
-- Test for extremely annoying case of xxx'First divided by -1 -- Test for extremely annoying case of xxx'First divided by -1
-- for division of signed integer types (only overflow case). -- for division of signed integer types (only overflow case).
...@@ -3093,6 +3097,7 @@ package body Checks is ...@@ -3093,6 +3097,7 @@ package body Checks is
begin begin
if not Overflow_Checks_Suppressed (Target_Base) if not Overflow_Checks_Suppressed (Target_Base)
and then not Overflow_Checks_Suppressed (Target_Type)
and then not and then not
In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK) In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK)
and then not Float_To_Int and then not Float_To_Int
...@@ -4420,7 +4425,7 @@ package body Checks is ...@@ -4420,7 +4425,7 @@ package body Checks is
procedure Enable_Overflow_Check (N : Node_Id) is procedure Enable_Overflow_Check (N : Node_Id) is
Typ : constant Entity_Id := Base_Type (Etype (N)); Typ : constant Entity_Id := Base_Type (Etype (N));
Mode : constant Overflow_Check_Type := Overflow_Check_Mode (Etype (N)); Mode : constant Overflow_Check_Type := Overflow_Check_Mode;
Chk : Nat; Chk : Nat;
OK : Boolean; OK : Boolean;
Ent : Entity_Id; Ent : Entity_Id;
...@@ -4438,7 +4443,7 @@ package body Checks is ...@@ -4438,7 +4443,7 @@ package body Checks is
-- No check if overflow checks suppressed for type of node -- No check if overflow checks suppressed for type of node
if Mode = Suppressed then if Overflow_Checks_Suppressed (Etype (N)) then
return; return;
-- Nothing to do for unsigned integer types, which do not overflow -- Nothing to do for unsigned integer types, which do not overflow
...@@ -4447,23 +4452,28 @@ package body Checks is ...@@ -4447,23 +4452,28 @@ package body Checks is
return; return;
end if; end if;
-- This is the point at which processing for CHECKED mode diverges -- This is the point at which processing for STRICT mode diverges
-- from processing for MINIMIZED/ELIMINATED modes. This divergence is -- from processing for MINIMIZED/ELIMINATED modes. This divergence is
-- probably more extreme that it needs to be, but what is going on here -- probably more extreme that it needs to be, but what is going on here
-- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted
-- to leave the processing for CHECKED mode untouched. There were -- to leave the processing for STRICT mode untouched. There were
-- two reasons for this. First it avoided any incompatible change of -- two reasons for this. First it avoided any incompatible change of
-- behavior. Second, it guaranteed that CHECKED mode continued to be -- behavior. Second, it guaranteed that STRICT mode continued to be
-- legacy reliable. -- legacy reliable.
-- The big difference is that in CHECKED mode there is a fair amount of -- The big difference is that in STRICT mode there is a fair amount of
-- circuitry to try to avoid setting the Do_Overflow_Check flag if we -- circuitry to try to avoid setting the Do_Overflow_Check flag if we
-- know that no check is needed. We skip all that in the two new modes, -- know that no check is needed. We skip all that in the two new modes,
-- since really overflow checking happens over a whole subtree, and we -- since really overflow checking happens over a whole subtree, and we
-- do the corresponding optimizations later on when applying the checks. -- do the corresponding optimizations later on when applying the checks.
if Mode in Minimized_Or_Eliminated then if Mode in Minimized_Or_Eliminated then
if not (Overflow_Checks_Suppressed (Etype (N)))
and then not (Is_Entity_Name (N)
and then Overflow_Checks_Suppressed (Entity (N)))
then
Activate_Overflow_Check (N); Activate_Overflow_Check (N);
end if;
if Debug_Flag_CC then if Debug_Flag_CC then
w ("Minimized/Eliminated mode"); w ("Minimized/Eliminated mode");
...@@ -4472,7 +4482,7 @@ package body Checks is ...@@ -4472,7 +4482,7 @@ package body Checks is
return; return;
end if; end if;
-- Remainder of processing is for Checked case, and is unchanged from -- Remainder of processing is for STRICT case, and is unchanged from
-- earlier versions preceding the addition of MINIMIZED/ELIMINATED. -- earlier versions preceding the addition of MINIMIZED/ELIMINATED.
-- 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
...@@ -6685,9 +6695,9 @@ package body Checks is ...@@ -6685,9 +6695,9 @@ package body Checks is
New_Reference_To (M, Loc)))))); New_Reference_To (M, Loc))))));
end Make_Bignum_Block; end Make_Bignum_Block;
---------------------------------------- ----------------------------------
-- Minimize_Eliminate_Overflow_Checks -- -- Minimize_Eliminate_Overflows --
---------------------------------------- ----------------------------------
-- This is a recursive routine that is called at the top of an expression -- This is a recursive routine that is called at the top of an expression
-- tree to properly process overflow checking for a whole subtree by making -- tree to properly process overflow checking for a whole subtree by making
...@@ -6697,14 +6707,13 @@ package body Checks is ...@@ -6697,14 +6707,13 @@ package body Checks is
-- it would interfere with semantic analysis). -- it would interfere with semantic analysis).
-- What happens is that if MINIMIZED/ELIMINATED mode is in effect then -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then
-- the operator expansion routines, as well as the expansion routines -- the operator expansion routines, as well as the expansion routines for
-- for if/case expression test the Do_Overflow_Check flag and if it is -- if/case expression, do nothing (for the moment) except call the routine
-- set they (for the moment) do nothing except call the routine to apply -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That
-- the overflow check (Apply_Arithmetic_Overflow_Check). That routine -- routine does nothing for non top-level nodes, so at the point where the
-- does nothing for non top-level nodes, so at the point where the call -- call is made for the top level node, the entire expression subtree has
-- is made for the top level node, the entire expression subtree has not -- not been expanded, or processed for overflow. All that has to happen as
-- been expanded, or processed for overflow. All that has to happen as a -- a result of the top level call to this routine.
-- result of the top level call to this routine.
-- As noted above, the overflow processing works by making recursive calls -- As noted above, the overflow processing works by making recursive calls
-- for the operands, and figuring out what to do, based on the processing -- for the operands, and figuring out what to do, based on the processing
...@@ -6716,11 +6725,10 @@ package body Checks is ...@@ -6716,11 +6725,10 @@ package body Checks is
-- the node (if it has been modified by the overflow check processing). The -- the node (if it has been modified by the overflow check processing). The
-- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid
-- a recursive call into the whole overflow apparatus, an important rule -- a recursive call into the whole overflow apparatus, an important rule
-- for this call is that either Do_Overflow_Check must be False, or if -- for this call is that the overflow handling mode must be temporarily set
-- it is set, then the overflow checking mode must be temporarily set -- to STRICT.
-- to CHECKED/SUPPRESSED. Either step will avoid the unwanted recursion.
procedure Minimize_Eliminate_Overflow_Checks procedure Minimize_Eliminate_Overflows
(N : Node_Id; (N : Node_Id;
Lo : out Uint; Lo : out Uint;
Hi : out Uint; Hi : out Uint;
...@@ -6730,7 +6738,7 @@ package body Checks is ...@@ -6730,7 +6738,7 @@ package body Checks is
pragma Assert (Is_Signed_Integer_Type (Rtyp)); pragma Assert (Is_Signed_Integer_Type (Rtyp));
-- Result type, must be a signed integer type -- Result type, must be a signed integer type
Check_Mode : constant Overflow_Check_Type := Overflow_Check_Mode (Empty); Check_Mode : constant Overflow_Check_Type := Overflow_Check_Mode;
pragma Assert (Check_Mode in Minimized_Or_Eliminated); pragma Assert (Check_Mode in Minimized_Or_Eliminated);
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
...@@ -6764,18 +6772,24 @@ package body Checks is ...@@ -6764,18 +6772,24 @@ package body Checks is
-- Set True if one or more operands is already of type Long_Long_Integer -- Set True if one or more operands is already of type Long_Long_Integer
-- which means that if the result is known to be in the result type -- which means that if the result is known to be in the result type
-- range, then we must convert such operands back to the result type. -- range, then we must convert such operands back to the result type.
-- This switch is properly set only when Bignum_Operands is False.
procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False);
procedure Reexpand (C : Suppressed_Or_Checked); -- This is called when we have modified the node and we therefore need
-- This is called when we have not modified the node, so we do not need -- to reanalyze it. It is important that we reset the mode to STRICT for
-- to reanalyze it. But we do want to reexpand it in either SUPPRESSED -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode
-- or CHECKED mode (as indicated by the argument C) to get proper -- we would reenter this routine recursively which would not be good!
-- expansion. It is important that we reset the mode to SUPPRESSED or -- The argument Suppress is set True if we also want to suppress
-- CHECKED, since if we leave it in MINIMIZED or ELIMINATED mode we -- overflow checking for the reexpansion (this is set when we know
-- would reenter this routine recursively which would not be good! -- overflow is not possible). Typ is the type for the reanalysis.
-- Note that this is not just an optimization, testing has showed up
-- several complex cases in which reanalyzing an already analyzed node procedure Reexpand (Suppress : Boolean := False);
-- causes incorrect behavior. -- This is like Reanalyze, but does not do the Analyze step, it only
-- does a reexpansion. We do this reexpansion in STRICT mode, so that
-- instead of reentering the MINIMIZED/ELIMINATED mode processing, we
-- follow the normal expansion path (e.g. converting A**4 to A**2**2).
-- Note that skipping reanalysis is not just an optimization, testing
-- has showed up several complex cases in which reanalyzing an already
-- analyzed node causes incorrect behavior.
function In_Result_Range return Boolean; function In_Result_Range return Boolean;
-- Returns True iff Lo .. Hi are within range of the result type -- Returns True iff Lo .. Hi are within range of the result type
...@@ -6829,25 +6843,62 @@ package body Checks is ...@@ -6829,25 +6843,62 @@ package body Checks is
end if; end if;
end Min; end Min;
---------------
-- Reanalyze --
---------------
procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False) is
Svg : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_General;
Sva : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_Assertions;
Svo : constant Boolean :=
Scope_Suppress.Suppress (Overflow_Check);
begin
Scope_Suppress.Overflow_Checks_General := Strict;
Scope_Suppress.Overflow_Checks_Assertions := Strict;
if Suppress then
Scope_Suppress.Suppress (Overflow_Check) := True;
end if;
Analyze_And_Resolve (N, Typ);
Scope_Suppress.Suppress (Overflow_Check) := Svo;
Scope_Suppress.Overflow_Checks_General := Svg;
Scope_Suppress.Overflow_Checks_Assertions := Sva;
end Reanalyze;
-------------- --------------
-- Reexpand -- -- Reexpand --
-------------- --------------
procedure Reexpand (C : Suppressed_Or_Checked) is procedure Reexpand (Suppress : Boolean := False) is
Svg : constant Overflow_Check_Type := Svg : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_General; Scope_Suppress.Overflow_Checks_General;
Sva : constant Overflow_Check_Type := Sva : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_Assertions; Scope_Suppress.Overflow_Checks_Assertions;
Svo : constant Boolean :=
Scope_Suppress.Suppress (Overflow_Check);
begin begin
Scope_Suppress.Overflow_Checks_General := C; Scope_Suppress.Overflow_Checks_General := Strict;
Scope_Suppress.Overflow_Checks_Assertions := C; Scope_Suppress.Overflow_Checks_Assertions := Strict;
Set_Analyzed (N, False); Set_Analyzed (N, False);
if Suppress then
Scope_Suppress.Suppress (Overflow_Check) := True;
end if;
Expand (N); Expand (N);
Scope_Suppress.Suppress (Overflow_Check) := Svo;
Scope_Suppress.Overflow_Checks_General := Svg; Scope_Suppress.Overflow_Checks_General := Svg;
Scope_Suppress.Overflow_Checks_Assertions := Sva; Scope_Suppress.Overflow_Checks_Assertions := Sva;
end Reexpand; end Reexpand;
-- Start of processing for Minimize_Eliminate_Overflow_Checks -- Start of processing for Minimize_Eliminate_Overflows
begin begin
-- Case where we do not have a signed integer arithmetic operation -- Case where we do not have a signed integer arithmetic operation
...@@ -6884,14 +6935,14 @@ package body Checks is ...@@ -6884,14 +6935,14 @@ package body Checks is
begin begin
Bignum_Operands := False; Bignum_Operands := False;
Minimize_Eliminate_Overflow_Checks Minimize_Eliminate_Overflows
(Then_DE, Lo, Hi, Top_Level => False); (Then_DE, Lo, Hi, Top_Level => False);
if Lo = No_Uint then if Lo = No_Uint then
Bignum_Operands := True; Bignum_Operands := True;
end if; end if;
Minimize_Eliminate_Overflow_Checks Minimize_Eliminate_Overflows
(Else_DE, Rlo, Rhi, Top_Level => False); (Else_DE, Rlo, Rhi, Top_Level => False);
if Rlo = No_Uint then if Rlo = No_Uint then
...@@ -6918,8 +6969,7 @@ package body Checks is ...@@ -6918,8 +6969,7 @@ package body Checks is
Convert_To_Bignum (Else_DE)), Convert_To_Bignum (Else_DE)),
Is_Elsif => Is_Elsif (N))); Is_Elsif => Is_Elsif (N)));
Analyze_And_Resolve Reanalyze (RTE (RE_Bignum), Suppress => True);
(N, RTE (RE_Bignum), Suppress => Overflow_Check);
-- If we have no Long_Long_Integer operands, then we are in result -- If we have no Long_Long_Integer operands, then we are in result
-- range, since it means that none of our operands felt the need -- range, since it means that none of our operands felt the need
...@@ -6930,7 +6980,7 @@ package body Checks is ...@@ -6930,7 +6980,7 @@ package body Checks is
elsif not Long_Long_Integer_Operands then elsif not Long_Long_Integer_Operands then
Set_Do_Overflow_Check (N, False); Set_Do_Overflow_Check (N, False);
Reexpand (Suppressed); Reexpand;
-- Otherwise convert us to long long integer mode. Note that we -- Otherwise convert us to long long integer mode. Note that we
-- don't need any further overflow checking at this level. -- don't need any further overflow checking at this level.
...@@ -6943,8 +6993,7 @@ package body Checks is ...@@ -6943,8 +6993,7 @@ package body Checks is
-- Now reanalyze with overflow checks off -- Now reanalyze with overflow checks off
Set_Do_Overflow_Check (N, False); Set_Do_Overflow_Check (N, False);
Set_Analyzed (N, False); Reanalyze (LLIB, Suppress => True);
Analyze_And_Resolve (N, LLIB, Suppress => Overflow_Check);
end if; end if;
end; end;
...@@ -6968,7 +7017,7 @@ package body Checks is ...@@ -6968,7 +7017,7 @@ package body Checks is
Aexp : constant Node_Id := Expression (Alt); Aexp : constant Node_Id := Expression (Alt);
begin begin
Minimize_Eliminate_Overflow_Checks Minimize_Eliminate_Overflows
(Aexp, Lo, Hi, Top_Level => False); (Aexp, Lo, Hi, Top_Level => False);
if Lo = No_Uint then if Lo = No_Uint then
...@@ -6991,7 +7040,7 @@ package body Checks is ...@@ -6991,7 +7040,7 @@ package body Checks is
if not (Bignum_Operands or Long_Long_Integer_Operands) then if not (Bignum_Operands or Long_Long_Integer_Operands) then
Set_Do_Overflow_Check (N, False); Set_Do_Overflow_Check (N, False);
Reexpand (Suppressed); Reexpand (Suppress => True);
-- Otherwise we are going to rebuild the case expression using -- Otherwise we are going to rebuild the case expression using
-- either bignum or long long integer operands throughout. -- either bignum or long long integer operands throughout.
...@@ -7028,7 +7077,7 @@ package body Checks is ...@@ -7028,7 +7077,7 @@ package body Checks is
Expression => Expression (N), Expression => Expression (N),
Alternatives => New_Alts)); Alternatives => New_Alts));
Analyze_And_Resolve (N, Rtype, Suppress => Overflow_Check); Reanalyze (Rtype, Suppress => True);
end; end;
end if; end if;
end; end;
...@@ -7040,11 +7089,11 @@ package body Checks is ...@@ -7040,11 +7089,11 @@ package body Checks is
-- operands to get the ranges (and to properly process the subtree -- operands to get the ranges (and to properly process the subtree
-- that lies below us!) -- that lies below us!)
Minimize_Eliminate_Overflow_Checks Minimize_Eliminate_Overflows
(Right_Opnd (N), Rlo, Rhi, Top_Level => False); (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
if Binary then if Binary then
Minimize_Eliminate_Overflow_Checks Minimize_Eliminate_Overflows
(Left_Opnd (N), Llo, Lhi, Top_Level => False); (Left_Opnd (N), Llo, Lhi, Top_Level => False);
end if; end if;
...@@ -7356,7 +7405,7 @@ package body Checks is ...@@ -7356,7 +7405,7 @@ package body Checks is
and then In_Result_Range and then In_Result_Range
then then
Set_Do_Overflow_Check (N, False); Set_Do_Overflow_Check (N, False);
Reexpand (Suppressed); Reexpand (Suppress => True);
return; return;
-- Here we know that we are not in the result range, and in the general -- Here we know that we are not in the result range, and in the general
...@@ -7380,22 +7429,17 @@ package body Checks is ...@@ -7380,22 +7429,17 @@ package body Checks is
and then Nkind (Parent (N)) /= N_Type_Conversion and then Nkind (Parent (N)) /= N_Type_Conversion
then then
-- Here we will keep the original types, but we do need an overflow -- Here keep original types, but we need to complete analysis
-- check, so we will set Do_Overflow_Check to True (actually it is
-- true already, or how would we have got here?).
pragma Assert (Do_Overflow_Check (N));
Set_Analyzed (N, False);
-- One subtlety. We can't just go ahead and do an analyze operation -- One subtlety. We can't just go ahead and do an analyze operation
-- here because it will cause recursion into the whole MINIMIZED/ -- here because it will cause recursion into the whole MINIMIZED/
-- ELIMINATED overflow processing which is not what we want. Here -- ELIMINATED overflow processing which is not what we want. Here
-- we are at the top level, and we need a check against the result -- we are at the top level, and we need a check against the result
-- mode (i.e. we want to use Checked mode). So do exactly that! -- mode (i.e. we want to use STRICT mode). So do exactly that!
-- Also, we have not modified the node, so this is a case where -- Also, we have not modified the node, so this is a case where
-- we need to reexpand, but not reanalyze. -- we need to reexpand, but not reanalyze.
Reexpand (Checked); Reexpand;
return; return;
-- Cases where we do the operation in Bignum mode. This happens either -- Cases where we do the operation in Bignum mode. This happens either
...@@ -7421,17 +7465,18 @@ package body Checks is ...@@ -7421,17 +7465,18 @@ package body Checks is
-- set True). In this case, there is no point in moving into Bignum -- set True). In this case, there is no point in moving into Bignum
-- mode to prevent overflow if the caller will immediately convert -- mode to prevent overflow if the caller will immediately convert
-- the Bignum value back to LLI with an overflow check. It's more -- the Bignum value back to LLI with an overflow check. It's more
-- efficient to stay in LLI mode with an overflow check. -- efficient to stay in LLI mode with an overflow check (if needed)
if Check_Mode = Minimized if Check_Mode = Minimized
or else (Top_Level and not Bignum_Operands) or else (Top_Level and not Bignum_Operands)
then then
if Do_Overflow_Check (N) then
Enable_Overflow_Check (N); Enable_Overflow_Check (N);
end if;
-- Since we are doing an overflow check, the result has to be in -- The result now has to be in Long_Long_Integer mode, so adjust
-- Long_Long_Integer mode, so adjust the possible range to reflect -- the possible range to reflect this. Note these calls also
-- this. Note these calls also change No_Uint values from the top -- change No_Uint values from the top level case to LLI bounds.
-- level case to LLI bounds.
Max (Lo, LLLo); Max (Lo, LLLo);
Min (Hi, LLHi); Min (Hi, LLHi);
...@@ -7500,7 +7545,7 @@ package body Checks is ...@@ -7500,7 +7545,7 @@ package body Checks is
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Occurrence_Of (Fent, Loc), Name => New_Occurrence_Of (Fent, Loc),
Parameter_Associations => Args)); Parameter_Associations => Args));
Analyze_And_Resolve (N, RTE (RE_Bignum)); Reanalyze (RTE (RE_Bignum), Suppress => True);
-- Indicate result is Bignum mode -- Indicate result is Bignum mode
...@@ -7557,48 +7602,36 @@ package body Checks is ...@@ -7557,48 +7602,36 @@ package body Checks is
-- we will complete any division checks (since we have not changed the -- we will complete any division checks (since we have not changed the
-- setting of the Do_Division_Check flag). -- setting of the Do_Division_Check flag).
-- If no overflow check, suppress overflow check to avoid an infinite -- We do this reanalysis in STRICT mode to avoid recursion into the
-- recursion into this procedure. -- MINIMIZED/ELIMINATED handling, since we are now done with that!
if not Do_Overflow_Check (N) then
Analyze_And_Resolve (N, LLIB, Suppress => Overflow_Check);
-- If an overflow check is required, do it in normal CHECKED mode.
-- That avoids an infinite recursion, making sure we get a normal
-- overflow check.
else
declare declare
SG : constant Overflow_Check_Type := SG : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_General; Scope_Suppress.Overflow_Checks_General;
SA : constant Overflow_Check_Type := SA : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_Assertions; Scope_Suppress.Overflow_Checks_Assertions;
begin begin
Scope_Suppress.Overflow_Checks_General := Checked; Scope_Suppress.Overflow_Checks_General := Strict;
Scope_Suppress.Overflow_Checks_Assertions := Checked; Scope_Suppress.Overflow_Checks_Assertions := Strict;
Analyze_And_Resolve (N, LLIB);
if not Do_Overflow_Check (N) then
Reanalyze (LLIB, Suppress => True);
else
Reanalyze (LLIB);
end if;
Scope_Suppress.Overflow_Checks_General := SG; Scope_Suppress.Overflow_Checks_General := SG;
Scope_Suppress.Overflow_Checks_Assertions := SA; Scope_Suppress.Overflow_Checks_Assertions := SA;
end; end;
end if; end Minimize_Eliminate_Overflows;
end Minimize_Eliminate_Overflow_Checks;
------------------------- -------------------------
-- Overflow_Check_Mode -- -- Overflow_Check_Mode --
------------------------- -------------------------
function Overflow_Check_Mode (E : Entity_Id) return Overflow_Check_Type is function Overflow_Check_Mode return Overflow_Check_Type is
begin begin
-- Check overflow suppressed on entity
if Present (E) and then Checks_May_Be_Suppressed (E) then
if Is_Check_Suppressed (E, Overflow_Check) then
return Suppressed;
end if;
end if;
-- Else return appropriate scope setting
if In_Assertion_Expr = 0 then if In_Assertion_Expr = 0 then
return Scope_Suppress.Overflow_Checks_General; return Scope_Suppress.Overflow_Checks_General;
else else
...@@ -7612,7 +7645,11 @@ package body Checks is ...@@ -7612,7 +7645,11 @@ package body Checks is
function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
begin begin
return Overflow_Check_Mode (E) = Suppressed; if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Overflow_Check);
else
return Scope_Suppress.Suppress (Overflow_Check);
end if;
end Overflow_Checks_Suppressed; end Overflow_Checks_Suppressed;
----------------------------- -----------------------------
......
gcc/ada/checks.ads
...@@ -72,12 +72,11 @@ package Checks is ...@@ -72,12 +72,11 @@ package Checks is
-- determine whether check C is suppressed either on the entity E or -- determine whether check C is suppressed either on the entity E or
-- as the result of a scope suppress pragma. If Checks_May_Be_Suppressed -- as the result of a scope suppress pragma. If Checks_May_Be_Suppressed
-- is False, then the status of the check can be determined simply by -- is False, then the status of the check can be determined simply by
-- examining Scope_Checks (C), so this routine is not called in that case. -- examining Scope_Suppress, so this routine is not called in that case.
function Overflow_Check_Mode (E : Entity_Id) return Overflow_Check_Type; function Overflow_Check_Mode return Overflow_Check_Type;
-- Returns current overflow checking mode, taking into account whether -- Returns current overflow checking mode, taking into account whether
-- we are inside an assertion expression. Always returns Suppressed if -- we are inside an assertion expression.
-- overflow checks are suppressed for entity E.
------------------------------------------- -------------------------------------------
-- Procedures to Activate Checking Flags -- -- Procedures to Activate Checking Flags --
...@@ -142,7 +141,10 @@ package Checks is ...@@ -142,7 +141,10 @@ package Checks is
-- overflow checking for dependent expressions. This routine handles -- overflow checking for dependent expressions. This routine handles
-- front end vs back end overflow checks (in the front end case it expands -- front end vs back end overflow checks (in the front end case it expands
-- the necessary check). Note that divide is handled separately using -- the necessary check). Note that divide is handled separately using
-- Apply_Divide_Checks. -- Apply_Divide_Checks. Node N may or may not have Do_Overflow_Check.
-- In STRICT mode, there is nothing to do if this flag is off, but in
-- MINIMIZED/ELIMINATED mode we still have to deal with possible use
-- of doing operations in Long_Long_Integer or Bignum mode.
procedure Apply_Constraint_Check procedure Apply_Constraint_Check
(N : Node_Id; (N : Node_Id;
...@@ -266,15 +268,16 @@ package Checks is ...@@ -266,15 +268,16 @@ package Checks is
-- Insert_Action of the whole block (it is returned unanalyzed). The Loc -- Insert_Action of the whole block (it is returned unanalyzed). The Loc
-- parameter is used to supply Sloc values for the constructed tree. -- parameter is used to supply Sloc values for the constructed tree.
procedure Minimize_Eliminate_Overflow_Checks procedure Minimize_Eliminate_Overflows
(N : Node_Id; (N : Node_Id;
Lo : out Uint; Lo : out Uint;
Hi : out Uint; Hi : out Uint;
Top_Level : Boolean); Top_Level : Boolean);
-- This is the main routine for handling MINIMIZED and ELIMINATED overflow -- This is the main routine for handling MINIMIZED and ELIMINATED overflow
-- checks. On entry N is a node whose result is a signed integer subtype. -- processing. On entry N is a node whose result is a signed integer
-- If the node is an arithmetic operation, then a range analysis is carried -- subtype. The Do_Overflow_Check flag may or may not be set on N. If the
-- out, and there are three possibilities: -- node is an arithmetic operation, then a range analysis is carried out,
-- and there are three possibilities:
-- --
-- The node is left unchanged (apart from expansion of an exponentiation -- The node is left unchanged (apart from expansion of an exponentiation
-- operation). This happens if the routine can determine that the result -- operation). This happens if the routine can determine that the result
...@@ -313,16 +316,16 @@ package Checks is ...@@ -313,16 +316,16 @@ package Checks is
-- The routine is called in three situations if we are operating in either -- The routine is called in three situations if we are operating in either
-- MINIMIZED or ELIMINATED modes. -- MINIMIZED or ELIMINATED modes.
-- --
-- Overflow checks applied to the top node of an expression tree when -- Overflow processing applied to the top node of an expression tree when
-- that node is an arithmetic operator. In this case the result is -- that node is an arithmetic operator. In this case the result is
-- converted to the appropriate result type (there is special processing -- converted to the appropriate result type (there is special processing
-- when the parent is a conversion, see body for details). -- when the parent is a conversion, see body for details).
-- --
-- Overflow checks are applied to the operands of a comparison operation. -- Overflow processing applied to the operands of a comparison operation.
-- In this case, the comparison is done on the result Long_Long_Integer -- In this case, the comparison is done on the result Long_Long_Integer
-- or Bignum values, without raising any exceptions. -- or Bignum values, without raising any exceptions.
-- --
-- Overflow checks are applied to the left operand of a membership test. -- Overflow processing applied to the left operand of a membership test.
-- In this case no exception is raised if a Long_Long_Integer or Bignum -- In this case no exception is raised if a Long_Long_Integer or Bignum
-- result is outside the range of the type of that left operand (it is -- result is outside the range of the type of that left operand (it is
-- just that the result of IN is false in that case). -- just that the result of IN is false in that case).
...@@ -332,13 +335,13 @@ package Checks is ...@@ -332,13 +335,13 @@ package Checks is
-- --
-- Top_Level is used to avoid inefficient unnecessary transitions into the -- Top_Level is used to avoid inefficient unnecessary transitions into the
-- Bignum domain. If Top_Level is True, it means that the caller will have -- Bignum domain. If Top_Level is True, it means that the caller will have
-- to convert any Bignum value back to Long_Long_Integer, checking that the -- to convert any Bignum value back to Long_Long_Integer, possibly checking
-- value is in range. This is the normal case for a top level operator in -- that the value is in range. This is the normal case for a top level
-- a subexpression. There is no point in going into Bignum mode to avoid an -- operator in a subexpression. There is no point in going into Bignum mode
-- overflow just so we can check for overflow the next moment. For calls -- to avoid an overflow just so we can check for overflow the next moment.
-- from comparisons and membership tests, and for all recursive calls, we -- For calls from comparisons and membership tests, and for all recursive
-- do want to transition into the Bignum domain if necessary. Note that -- calls, we do want to transition into the Bignum domain if necessary.
-- this setting is only relevant in ELIMINATED mode. -- Note that this setting is only relevant in ELIMINATED mode.
------------------------------------------------------- -------------------------------------------------------
-- Control and Optimization of Range/Overflow Checks -- -- Control and Optimization of Range/Overflow Checks --
...@@ -370,9 +373,7 @@ package Checks is ...@@ -370,9 +373,7 @@ package Checks is
-- has no effect. If a check is needed then this routine sets the flag -- has no effect. If a check is needed then this routine sets the flag
-- Do_Overflow_Check in node N to True, unless it can be determined that -- Do_Overflow_Check in node N to True, unless it can be determined that
-- the check is not needed. The only condition under which this is the -- the check is not needed. The only condition under which this is the
-- case is if there was an identical check earlier on. These optimziations -- case is if there was an identical check earlier on.
-- apply to CHECKED mode, but not to MINIMIZED/ELIMINATED modes. See the
-- body for a full explanation.
procedure Enable_Range_Check (N : Node_Id); procedure Enable_Range_Check (N : Node_Id);
-- Set Do_Range_Check flag in node N True, unless it can be determined -- Set Do_Range_Check flag in node N True, unless it can be determined
......
gcc/ada/exp_ch4.adb
...@@ -213,19 +213,19 @@ package body Exp_Ch4 is ...@@ -213,19 +213,19 @@ package body Exp_Ch4 is
-- Convert_To_Actual_Subtype if necessary). -- Convert_To_Actual_Subtype if necessary).
function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean; function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean;
-- For signed arithmetic operations with Do_Overflow_Check set when the -- For signed arithmetic operations when the current overflow mode is
-- current overflow mode is MINIMIZED or ELIMINATED, we need to make a -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
-- call to Apply_Arithmetic_Overflow_Checks as the first thing we do. We -- as the first thing we do. We then return. We count on the recursive
-- then return. We count on the recursive apparatus for overflow checks -- apparatus for overflow checks to call us back with an equivalent
-- to call us back with an equivalent operation that does not have the -- operation that is in CHECKED mode, avoiding a recursive entry into this
-- Do_Overflow_Check flag set, and that is when we will proceed with the -- routine, and that is when we will proceed with the expansion of the
-- expansion of the operator (e.g. converting X+0 to X, or X**2 to X*X). -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
-- We cannot do these optimizations without first making this check, since -- these optimizations without first making this check, since there may be
-- there may be operands further down the tree that are relying on the -- operands further down the tree that are relying on the recursive calls
-- recursive calls triggered by the top level nodes to properly process -- triggered by the top level nodes to properly process overflow checking
-- overflow checking and remaining expansion on these nodes. Note that -- and remaining expansion on these nodes. Note that this call back may be
-- this call back may be skipped if the operation is done in Bignum mode -- skipped if the operation is done in Bignum mode but that's fine, since
-- but that's fine, since the Bignum call takes care of everything. -- the Bignum call takes care of everything.
procedure Optimize_Length_Comparison (N : Node_Id); procedure Optimize_Length_Comparison (N : Node_Id);
-- Given an expression, if it is of the form X'Length op N (or the other -- Given an expression, if it is of the form X'Length op N (or the other
...@@ -2274,8 +2274,8 @@ package body Exp_Ch4 is ...@@ -2274,8 +2274,8 @@ package body Exp_Ch4 is
LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
-- Entity for Long_Long_Integer'Base -- Entity for Long_Long_Integer'Base
Check : constant Overflow_Check_Type := Overflow_Check_Mode (Empty); Check : constant Overflow_Check_Type := Overflow_Check_Mode;
-- Current checking mode -- Current overflow checking mode
procedure Set_True; procedure Set_True;
procedure Set_False; procedure Set_False;
...@@ -2320,9 +2320,9 @@ package body Exp_Ch4 is ...@@ -2320,9 +2320,9 @@ package body Exp_Ch4 is
-- our operands using the Minimize_Eliminate circuitry which applies -- our operands using the Minimize_Eliminate circuitry which applies
-- this processing to the two operand subtrees. -- this processing to the two operand subtrees.
Minimize_Eliminate_Overflow_Checks Minimize_Eliminate_Overflows
(Left_Opnd (N), Llo, Lhi, Top_Level => False); (Left_Opnd (N), Llo, Lhi, Top_Level => False);
Minimize_Eliminate_Overflow_Checks Minimize_Eliminate_Overflows
(Right_Opnd (N), Rlo, Rhi, Top_Level => False); (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
-- See if the range information decides the result of the comparison. -- See if the range information decides the result of the comparison.
...@@ -3721,7 +3721,7 @@ package body Exp_Ch4 is ...@@ -3721,7 +3721,7 @@ package body Exp_Ch4 is
-- Entity for Long_Long_Integer'Base (Standard should export this???) -- Entity for Long_Long_Integer'Base (Standard should export this???)
begin begin
Minimize_Eliminate_Overflow_Checks (Lop, Lo, Hi, Top_Level => False); Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
-- If right operand is a subtype name, and the subtype name has no -- If right operand is a subtype name, and the subtype name has no
-- predicate, then we can just replace the right operand with an -- predicate, then we can just replace the right operand with an
...@@ -3751,9 +3751,9 @@ package body Exp_Ch4 is ...@@ -3751,9 +3751,9 @@ package body Exp_Ch4 is
-- have not been processed for minimized or eliminated checks. -- have not been processed for minimized or eliminated checks.
if Nkind (Rop) = N_Range then if Nkind (Rop) = N_Range then
Minimize_Eliminate_Overflow_Checks Minimize_Eliminate_Overflows
(Low_Bound (Rop), Lo, Hi, Top_Level => False); (Low_Bound (Rop), Lo, Hi, Top_Level => False);
Minimize_Eliminate_Overflow_Checks Minimize_Eliminate_Overflows
(High_Bound (Rop), Lo, Hi, Top_Level => False); (High_Bound (Rop), Lo, Hi, Top_Level => False);
-- We have A in B .. C, treated as A >= B and then A <= C -- We have A in B .. C, treated as A >= B and then A <= C
...@@ -5498,7 +5498,7 @@ package body Exp_Ch4 is ...@@ -5498,7 +5498,7 @@ package body Exp_Ch4 is
-- in which case, this usage makes sense, and in any case, we have -- in which case, this usage makes sense, and in any case, we have
-- actually eliminated the danger of optimization above. -- actually eliminated the danger of optimization above.
if Overflow_Check_Mode (Restyp) not in Minimized_Or_Eliminated then if Overflow_Check_Mode not in Minimized_Or_Eliminated then
Error_Msg_N ("?explicit membership test may be optimized away", N); Error_Msg_N ("?explicit membership test may be optimized away", N);
Error_Msg_N -- CODEFIX Error_Msg_N -- CODEFIX
("\?use ''Valid attribute instead", N); ("\?use ''Valid attribute instead", N);
...@@ -5526,7 +5526,7 @@ package body Exp_Ch4 is ...@@ -5526,7 +5526,7 @@ package body Exp_Ch4 is
-- type, then expand with a separate procedure. Note the use of the -- type, then expand with a separate procedure. Note the use of the
-- flag No_Minimize_Eliminate to prevent infinite recursion. -- flag No_Minimize_Eliminate to prevent infinite recursion.
if Overflow_Check_Mode (Empty) in Minimized_Or_Eliminated if Overflow_Check_Mode in Minimized_Or_Eliminated
and then Is_Signed_Integer_Type (Ltyp) and then Is_Signed_Integer_Type (Ltyp)
and then not No_Minimize_Eliminate (N) and then not No_Minimize_Eliminate (N)
then then
...@@ -11785,8 +11785,7 @@ package body Exp_Ch4 is ...@@ -11785,8 +11785,7 @@ package body Exp_Ch4 is
begin begin
return return
Is_Signed_Integer_Type (Etype (N)) Is_Signed_Integer_Type (Etype (N))
and then Do_Overflow_Check (N) and then Overflow_Check_Mode in Minimized_Or_Eliminated;
and then Overflow_Check_Mode (Empty) in Minimized_Or_Eliminated;
end Minimized_Eliminated_Overflow_Check; end Minimized_Eliminated_Overflow_Check;
-------------------------------- --------------------------------
......
gcc/ada/exp_util.adb
...@@ -3840,11 +3840,11 @@ package body Exp_Util is ...@@ -3840,11 +3840,11 @@ package body Exp_Util is
begin begin
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Record := Scope_Suppress; Sva : constant Suppress_Array := Scope_Suppress.Suppress;
begin begin
Scope_Suppress := Suppress_All; Scope_Suppress.Suppress := (others => True);
Insert_Actions (Assoc_Node, Ins_Actions); Insert_Actions (Assoc_Node, Ins_Actions);
Scope_Suppress := Svg; Scope_Suppress.Suppress := Sva;
end; end;
else else
...@@ -6727,7 +6727,7 @@ package body Exp_Util is ...@@ -6727,7 +6727,7 @@ package body Exp_Util is
-- All this must not have any checks -- All this must not have any checks
Scope_Suppress := Suppress_All; Scope_Suppress.Suppress := (others => True);
-- If it is a scalar type and we need to capture the value, just make -- If it is a scalar type and we need to capture the value, just make
-- a copy. Likewise for a function call, an attribute reference, an -- a copy. Likewise for a function call, an attribute reference, an
......
gcc/ada/gnat1drv.adb
...@@ -192,14 +192,12 @@ procedure Gnat1drv is ...@@ -192,14 +192,12 @@ procedure Gnat1drv is
-- Enable all other language checks -- Enable all other language checks
Suppress_Options := Suppress_Options.Suppress :=
(Suppress => (Access_Check => True, (Access_Check => True,
Alignment_Check => True, Alignment_Check => True,
Division_Check => True, Division_Check => True,
Elaboration_Check => True, Elaboration_Check => True,
others => False), others => False);
Overflow_Checks_General => Suppressed,
Overflow_Checks_Assertions => Suppressed);
Dynamic_Elaboration_Checks := False; Dynamic_Elaboration_Checks := False;
...@@ -328,25 +326,32 @@ procedure Gnat1drv is ...@@ -328,25 +326,32 @@ procedure Gnat1drv is
Exception_Mechanism := Back_End_Exceptions; Exception_Mechanism := Back_End_Exceptions;
end if; end if;
-- Set proper status for overflow checks -- Set proper status for overflow check mechanism
-- If already set (by - gnato or -gnatp) then we have nothing to do -- If already set (by -gnato) then we have nothing to do
if Opt.Suppress_Options.Overflow_Checks_General /= Not_Set then if Opt.Suppress_Options.Overflow_Checks_General /= Not_Set then
null; null;
-- Otherwise set appropriate default mode. Note: at present we set -- Otherwise set overflow mode defaults
-- SUPPRESSED in all three of the following cases. They are separated
-- because in the future we may make different choices.
-- By default suppress overflow checks in -gnatg mode else
-- Otherwise set overflow checks off by default
Suppress_Options.Suppress (Overflow_Check) := True;
-- Set appropriate default overflow handling mode. Note: at present
-- we set STRICT in all three of the following cases. They are
-- separated because in the future we may make different choices.
elsif GNAT_Mode then -- By default set STRICT mode if -gnatg in effect
Suppress_Options.Overflow_Checks_General := Suppressed;
Suppress_Options.Overflow_Checks_Assertions := Suppressed; if GNAT_Mode then
Suppress_Options.Overflow_Checks_General := Strict;
Suppress_Options.Overflow_Checks_Assertions := Strict;
-- If we have backend divide and overflow checks, then by default -- If we have backend divide and overflow checks, then by default
-- overflow checks are suppressed. Historically this code used to -- overflow checks are STRICT. Historically this code used to also
-- activate overflow checks, although no target currently has these -- activate overflow checks, although no target currently has these
-- flags set, so this was dead code anyway. -- flags set, so this was dead code anyway.
...@@ -354,16 +359,17 @@ procedure Gnat1drv is ...@@ -354,16 +359,17 @@ procedure Gnat1drv is
and and
Targparm.Backend_Overflow_Checks_On_Target Targparm.Backend_Overflow_Checks_On_Target
then then
Suppress_Options.Overflow_Checks_General := Suppressed; Suppress_Options.Overflow_Checks_General := Strict;
Suppress_Options.Overflow_Checks_Assertions := Suppressed; Suppress_Options.Overflow_Checks_Assertions := Strict;
-- Otherwise for now, default is checks are suppressed. This is subject -- Otherwise for now, default is STRICT mode. This may change in the
-- to change in the future, but for now this is the compatible behavior -- future, but for now this is the compatible behavior with previous
-- with previous versions of GNAT. -- versions of GNAT.
else else
Suppress_Options.Overflow_Checks_General := Suppressed; Suppress_Options.Overflow_Checks_General := Strict;
Suppress_Options.Overflow_Checks_Assertions := Suppressed; Suppress_Options.Overflow_Checks_Assertions := Strict;
end if;
end if; end if;
-- Set default for atomic synchronization. As this synchronization -- Set default for atomic synchronization. As this synchronization
......
gcc/ada/sem.adb
...@@ -723,29 +723,15 @@ package body Sem is ...@@ -723,29 +723,15 @@ package body Sem is
begin begin
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Record := Scope_Suppress; Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin begin
Scope_Suppress := Suppress_All; Scope_Suppress.Suppress := (others => True);
Analyze (N); Analyze (N);
Scope_Suppress := Svg; Scope_Suppress.Suppress := Svs;
end; end;
elsif Suppress = Overflow_Check then elsif Suppress = Overflow_Check then
declare declare
Svg : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_General;
Sva : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_Assertions;
begin
Scope_Suppress.Overflow_Checks_General := Suppressed;
Scope_Suppress.Overflow_Checks_Assertions := Suppressed;
Analyze (N);
Scope_Suppress.Overflow_Checks_General := Svg;
Scope_Suppress.Overflow_Checks_Assertions := Sva;
end;
else
declare
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin begin
Scope_Suppress.Suppress (Suppress) := True; Scope_Suppress.Suppress (Suppress) := True;
...@@ -776,25 +762,11 @@ package body Sem is ...@@ -776,25 +762,11 @@ package body Sem is
begin begin
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Record := Scope_Suppress; Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin
Scope_Suppress := Suppress_All;
Analyze_List (L);
Scope_Suppress := Svg;
end;
elsif Suppress = Overflow_Check then
declare
Svg : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_General;
Sva : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_Assertions;
begin begin
Scope_Suppress.Overflow_Checks_General := Suppressed; Scope_Suppress.Suppress := (others => True);
Scope_Suppress.Overflow_Checks_Assertions := Suppressed;
Analyze_List (L); Analyze_List (L);
Scope_Suppress.Overflow_Checks_General := Svg; Scope_Suppress.Suppress := Svs;
Scope_Suppress.Overflow_Checks_Assertions := Sva;
end; end;
else else
...@@ -1051,11 +1023,11 @@ package body Sem is ...@@ -1051,11 +1023,11 @@ package body Sem is
begin begin
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Record := Scope_Suppress; Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin begin
Scope_Suppress := Suppress_All; Scope_Suppress.Suppress := (others => True);
Insert_After_And_Analyze (N, M); Insert_After_And_Analyze (N, M);
Scope_Suppress := Svg; Scope_Suppress.Suppress := Svs;
end; end;
else else
...@@ -1111,11 +1083,11 @@ package body Sem is ...@@ -1111,11 +1083,11 @@ package body Sem is
begin begin
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Record := Scope_Suppress; Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin begin
Scope_Suppress := Suppress_All; Scope_Suppress.Suppress := (others => True);
Insert_Before_And_Analyze (N, M); Insert_Before_And_Analyze (N, M);
Scope_Suppress := Svg; Scope_Suppress.Suppress := Svs;
end; end;
else else
...@@ -1170,11 +1142,11 @@ package body Sem is ...@@ -1170,11 +1142,11 @@ package body Sem is
begin begin
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Record := Scope_Suppress; Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin begin
Scope_Suppress := Suppress_All; Scope_Suppress.Suppress := (others => True);
Insert_List_After_And_Analyze (N, L); Insert_List_After_And_Analyze (N, L);
Scope_Suppress := Svg; Scope_Suppress.Suppress := Svs;
end; end;
else else
...@@ -1228,11 +1200,11 @@ package body Sem is ...@@ -1228,11 +1200,11 @@ package body Sem is
begin begin
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Record := Scope_Suppress; Svs : constant Suppress_Array := Scope_Suppress.Suppress;
begin begin
Scope_Suppress := Suppress_All; Scope_Suppress.Suppress := (others => True);
Insert_List_Before_And_Analyze (N, L); Insert_List_Before_And_Analyze (N, L);
Scope_Suppress := Svg; Scope_Suppress.Suppress := Svs;
end; end;
else else
......
gcc/ada/sem_prag.adb
...@@ -2121,7 +2121,8 @@ package body Sem_Prag is ...@@ -2121,7 +2121,8 @@ package body Sem_Prag is
(Get_Pragma_Arg (Arg2), Standard_String); (Get_Pragma_Arg (Arg2), Standard_String);
end if; end if;
-- Record if pragma is disabled -- For a pragma in the extended main source unit, record enabled
-- status in SCO (note: there is never any SCO for an instance).
if Check_Enabled (Pname) then if Check_Enabled (Pname) then
Set_SCO_Pragma_Enabled (Loc); Set_SCO_Pragma_Enabled (Loc);
...@@ -5058,6 +5059,7 @@ package body Sem_Prag is ...@@ -5058,6 +5059,7 @@ package body Sem_Prag is
-- If previous error, avoid cascaded errors -- If previous error, avoid cascaded errors
Cascaded_Error;
Applies := True; Applies := True;
Effective := True; Effective := True;
...@@ -5703,18 +5705,6 @@ package body Sem_Prag is ...@@ -5703,18 +5705,6 @@ package body Sem_Prag is
("argument of pragma% is not valid check name", Arg1); ("argument of pragma% is not valid check name", Arg1);
end if; end if;
-- Special processing for overflow check case
if C = All_Checks or else C = Overflow_Check then
if Suppress_Case then
Scope_Suppress.Overflow_Checks_General := Suppressed;
Scope_Suppress.Overflow_Checks_Assertions := Suppressed;
else
Scope_Suppress.Overflow_Checks_General := Checked;
Scope_Suppress.Overflow_Checks_Assertions := Checked;
end if;
end if;
if Arg_Count = 1 then if Arg_Count = 1 then
-- Make an entry in the local scope suppress table. This is the -- Make an entry in the local scope suppress table. This is the
...@@ -12007,10 +11997,11 @@ package body Sem_Prag is ...@@ -12007,10 +11997,11 @@ package body Sem_Prag is
-- pragma Overflow_Checks -- pragma Overflow_Checks
-- ([General => ] MODE [, [Assertions => ] MODE]); -- ([General => ] MODE [, [Assertions => ] MODE]);
-- MODE := SUPPRESSED | CHECKED | MINIMIZED | ELIMINATED -- MODE := STRICT | MINIMIZED | ELIMINATED
-- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
-- since System.Bignums makes this assumption. -- since System.Bignums makes this assumption. This is true of nearly
-- all (all?) targets.
when Pragma_Overflow_Checks => Overflow_Checks : declare when Pragma_Overflow_Checks => Overflow_Checks : declare
function Get_Check_Mode function Get_Check_Mode
...@@ -12034,19 +12025,8 @@ package body Sem_Prag is ...@@ -12034,19 +12025,8 @@ package body Sem_Prag is
Check_Optional_Identifier (Arg, Name); Check_Optional_Identifier (Arg, Name);
Check_Arg_Is_Identifier (Argx); Check_Arg_Is_Identifier (Argx);
-- Do not suppress overflow checks for formal verification. if Chars (Argx) = Name_Strict then
-- Instead, require that a check is inserted so that formal return Strict;
-- verification can detect wraparound errors.
if Chars (Argx) = Name_Suppressed then
if Alfa_Mode then
return Checked;
else
return Suppressed;
end if;
elsif Chars (Argx) = Name_Checked then
return Checked;
elsif Chars (Argx) = Name_Minimized then elsif Chars (Argx) = Name_Minimized then
return Minimized; return Minimized;
...@@ -14545,6 +14525,7 @@ package body Sem_Prag is ...@@ -14545,6 +14525,7 @@ package body Sem_Prag is
-- Note: in previous versions of GNAT we used to check for limited -- Note: in previous versions of GNAT we used to check for limited
-- types and give an error, but in fact the standard does allow -- types and give an error, but in fact the standard does allow
-- Unchecked_Union on limited types, so this check was removed. -- Unchecked_Union on limited types, so this check was removed.
-- Similarly, GNAT used to require that all discriminants have -- Similarly, GNAT used to require that all discriminants have
-- default values, but this is not mandated by the RM. -- default values, but this is not mandated by the RM.
......
gcc/ada/sem_res.adb
...@@ -334,25 +334,11 @@ package body Sem_Res is ...@@ -334,25 +334,11 @@ package body Sem_Res is
begin begin
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Record := Scope_Suppress; Sva : constant Suppress_Array := Scope_Suppress.Suppress;
begin begin
Scope_Suppress := Suppress_All; Scope_Suppress.Suppress := (others => True);
Analyze_And_Resolve (N, Typ); Analyze_And_Resolve (N, Typ);
Scope_Suppress := Svg; Scope_Suppress.Suppress := Sva;
end;
elsif Suppress = Overflow_Check then
declare
Svg : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_General;
Sva : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_Assertions;
begin
Scope_Suppress.Overflow_Checks_General := Suppressed;
Scope_Suppress.Overflow_Checks_Assertions := Suppressed;
Analyze_And_Resolve (N, Typ);
Scope_Suppress.Overflow_Checks_General := Svg;
Scope_Suppress.Overflow_Checks_Assertions := Sva;
end; end;
else else
...@@ -388,25 +374,11 @@ package body Sem_Res is ...@@ -388,25 +374,11 @@ package body Sem_Res is
begin begin
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Record := Scope_Suppress; Sva : constant Suppress_Array := Scope_Suppress.Suppress;
begin
Scope_Suppress := Suppress_All;
Analyze_And_Resolve (N);
Scope_Suppress := Svg;
end;
elsif Suppress = Overflow_Check then
declare
Svg : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_General;
Sva : constant Overflow_Check_Type :=
Scope_Suppress.Overflow_Checks_Assertions;
begin begin
Scope_Suppress.Overflow_Checks_General := Suppressed; Scope_Suppress.Suppress := (others => True);
Scope_Suppress.Overflow_Checks_Assertions := Suppressed;
Analyze_And_Resolve (N); Analyze_And_Resolve (N);
Scope_Suppress.Overflow_Checks_General := Svg; Scope_Suppress.Suppress := Sva;
Scope_Suppress.Overflow_Checks_Assertions := Sva;
end; end;
else else
...@@ -1690,19 +1662,23 @@ package body Sem_Res is ...@@ -1690,19 +1662,23 @@ package body Sem_Res is
Full_Analysis := False; Full_Analysis := False;
Expander_Mode_Save_And_Set (False); Expander_Mode_Save_And_Set (False);
-- We suppress all checks for this analysis, except in Alfa mode. -- Normally, we suppress all checks for this preanalysis. There is no
-- Otherwise the checks are applied properly, and in the proper -- point in processing them now, since they will be applied properly
-- location, when the default expressions are reanalyzed and reexpanded -- and in the proper location when the default expressions reanalyzed
-- later on. -- and reexpanded later on. We will also have more information at that
-- point for possible suppression of individual checks.
-- Alfa mode suppresses all expansion but requires the setting of -- However, in Alfa mode, most expansion is suppressed, and this
-- checking flags (DIvision_Check and others) in particular for Ada 2012 -- later reanalysis and reexpansion may not occur. Alfa mode does
-- constructs such as quantified expressions, that are expanded in two -- require the setting of checking flags for proof purposes, so we
-- separate steps. -- do the Alfa preanalysis without suppressing checks.
-- This special handling for Alfa mode is required for example in the
-- case of Ada 2012 constructs such as quantified expressions, which are
-- expanded in two separate steps.
if Alfa_Mode then if Alfa_Mode then
Analyze_And_Resolve (N, T); Analyze_And_Resolve (N, T);
else else
Analyze_And_Resolve (N, T, Suppress => All_Checks); Analyze_And_Resolve (N, T, Suppress => All_Checks);
end if; end if;
...@@ -2946,11 +2922,11 @@ package body Sem_Res is ...@@ -2946,11 +2922,11 @@ package body Sem_Res is
begin begin
if Suppress = All_Checks then if Suppress = All_Checks then
declare declare
Svg : constant Suppress_Record := Scope_Suppress; Sva : constant Suppress_Array := Scope_Suppress.Suppress;
begin begin
Scope_Suppress := Suppress_All; Scope_Suppress.Suppress := (others => True);
Resolve (N, Typ); Resolve (N, Typ);
Scope_Suppress := Svg; Scope_Suppress.Suppress := Sva;
end; end;
else else
...@@ -5959,16 +5935,6 @@ package body Sem_Res is ...@@ -5959,16 +5935,6 @@ package body Sem_Res is
Set_Etype (N, Typ); Set_Etype (N, Typ);
Eval_Case_Expression (N); Eval_Case_Expression (N);
-- If we still have a case expression, and overflow checks are enabled
-- in MINIMIZED or ELIMINATED modes, then set Do_Overflow_Check to
-- ensure that we handle overflow for dependent expressions.
if Nkind (N) = N_Case_Expression
and then Overflow_Check_Mode (Typ) in Minimized_Or_Eliminated
then
Set_Do_Overflow_Check (N);
end if;
end Resolve_Case_Expression; end Resolve_Case_Expression;
------------------------------- -------------------------------
...@@ -7215,16 +7181,6 @@ package body Sem_Res is ...@@ -7215,16 +7181,6 @@ package body Sem_Res is
Set_Etype (N, Typ); Set_Etype (N, Typ);
Eval_If_Expression (N); Eval_If_Expression (N);
-- If we still have a if expression, and overflow checks are enabled in
-- MINIMIZED or ELIMINATED modes, then set Do_Overflow_Check to ensure
-- that we handle overflow for dependent expressions.
if Nkind (N) = N_If_Expression
and then Overflow_Check_Mode (Typ) in Minimized_Or_Eliminated
then
Set_Do_Overflow_Check (N);
end if;
end Resolve_If_Expression; end Resolve_If_Expression;
------------------------------- -------------------------------
......
gcc/ada/snames.ads-tmpl
...@@ -665,7 +665,6 @@ package Snames is ...@@ -665,7 +665,6 @@ package Snames is
Name_By_Protected_Procedure : constant Name_Id := N + $; Name_By_Protected_Procedure : constant Name_Id := N + $;
Name_Casing : constant Name_Id := N + $; Name_Casing : constant Name_Id := N + $;
Name_Check_All : constant Name_Id := N + $; Name_Check_All : constant Name_Id := N + $;
Name_Checked : constant Name_Id := N + $;
Name_Code : constant Name_Id := N + $; Name_Code : constant Name_Id := N + $;
Name_Component : constant Name_Id := N + $; Name_Component : constant Name_Id := N + $;
Name_Component_Size_4 : constant Name_Id := N + $; Name_Component_Size_4 : constant Name_Id := N + $;
...@@ -739,6 +738,7 @@ package Snames is ...@@ -739,6 +738,7 @@ package Snames is
Name_State : constant Name_Id := N + $; Name_State : constant Name_Id := N + $;
Name_Static : constant Name_Id := N + $; Name_Static : constant Name_Id := N + $;
Name_Stack_Size : constant Name_Id := N + $; Name_Stack_Size : constant Name_Id := N + $;
Name_Strict : constant Name_Id := N + $;
Name_Subunit_File_Name : constant Name_Id := N + $; Name_Subunit_File_Name : constant Name_Id := N + $;
Name_Suppressed : constant Name_Id := N + $; Name_Suppressed : constant Name_Id := N + $;
Name_Task_Stack_Size_Default : constant Name_Id := N + $; Name_Task_Stack_Size_Default : constant Name_Id := N + $;
......
gcc/ada/switch-c.adb
...@@ -97,11 +97,8 @@ package body Switch.C is ...@@ -97,11 +97,8 @@ package body Switch.C is
function Get_Overflow_Mode (C : Character) return Overflow_Check_Type is function Get_Overflow_Mode (C : Character) return Overflow_Check_Type is
begin begin
case C is case C is
when '0' =>
return Suppressed;
when '1' => when '1' =>
return Checked; return Strict;
when '2' => when '2' =>
return Minimized; return Minimized;
...@@ -801,12 +798,13 @@ package body Switch.C is ...@@ -801,12 +798,13 @@ package body Switch.C is
when 'o' => when 'o' =>
Ptr := Ptr + 1; Ptr := Ptr + 1;
Suppress_Options.Suppress (Overflow_Check) := False;
-- Case of no digits after the -gnato -- Case of no digits after the -gnato
if Ptr > Max or else Switch_Chars (Ptr) not in '0' .. '3' then if Ptr > Max or else Switch_Chars (Ptr) not in '1' .. '3' then
Suppress_Options.Overflow_Checks_General := Checked; Suppress_Options.Overflow_Checks_General := Strict;
Suppress_Options.Overflow_Checks_Assertions := Checked; Suppress_Options.Overflow_Checks_Assertions := Strict;
-- At least one digit after the -gnato -- At least one digit after the -gnato
...@@ -821,7 +819,7 @@ package body Switch.C is ...@@ -821,7 +819,7 @@ package body Switch.C is
-- be the same as general mode. -- be the same as general mode.
if Ptr > Max if Ptr > Max
or else Switch_Chars (Ptr) not in '0' .. '3' or else Switch_Chars (Ptr) not in '1' .. '3'
then then
Suppress_Options.Overflow_Checks_Assertions := Suppress_Options.Overflow_Checks_Assertions :=
Suppress_Options.Overflow_Checks_General; Suppress_Options.Overflow_Checks_General;
...@@ -869,9 +867,6 @@ package body Switch.C is ...@@ -869,9 +867,6 @@ package body Switch.C is
end if; end if;
end loop; end loop;
Suppress_Options.Overflow_Checks_General := Suppressed;
Suppress_Options.Overflow_Checks_Assertions := Suppressed;
Validity_Checks_On := False; Validity_Checks_On := False;
Opt.Suppress_Checks := True; Opt.Suppress_Checks := True;
end if; end if;
......
gcc/ada/types.ads
...@@ -703,43 +703,39 @@ package Types is ...@@ -703,43 +703,39 @@ package Types is
-- 4. Add a new Do_xxx_Check flag to Sinfo (if required) -- 4. Add a new Do_xxx_Check flag to Sinfo (if required)
-- 5. Add appropriate checks for the new test -- 5. Add appropriate checks for the new test
-- The following provides precise details on the mode used to check -- The following provides precise details on the mode used to generate
-- intermediate overflows in expressions for signed integer arithmetic. -- code for intermediate overflows in expressions for signed integer
-- arithmetic (and how to generate overflow checks if enabled). Note
-- that this only affects handling of intermediate results. The final
-- result must always fit within the target range, and if overflow
-- checking is enabled, the check on the final result is against this
-- target range.
type Overflow_Check_Type is ( type Overflow_Check_Type is (
Not_Set, Not_Set,
-- Dummy value used during initialization process to show that the -- Dummy value used during initialization process to show that the
-- corresponding value has not yet been initialized. -- corresponding value has not yet been initialized.
Suppressed, Strict,
-- Overflow checking is suppressed. If an arithmetic operation creates -- Operations are done in the base type of the subexpression. If
-- an overflow, no exception is raised, and the program is erroneous. -- overflow checks are enabled, then the check is against the range
-- of this base type.
Checked,
-- All operations, including all intermediate operations are checked.
-- If the result of any arithmetic operation gives a result outside the
-- range of the base type, then a Constraint_Error exception is raised.
Minimized, Minimized,
-- Where appropriate, arithmetic operations are performed with an -- Where appropriate, intermediate arithmetic operations are performed
-- extended range, using Long_Long_Integer if necessary. As long as the -- with an extended range, using Long_Long_Integer if necessary. If
-- result fits in this extended range, then no exception is raised and -- overflow checking is enabled, then the check is against the range
-- computation continues with the extended result. The final value of an -- of Long_Long_Integer.
-- expression must fit in the base type of the whole expression. If an
-- intermediate result is outside the range of Long_Long_Integer then a
-- Constraint_Error exception is raised.
Eliminated); Eliminated);
-- In this mode arbitrary precision arithmetic is used as needed to -- In this mode arbitrary precision arithmetic is used as needed to
-- ensure that it is impossible for intermediate arithmetic to cause an -- ensure that it is impossible for intermediate arithmetic to cause an
-- overflow. Again the final value of an expression must fit in the base -- overflow. In this mode, intermediate expressions are not affected by
-- type of the whole expression. -- the overflow checking mode, since overflows are eliminated.
subtype Minimized_Or_Eliminated is subtype Minimized_Or_Eliminated is
Overflow_Check_Type range Minimized .. Eliminated; Overflow_Check_Type range Minimized .. Eliminated;
subtype Suppressed_Or_Checked is -- Define subtype so that clients don't need to know ordering. Note that
Overflow_Check_Type range Suppressed .. Checked;
-- Define subtypes so that clients don't need to know ordering. Note that
-- Overflow_Check_Type is not marked as an ordered enumeration type. -- Overflow_Check_Type is not marked as an ordered enumeration type.
-- The following structure captures the state of check suppression or -- The following structure captures the state of check suppression or
...@@ -747,24 +743,19 @@ package Types is ...@@ -747,24 +743,19 @@ package Types is
type Suppress_Record is record type Suppress_Record is record
Suppress : Suppress_Array; Suppress : Suppress_Array;
-- Indicates suppression status of each possible check. Note: there -- Indicates suppression status of each possible check
-- is an entry for Overflow_Check in this array, but it is never used.
-- Instead we use the more detailed information in the two components
-- that follow this one (Overflow_Checks_General/Assertions).
Overflow_Checks_General : Overflow_Check_Type; Overflow_Checks_General : Overflow_Check_Type;
-- This field indicates the mode of overflow checking to be applied to -- This field indicates the mode for handling code generation and
-- general expressions outside assertions. -- overflow checking (if enabled) for intermediate expression values.
-- This applies to general expressions outside assertions.
Overflow_Checks_Assertions : Overflow_Check_Type; Overflow_Checks_Assertions : Overflow_Check_Type;
-- This field indicates the mode of overflow checking to be applied to -- This field indicates the mode for handling code generation and
-- any expression occuring inside assertions. -- overflow checking (if enabled) for intermediate expression values.
-- This applies to any expression occuring inside assertions.
end record; end record;
Suppress_All : constant Suppress_Record :=
((others => True), Suppressed, Suppressed);
-- Constant used to initialize Suppress_Record value to all suppressed.
----------------------------------- -----------------------------------
-- Global Exception Declarations -- -- Global Exception Declarations --
----------------------------------- -----------------------------------
......
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