diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 19 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 35 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/gnat1drv.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/inline.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/makeutl.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/osint.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem.adb | 64 | ||||
| -rw-r--r-- | gcc/ada/sem.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/switch-c.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/types.ads | 56 |
19 files changed, 218 insertions, 127 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0610114c401..abd977a7afa 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 58cddfb67cd..b086c754807 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 9ac910cede0..9cc8865b64d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 869278181fa..930f82befc0 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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, diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 122065df803..7e28bb4c139 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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 diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index a732da215c4..f7b9d450128 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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 diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 4cc6a4937b2..b2f371f3973 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -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; diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index 63c043def68..f3750a83aa2 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -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 diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 198e61aaab5..1b899c1bb45 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -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. diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 97e7ba7897a..a6c0cf3dff2 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -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 diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index d42a48e9ac0..3e452b5d6de 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -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 diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 352665af23f..46fd546fa76 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -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; diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 7f20eafebc9..00bce6969b6 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -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; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index b2af6ae85b8..737ede23845 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 6ed11b87766..31e8e5564e5 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -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; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 8a67b471d8d..4d377585e5f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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 diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 257e4d5566b..21d3e145d33 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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; diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 51cec6e02c4..4815c097302 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -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; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 011afda0868..03370cff666 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -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 -- ----------------------------------- |