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

[multiple changes] 

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

	* exp_util.adb, switch-c.adb, inline.ads, sem_ch10.adb, types.ads,
	checks.adb, sem_prag.adb, sem.adb, sem.ads, sem_res.adb, sem_attr.adb,
	gnat1drv.adb, exp_ch4.adb, exp_ch6.adb, opt.ads, osint.adb: Implement
	extended overflow checks (step 1).
	(Overflow_Check_Type, Suppress_Record, Suppress_All): New types.
	(Suppress_Array): Extended to include switches to control extended
	overflow checking (and renamed to Suppress_Record).
	Update all uses of Suppress_Array.

2012-08-06  Thomas Quinot  <quinot@adacore.com>

	* makeutl.ads: Minor documentation fix.

2012-08-06  Thomas Quinot  <quinot@adacore.com>

	* exp_ch7.adb: Minor reformatting.

From-SVN: r190166
This commit is contained in:
Arnaud Charlet 2012-08-06 10:26:27 +02:00
parent e68077239d
commit 3217f71e44
19 changed files with 218 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
gcc/ada/ChangeLog
View File

@ -1,3 +1,22 @@
2012-08-06 Robert Dewar <dewar@adacore.com>
* exp_util.adb, switch-c.adb, inline.ads, sem_ch10.adb, types.ads,
checks.adb, sem_prag.adb, sem.adb, sem.ads, sem_res.adb, sem_attr.adb,
gnat1drv.adb, exp_ch4.adb, exp_ch6.adb, opt.ads, osint.adb: Implement
extended overflow checks (step 1).
(Overflow_Check_Type, Suppress_Record, Suppress_All): New types.
(Suppress_Array): Extended to include switches to control extended
overflow checking (and renamed to Suppress_Record).
Update all uses of Suppress_Array.
2012-08-06 Thomas Quinot <quinot@adacore.com>
* makeutl.ads: Minor documentation fix.
2012-08-06 Thomas Quinot <quinot@adacore.com>
* exp_ch7.adb: Minor reformatting.
2012-08-06 Geert Bosch <bosch@adacore.com>
* a-ngelfu.adb: Change obsolete comment that this is a non-strict

35
gcc/ada/checks.adb
View File

@ -322,7 +322,7 @@ package body Checks is
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Access_Check);
else
return Scope_Suppress (Access_Check);
return Scope_Suppress.Suppress (Access_Check);
end if;
end Access_Checks_Suppressed;
@ -335,7 +335,7 @@ package body Checks is
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Accessibility_Check);
else
return Scope_Suppress (Accessibility_Check);
return Scope_Suppress.Suppress (Accessibility_Check);
end if;
end Accessibility_Checks_Suppressed;
@ -378,7 +378,7 @@ package body Checks is
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Alignment_Check);
else
return Scope_Suppress (Alignment_Check);
return Scope_Suppress.Suppress (Alignment_Check);
end if;
end Alignment_Checks_Suppressed;
@ -2616,7 +2616,7 @@ package body Checks is
-- Otherwise result depends on current scope setting
else
return Scope_Suppress (Atomic_Synchronization);
return Scope_Suppress.Suppress (Atomic_Synchronization);
end if;
end Atomic_Synchronization_Disabled;
@ -3641,7 +3641,7 @@ package body Checks is
end if;
end if;
return Scope_Suppress (Discriminant_Check);
return Scope_Suppress.Suppress (Discriminant_Check);
end Discriminant_Checks_Suppressed;
--------------------------------
@ -3653,7 +3653,7 @@ package body Checks is
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Division_Check);
else
return Scope_Suppress (Division_Check);
return Scope_Suppress.Suppress (Division_Check);
end if;
end Division_Checks_Suppressed;
@ -3682,10 +3682,10 @@ package body Checks is
end if;
end if;
if Scope_Suppress (Elaboration_Check) then
if Scope_Suppress.Suppress (Elaboration_Check) then
return True;
elsif Dynamic_Elaboration_Checks then
return Scope_Suppress (All_Checks);
return Scope_Suppress.Suppress (All_Checks);
else
return False;
end if;
@ -5305,7 +5305,7 @@ package body Checks is
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Index_Check);
else
return Scope_Suppress (Index_Check);
return Scope_Suppress.Suppress (Index_Check);
end if;
end Index_Checks_Suppressed;
@ -5821,7 +5821,7 @@ package body Checks is
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Length_Check);
else
return Scope_Suppress (Length_Check);
return Scope_Suppress.Suppress (Length_Check);
end if;
end Length_Checks_Suppressed;
@ -5834,7 +5834,7 @@ package body Checks is
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Overflow_Check);
else
return Scope_Suppress (Overflow_Check);
return Scope_Suppress.Suppress (Overflow_Check);
end if;
end Overflow_Checks_Suppressed;
@ -5858,7 +5858,7 @@ package body Checks is
end if;
end if;
return Scope_Suppress (Range_Check);
return Scope_Suppress.Suppress (Range_Check);
end Range_Checks_Suppressed;
-----------------------------------------
@ -5875,7 +5875,10 @@ package body Checks is
begin
-- Immediate return if scope checks suppressed for either check
if Scope_Suppress (Range_Check) or Scope_Suppress (Validity_Check) then
if Scope_Suppress.Suppress (Range_Check)
or
Scope_Suppress.Suppress (Validity_Check)
then
return True;
end if;
@ -7356,7 +7359,7 @@ package body Checks is
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Storage_Check);
else
return Scope_Suppress (Storage_Check);
return Scope_Suppress.Suppress (Storage_Check);
end if;
end Storage_Checks_Suppressed;
@ -7372,7 +7375,7 @@ package body Checks is
return Is_Check_Suppressed (E, Tag_Check);
end if;
return Scope_Suppress (Tag_Check);
return Scope_Suppress.Suppress (Tag_Check);
end Tag_Checks_Suppressed;
--------------------------
@ -7398,7 +7401,7 @@ package body Checks is
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Validity_Check);
else
return Scope_Suppress (Validity_Check);
return Scope_Suppress.Suppress (Validity_Check);
end if;
end Validity_Checks_Suppressed;

2
gcc/ada/exp_ch4.adb
View File

@ -699,7 +699,7 @@ package body Exp_Ch4 is
begin
if Ada_Version >= Ada_2005
and then Is_Class_Wide_Type (DesigT)
and then not Scope_Suppress (Accessibility_Check)
and then not Scope_Suppress.Suppress (Accessibility_Check)
and then
(Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
or else

2
gcc/ada/exp_ch6.adb
View File

@ -7474,7 +7474,7 @@ package body Exp_Ch6 is
elsif Ada_Version >= Ada_2005
and then Tagged_Type_Expansion
and then Is_Class_Wide_Type (R_Type)
and then not Scope_Suppress (Accessibility_Check)
and then not Scope_Suppress.Suppress (Accessibility_Check)
and then
(Is_Class_Wide_Type (Etype (Exp))
or else Nkind_In (Exp, N_Type_Conversion,

10
gcc/ada/exp_ch7.adb
View File

@ -4410,6 +4410,8 @@ package body Exp_Ch7 is
Stmts : List_Id;
Temp_Id : Entity_Id;
-- Start of processing for Process_Transient_Objects
begin
-- Examine all objects in the list First_Object .. Last_Object
@ -4629,10 +4631,10 @@ package body Exp_Ch7 is
end if;
declare
Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
First_Obj : Node_Id;
Last_Obj : Node_Id;
Target : Node_Id;
Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
First_Obj : Node_Id;
Last_Obj : Node_Id;
Target : Node_Id;
begin
-- If the node to be wrapped is the trigger of an asynchronous

18
gcc/ada/exp_util.adb
View File

@ -3818,20 +3818,20 @@ package body Exp_Util is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Scope_Suppress := Suppress_All;
Insert_Actions (Assoc_Node, Ins_Actions);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Scope_Suppress.Suppress (Suppress) := True;
Insert_Actions (Assoc_Node, Ins_Actions);
Scope_Suppress (Suppress) := Svg;
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Insert_Actions;
@ -6272,9 +6272,9 @@ package body Exp_Util is
Name_Req : Boolean := False;
Variable_Ref : Boolean := False)
is
Loc : constant Source_Ptr := Sloc (Exp);
Exp_Type : constant Entity_Id := Etype (Exp);
Svg_Suppress : constant Suppress_Array := Scope_Suppress;
Loc : constant Source_Ptr := Sloc (Exp);
Exp_Type : constant Entity_Id := Etype (Exp);
Svg_Suppress : constant Suppress_Record := Scope_Suppress;
Def_Id : Entity_Id;
E : Node_Id;
New_Exp : Node_Id;
@ -6705,7 +6705,7 @@ package body Exp_Util is
-- All this must not have any checks
Scope_Suppress := (others => True);
Scope_Suppress := Suppress_All;
-- 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

30
gcc/ada/gnat1drv.adb
View File

@ -193,13 +193,16 @@ procedure Gnat1drv is
-- Enable all other language checks
Suppress_Options :=
(Access_Check => True,
Alignment_Check => True,
Division_Check => True,
Elaboration_Check => True,
Overflow_Check => True,
others => False);
Enable_Overflow_Checks := False;
(Suppress => (Access_Check => True,
Alignment_Check => True,
Division_Check => True,
Elaboration_Check => True,
Overflow_Check => True,
others => False),
Overflow_Checks_General => Suppress,
Overflow_Checks_Assertions => Suppress);
Enable_Overflow_Checks := False;
Dynamic_Elaboration_Checks := False;
-- Kill debug of generated code, since it messes up sloc values
@ -339,9 +342,11 @@ procedure Gnat1drv is
and
Targparm.Backend_Overflow_Checks_On_Target))
then
Suppress_Options (Overflow_Check) := False;
Suppress_Options.Suppress (Overflow_Check) := False;
else
Suppress_Options (Overflow_Check) := True;
Suppress_Options.Suppress (Overflow_Check) := True;
Suppress_Options.Overflow_Checks_General := Check_All;
Suppress_Options.Overflow_Checks_Assertions := Check_All;
end if;
-- Set default for atomic synchronization. As this synchronization
@ -349,7 +354,8 @@ procedure Gnat1drv is
-- on some targets, an optional target parameter can turn the option
-- off. Note Atomic Synchronization is implemented as check.
Suppress_Options (Atomic_Synchronization) := not Atomic_Sync_Default;
Suppress_Options.Suppress (Atomic_Synchronization) :=
not Atomic_Sync_Default;
-- Set switch indicating if we can use N_Expression_With_Actions
@ -426,12 +432,12 @@ procedure Gnat1drv is
Restrict.Restrictions.Set (No_Initialize_Scalars) := True;
-- Suppress all language checks since they are handled implicitly by
-- the formal verification backend.
-- the formal verification backend.
-- Turn off dynamic elaboration checks.
-- Turn off alignment checks.
-- Turn off validity checking.
Suppress_Options := (others => True);
Suppress_Options := Suppress_All;
Enable_Overflow_Checks := False;
Dynamic_Elaboration_Checks := False;
Reset_Validity_Check_Options;

2
gcc/ada/inline.ads
View File

@ -70,7 +70,7 @@ package Inline is
-- be restored when compiling the body, to insure that internal enti-
-- ties use the same counter and are unique over spec and body.
Scope_Suppress : Suppress_Array;
Scope_Suppress : Suppress_Record;
Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr;
-- Save suppress information at the point of instantiation. Used to
-- properly inherit check status active at this point (see RM 11.5

3
gcc/ada/makeutl.ads
View File

@ -138,7 +138,8 @@ package Makeutl is
-- Do nothing if Switch is an absolute path switch. If relative, fail if
-- Parent is the empty string, otherwise prepend the path with Parent. This
-- subprogram is only used when using project files. If For_Gnatbind is
-- True, gnatbind switches that are not paths (-L, -A) are left unchaned.
-- True, consider gnatbind specific syntax for -L (not a path, left
-- unchanged) and -A (path is optional, preceded with "=" if present).
-- If Including_RTS is True, process also switches --RTS=. Do_Fail is
-- called in case of error. Using Osint.Fail might be appropriate.

7
gcc/ada/opt.ads
View File

@ -1070,8 +1070,9 @@ package Opt is
Overflow_Checks_Unsuppressed : Boolean := False;
-- GNAT
-- Set to True if at least one occurrence of pragma Unsuppress
-- (All_Checks|Overflow_Checks) has been processed.
-- This flag is True if there has been at least one pragma with the
-- effect of unsuppressing overflow checks, meaning that a more careful
-- check of the current mode is required.
Persistent_BSS_Mode : Boolean := False;
-- GNAT
@ -1249,7 +1250,7 @@ package Opt is
-- GNAT
-- Set to True if -gnatp (suppress all checks) switch present.
Suppress_Options : Suppress_Array;
Suppress_Options : Suppress_Record;
-- GNAT
-- Flags set True to suppress corresponding check, i.e. add an implicit
-- pragma Suppress at the outer level of each unit compiled. Note that

2
gcc/ada/osint.adb
View File

@ -1659,7 +1659,7 @@ package body Osint is
-- be reset later (turning some on if -gnato is not specified, and
-- turning all of them on if -gnatp is specified).
Suppress_Options := (others => False);
Suppress_Options := ((others => False), Check_All, Check_All);
-- Reserve the first slot in the search paths table. This is the
-- directory of the main source file or main library file and is filled

64
gcc/ada/sem.adb
View File

@ -722,20 +722,20 @@ package body Sem is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Scope_Suppress := Suppress_All;
Analyze (N);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Scope_Suppress.Suppress (Suppress) := True;
Analyze (N);
Scope_Suppress (Suppress) := Svg;
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Analyze;
@ -761,20 +761,20 @@ package body Sem is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Scope_Suppress := Suppress_All;
Analyze_List (L);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Scope_Suppress.Suppress (Suppress) := True;
Analyze_List (L);
Scope_Suppress (Suppress) := Svg;
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Analyze_List;
@ -1022,20 +1022,20 @@ package body Sem is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Scope_Suppress := Suppress_All;
Insert_After_And_Analyze (N, M);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Scope_Suppress.Suppress (Suppress) := True;
Insert_After_And_Analyze (N, M);
Scope_Suppress (Suppress) := Svg;
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Insert_After_And_Analyze;
@ -1082,20 +1082,20 @@ package body Sem is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Scope_Suppress := Suppress_All;
Insert_Before_And_Analyze (N, M);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Scope_Suppress.Suppress (Suppress) := True;
Insert_Before_And_Analyze (N, M);
Scope_Suppress (Suppress) := Svg;
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Insert_Before_And_Analyze;
@ -1141,20 +1141,20 @@ package body Sem is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Scope_Suppress := Suppress_All;
Insert_List_After_And_Analyze (N, L);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Scope_Suppress.Suppress (Suppress) := True;
Insert_List_After_And_Analyze (N, L);
Scope_Suppress (Suppress) := Svg;
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Insert_List_After_And_Analyze;
@ -1199,20 +1199,20 @@ package body Sem is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Scope_Suppress := Suppress_All;
Insert_List_Before_And_Analyze (N, L);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Scope_Suppress.Suppress (Suppress) := True;
Insert_List_Before_And_Analyze (N, L);
Scope_Suppress (Suppress) := Svg;
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Insert_List_Before_And_Analyze;
@ -1264,9 +1264,9 @@ package body Sem is
-- the All_Checks flag.
if C in Predefined_Check_Id then
return Scope_Suppress (C);
return Scope_Suppress.Suppress (C);
else
return Scope_Suppress (All_Checks);
return Scope_Suppress.Suppress (All_Checks);
end if;
end Is_Check_Suppressed;

6
gcc/ada/sem.ads
View File

@ -310,8 +310,8 @@ package Sem is
-- that are applicable to all entities. A similar search is needed for any
-- non-predefined check even if no specific entity is involved.
Scope_Suppress : Suppress_Array := Suppress_Options;
-- This array contains the current scope based settings of the suppress
Scope_Suppress : Suppress_Record := Suppress_Options;
-- This variable contains the current scope based settings of the suppress
-- switches. It is initialized from the options as shown, and then modified
-- by pragma Suppress. On entry to each scope, the current setting is saved
-- the scope stack, and then restored on exit from the scope. This record
@ -449,7 +449,7 @@ package Sem is
-- Pointer to name of last subprogram body in this scope. Used for
-- testing proper alpha ordering of subprogram bodies in scope.
Save_Scope_Suppress : Suppress_Array;
Save_Scope_Suppress : Suppress_Record;
-- Save contents of Scope_Suppress on entry
Save_Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr;

2
gcc/ada/sem_attr.adb
View File

@ -5880,7 +5880,7 @@ package body Sem_Attr is
begin
if No (E1) then
if C in Predefined_Check_Id then
R := Scope_Suppress (C);
R := Scope_Suppress.Suppress (C);
else
R := Is_Check_Suppressed (Empty, C);
end if;

2
gcc/ada/sem_ch10.adb
View File

@ -1964,7 +1964,7 @@ package body Sem_Ch10 is
Num_Scopes : Int := 0;
Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
Enclosing_Child : Entity_Id := Empty;
Svg : constant Suppress_Array := Scope_Suppress;
Svg : constant Suppress_Record := Scope_Suppress;
Save_Cunit_Restrictions : constant Save_Cunit_Boolean_Restrictions :=
Cunit_Boolean_Restrictions_Save;

32
gcc/ada/sem_prag.adb
View File

@ -5485,9 +5485,9 @@ package body Sem_Prag is
-- affected by this processing).
if R_Id = No_Exceptions and then not Warn then
for J in Scope_Suppress'Range loop
for J in Scope_Suppress.Suppress'Range loop
if J /= Atomic_Synchronization then
Scope_Suppress (J) := True;
Scope_Suppress.Suppress (J) := True;
end if;
end loop;
end if;
@ -5641,9 +5641,7 @@ package body Sem_Prag is
-- user code: we want to generate checks for analysis purposes, as
-- set respectively by -gnatC and -gnatd.F
if (CodePeer_Mode or Alfa_Mode)
and then Comes_From_Source (N)
then
if (CodePeer_Mode or Alfa_Mode) and then Comes_From_Source (N) then
return;
end if;
@ -5666,10 +5664,17 @@ package body Sem_Prag is
("argument of pragma% is not valid check name", Arg1);
end if;
if not Suppress_Case
and then (C = All_Checks or else C = Overflow_Check)
then
Opt.Overflow_Checks_Unsuppressed := True;
-- 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 := Suppress;
Scope_Suppress.Overflow_Checks_Assertions := Suppress;
else
Scope_Suppress.Overflow_Checks_General := Check_All;
Scope_Suppress.Overflow_Checks_Assertions := Check_All;
Opt.Overflow_Checks_Unsuppressed := True;
end if;
end if;
if Arg_Count = 1 then
@ -5687,11 +5692,12 @@ package body Sem_Prag is
-- Atomic_Synchronization is also not affected, since this is
-- not a real check.
for J in Scope_Suppress'Range loop
for J in Scope_Suppress.Suppress'Range loop
if J /= Elaboration_Check
and then J /= Atomic_Synchronization
and then
J /= Atomic_Synchronization
then
Scope_Suppress (J) := Suppress_Case;
Scope_Suppress.Suppress (J) := Suppress_Case;
end if;
end loop;
@ -5704,7 +5710,7 @@ package body Sem_Prag is
and then (not Comes_From_Source (N)
or else C /= Atomic_Synchronization)
then
Scope_Suppress (C) := Suppress_Case;
Scope_Suppress.Suppress (C) := Suppress_Case;
end if;
-- Also make an entry in the Local_Entity_Suppress table

36
gcc/ada/sem_res.adb
View File

@ -334,21 +334,20 @@ package body Sem_Res is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Scope_Suppress := Suppress_All;
Analyze_And_Resolve (N, Typ);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Scope_Suppress.Suppress (Suppress) := True;
Analyze_And_Resolve (N, Typ);
Scope_Suppress (Suppress) := Svg;
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
@ -375,27 +374,24 @@ package body Sem_Res is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Scope_Suppress := Suppress_All;
Analyze_And_Resolve (N);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Scope_Suppress.Suppress (Suppress) := True;
Analyze_And_Resolve (N);
Scope_Suppress (Suppress) := Svg;
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
if Current_Scope /= Scop
and then Scope_Is_Transient
then
if Current_Scope /= Scop and then Scope_Is_Transient then
Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
Scope_Suppress;
end if;
@ -2904,20 +2900,20 @@ package body Sem_Res is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Scope_Suppress := Suppress_All;
Resolve (N, Typ);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Scope_Suppress.Suppress (Suppress) := True;
Resolve (N, Typ);
Scope_Suppress (Suppress) := Svg;
Scope_Suppress.Suppress (Suppress) := Svg;
end;
end if;
end Resolve;

17
gcc/ada/switch-c.adb
View File

@ -443,7 +443,8 @@ package body Switch.C is
-- -gnated switch (disable atomic synchronization)
when 'd' =>
Suppress_Options (Atomic_Synchronization) := True;
Suppress_Options.Suppress (Atomic_Synchronization) :=
True;
-- -gnateD switch (preprocessing symbol definition)
@ -754,7 +755,9 @@ package body Switch.C is
when 'o' =>
Ptr := Ptr + 1;
Suppress_Options (Overflow_Check) := False;
Suppress_Options.Suppress (Overflow_Check) := False;
Suppress_Options.Overflow_Checks_General := Check_All;
Suppress_Options.Overflow_Checks_Assertions := Check_All;
Opt.Enable_Overflow_Checks := True;
-- Processing for O switch
@ -782,12 +785,16 @@ package body Switch.C is
-- exclude Atomic_Synchronization, since this is not a real
-- check.
for J in Suppress_Options'Range loop
for J in Suppress_Options.Suppress'Range loop
if J /= Elaboration_Check
and then J /= Atomic_Synchronization
and then
J /= Atomic_Synchronization
then
Suppress_Options (J) := True;
Suppress_Options.Suppress (J) := True;
end if;
Suppress_Options.Overflow_Checks_General := Suppress;
Suppress_Options.Overflow_Checks_Assertions := Suppress;
end loop;
Validity_Checks_On := False;

56
gcc/ada/types.ads
View File

@ -646,9 +646,9 @@ package Types is
TS : out Time_Stamp_Type);
-- Given the components of a time stamp, initialize the value
-----------------------------------------------
-- Types used for Pragma Suppress Management --
-----------------------------------------------
-------------------------------------
-- Types used for Check Management --
-------------------------------------
type Check_Id is new Nat;
-- Type used to represent a check id
@ -703,6 +703,56 @@ package Types is
-- 4. Add a new Do_xxx_Check flag to Sinfo (if required)
-- 5. Add appropriate checks for the new test
-- The following provides precise details on the mode used to check
-- intermediate overflows in expressions for signed integer arithmetic.
type Overflow_Check_Type is
(Suppress,
-- Intermediate overflow suppressed. If an arithmetic operation creates
-- an overflow, no exception is raised, and the program is erroneous.
Check_All,
-- 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.
Minimize,
-- Where appropriate, arithmetic operations are performed with an
-- extended range, using Long_Long_Integer if necessary. As long as
-- the result fits in this extended range, then no exception is raised
-- and computation continues with the extended result. The final value
-- of an 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.
Eliminate);
-- In this mode arbitrary precision arithmetic is used as needed to
-- ensure that it is impossible for intermediate arithmetic to cause
-- an overflow. Again the final value of an expression must fit in
-- the base type of the whole expression.
-- The following structure captures the state of check suppression or
-- activation at a particular point in the program execution.
type Suppress_Record is record
Suppress : Suppress_Array;
-- Indicates suppression status of each possible check
Overflow_Checks_General : Overflow_Check_Type;
-- This field is relevant only if Suppress (Overflow_Check) is False.
-- It indicates the mode of overflow checking to be applied to general
-- expressions outside assertions.
Overflow_Checks_Assertions : Overflow_Check_Type;
-- This field is relevant only if Suppress (Overflow_Check) is False.
-- It indicates the mode of overflow checking to be applied to any
-- expressions occuring inside assertions.
end record;
Suppress_All : constant Suppress_Record :=
((others => True), Suppress, Suppress);
-- Constant used to initialize Suppress_Record value to all suppressed.
-----------------------------------
-- Global Exception Declarations --
-----------------------------------