diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 47 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 27 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/gnat1drv.adb | 51 | ||||
| -rw-r--r-- | gcc/ada/gnatcmd.adb | 39 | ||||
| -rw-r--r-- | gcc/ada/make.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/opt.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/osint.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/par-prag.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/prj-part.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sem.ads | 22 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 86 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 9 | ||||
| -rw-r--r-- | gcc/ada/switch-c.adb | 89 | ||||
| -rw-r--r-- | gcc/ada/types.ads | 59 |
19 files changed, 372 insertions, 136 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c1b2ba3e5fd..4a7e8b99d09 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2012-10-01 Vincent Celier <celier@adacore.com> + + * make.adb (Scan_Make_Arg): Only test for "vP" of the option + includes at least 3 characters. + * gnatcmd.adb (GNATCmd): Ditto. + +2012-10-01 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch7.adb, sinfo.ads: Add comments. + +2012-10-01 Robert Dewar <dewar@adacore.com> + + * checks.adb: Remove reference to Enable_Overflow_Checks Use + Suppress_Options rather than Scope_Suppress. + * gnat1drv.adb (Adjust_Global_Switches): Handle new overflow + settings (Adjust_Global_Switches): Initialize Scope_Suppress + from Suppress_Options. + * opt.adb: Remove Enable_Overflow_Checks (use Suppress_Options + instead). + * opt.ads: Remove Overflow_Checks_Unsuppressed (not used) + Remove Enable_Overflow_Checks (use Suppress_Options instead) + Suppress_Options is now current setting (replaces Scope_Suppress). + * osint.adb (Initialize): Deal with initializing overflow + checking. + * par-prag.adb: Add dummy entry for pragma Overflow_Checks. + * sem.adb (Semantics): Save and restore In_Assertion_Expr Use + Suppress_Options instead of Scope_Suppress. + * sem.ads (In_Assertion_Expr): New flag (Scope_Suppress): + Removed, use Suppress_Options instead. + * sem_eval.adb (Compile_Time_Compare): Return Unknown in + preanalysis mode. + * sem_prag.adb (Process_Suppress_Unsuppress): Setting of + Overflow_Checks_Unsuppressed removed (not used anywhere!) + (Analyze_Pragma, case Check): Set In_Assertion_Expression + (Analyze_Pragma, case Overflow_Checks): Implement new pragma + * snames.ads-tmpl: Add names needed for handling pragma + Overflow_Checks + * switch-c.adb (Scan_Front_End_Switches) Handle -gnato? and + -gnato?? where ? is 0-3 + * types.ads: Updates and fixes to comment on Suppress_Record. + +2012-10-01 Vincent Celier <celier@adacore.com> + + * prj-part.adb (Parse): Remove incorrect comment about checking + imported non extending projects from and "extending all" + one. Minor correction. + 2012-10-01 Robert Dewar <dewar@adacore.com> * make.adb, exp_ch3.adb: Minor reformatting. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 2861d7c2cde..46cf71ce7c5 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -3912,19 +3912,6 @@ package body Checks is -- the computed expression is in the range Lor .. Hir. We can use this -- to restrict the possible range of results. - -- If one of the computed bounds is outside the range of the base type, - -- the expression may raise an exception and we had better indicate that - -- the evaluation has failed, at least if checks are enabled. - - if OK1 - and then Enable_Overflow_Checks - and then not Is_Entity_Name (N) - and then (Lor < Lo or else Hir > Hi) - then - OK := False; - return; - end if; - if OK1 then -- If the refined value of the low bound is greater than the type @@ -6184,10 +6171,20 @@ package body Checks is function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is begin + -- Check overflow suppressed on entity + if Present (E) and then Checks_May_Be_Suppressed (E) then - return Is_Check_Suppressed (E, Overflow_Check); + if Is_Check_Suppressed (E, Overflow_Check) then + return True; + end if; + end if; + + -- Else return appropriate scope setting + + if In_Assertion_Expr = 0 then + return Scope_Suppress.Overflow_Checks_General = Suppressed; else - return Scope_Suppress.Suppress (Overflow_Check); + return Scope_Suppress.Overflow_Checks_Assertions = Suppressed; end if; end Overflow_Checks_Suppressed; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 725cd2ac4b6..9c6955a7b9e 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4585,9 +4585,6 @@ package body Exp_Ch7 is -- finalization blocks, and we put everything into a wrapper -- block to clearly expose the construct to the back-end. - -- This requirement for "clearly expose" must be properly - -- documented in sinfo/einfo ??? - if Present (Prev_Fin) then Insert_Before_And_Analyze (Prev_Fin, Fin_Block); else diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index b2f371f3973..3d998840aa4 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -197,12 +197,10 @@ procedure Gnat1drv is Alignment_Check => True, Division_Check => True, Elaboration_Check => True, - Overflow_Check => True, others => False), - Overflow_Checks_General => Suppress, - Overflow_Checks_Assertions => Suppress); + Overflow_Checks_General => Suppressed, + Overflow_Checks_Assertions => Suppressed); - Enable_Overflow_Checks := False; Dynamic_Elaboration_Checks := False; -- Kill debug of generated code, since it messes up sloc values @@ -330,23 +328,29 @@ procedure Gnat1drv is Exception_Mechanism := Back_End_Exceptions; end if; - -- Set proper status for overflow checks. We turn on overflow checks if - -- -gnatp was not specified, and either -gnato is set or the back-end - -- takes care of overflow checks. Otherwise we suppress overflow checks - -- by default (since front end checks are expensive). - - if not Opt.Suppress_Checks - and then (Opt.Enable_Overflow_Checks - or else - (Targparm.Backend_Divide_Checks_On_Target - and - Targparm.Backend_Overflow_Checks_On_Target)) + -- Set proper status for overflow checks. If already set (by -gnato or + -- -gnatp) then we have nothing to do. + + if Opt.Suppress_Options.Overflow_Checks_General /= Not_Set then + null; + + -- If we have backend divide and overflow checks, then by default + -- overflow checks are minimized, which is a reasonable setting. + + elsif Targparm.Backend_Divide_Checks_On_Target + and + Targparm.Backend_Overflow_Checks_On_Target then - Suppress_Options.Suppress (Overflow_Check) := False; + Suppress_Options.Overflow_Checks_General := Minimized; + Suppress_Options.Overflow_Checks_Assertions := Minimized; + + -- Otherwise for now, default is checks are suppressed. This is likely + -- to change in the future, but for now this is the compatible behavior + -- with previous versions of GNAT. + else - Suppress_Options.Suppress (Overflow_Check) := True; - Suppress_Options.Overflow_Checks_General := Check_All; - Suppress_Options.Overflow_Checks_Assertions := Check_All; + Suppress_Options.Overflow_Checks_General := Suppressed; + Suppress_Options.Overflow_Checks_Assertions := Suppressed; end if; -- Set default for atomic synchronization. As this synchronization @@ -437,8 +441,7 @@ procedure Gnat1drv is -- Turn off alignment checks. -- Turn off validity checking. - Suppress_Options := Suppress_All; - Enable_Overflow_Checks := False; + Suppress_Options := Suppress_All; Dynamic_Elaboration_Checks := False; Reset_Validity_Check_Options; @@ -517,6 +520,12 @@ procedure Gnat1drv is Inline_Level := 2; end if; end if; + + -- Finally capture adjusted value of Suppress_Options as the initial + -- value for Scope_Suppress, which will be modified as we move from + -- scope to scope (by Suppress/Unsuppress/Overflow_Checks pragmas). + + Sem.Scope_Suppress := Opt.Suppress_Options; end Adjust_Global_Switches; -------------------- diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index ef93f2fab1c..ab4ddcc7d29 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -848,6 +848,9 @@ procedure GNATCmd is Unit : Unit_Index; Path : Path_Name_Type; + Files_File : Ada.Text_IO.File_Type; + Temp_File_Name : Path_Name_Type; + begin if GN_Path = null then Put_Line (Standard_Error, "could not locate " & GN_Name); @@ -856,7 +859,7 @@ procedure GNATCmd is -- Create the temp file - Tempdir.Create_Temp_File (FD, Name); + Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files"); -- And close it, because on VMS Spawn with a file descriptor created -- with Create_Temp_File does not redirect output. @@ -904,8 +907,19 @@ procedure GNATCmd is raise Error_Exit; else - -- Get each file name in the file, find its path and add it the - -- list of arguments. + -- Create a temporary file to put the list of files in the closure + + Tempdir.Create_Temp_File (FD, Temp_File_Name); + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'("-files=" & Get_Name_String (Temp_File_Name)); + + Close (FD); + + Open (Files_File, Out_File, Get_Name_String (Temp_File_Name)); + + -- Get each file name in the file, find its path and add it the list + -- of arguments. while not End_Of_File (File) loop Get_Line (File, Line, Last); @@ -933,18 +947,16 @@ procedure GNATCmd is Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); end loop; - Last_Switches.Increment_Last; - if Path /= No_Path then - Last_Switches.Table (Last_Switches.Last) := - new String'(Get_Name_String (Path)); + Put_Line (Files_File, Get_Name_String (Path)); else - Last_Switches.Table (Last_Switches.Last) := - new String'(Line (1 .. Last)); + Put_Line (Files_File, Line (1 .. Last)); end if; end loop; + Close (Files_File); + begin if not Keep_Temporary_Files then Delete (File); @@ -1769,7 +1781,9 @@ begin -- -vPx Specify verbosity while parsing project files - elsif Argv (Argv'First + 1 .. Argv'First + 2) = "vP" then + elsif Argv'Length >= 3 + and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" + then if Argv'Length = 4 and then Argv (Argv'Last) in '0' .. '2' then @@ -2055,6 +2069,11 @@ begin or else The_Command = Link or else The_Command = Elim then + if Project.Object_Directory.Name = No_Path then + Fail ("project " & Get_Name_String (Project.Display_Name) & + " has no object directory"); + end if; + Change_Dir (Get_Name_String (Project.Object_Directory.Name)); end if; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 33611d3a744..69a996d8a14 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -7825,7 +7825,7 @@ package body Make is -- -vPx (verbosity of the parsing of the project files) - elsif Argv (2 .. 3) = "vP" then + elsif Argv'Length >= 3 and then Argv (2 .. 3) = "vP" then if Argv'Last /= 4 or else Argv (4) not in '0' .. '2' then Make_Failed ("invalid verbosity level " & Argv (4 .. Argv'Last)); diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index 809816d244c..a6c15538c28 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -259,7 +259,6 @@ package body Opt is Tree_Read_Bool (Debug_Pragmas_Disabled); Tree_Read_Bool (Debug_Pragmas_Enabled); Tree_Read_Int (Int (Default_Pool)); - Tree_Read_Bool (Enable_Overflow_Checks); Tree_Read_Bool (Full_List); Ada_Version_Config := @@ -326,7 +325,6 @@ package body Opt is Tree_Write_Bool (Debug_Pragmas_Disabled); Tree_Write_Bool (Debug_Pragmas_Enabled); Tree_Write_Int (Int (Default_Pool)); - Tree_Write_Bool (Enable_Overflow_Checks); Tree_Write_Bool (Full_List); Tree_Write_Int (Int (Version_String'Length)); Tree_Write_Data (Version_String'Address, Version_String'Length); diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index a6c0cf3dff2..5eac7ed8726 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -486,11 +486,6 @@ package Opt is -- GNAT -- Set to True to generate full elaboration warnings (-gnatwl) - Enable_Overflow_Checks : Boolean := False; - -- GNAT - -- Set to True if -gnato (enable overflow checks) switch is set, - -- but not -gnatp. - Error_Msg_Line_Length : Nat := 0; -- GNAT -- Records the error message line length limit. If this is set to zero, @@ -1068,12 +1063,6 @@ package Opt is -- True if output of list of objects is requested (-O switch set). List is -- output under the given filename, or standard output if not specified. - Overflow_Checks_Unsuppressed : Boolean := False; - -- GNAT - -- 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 -- True if a Persistent_BSS configuration pragma is in effect, causing @@ -1252,10 +1241,10 @@ package Opt is 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 - -- these suppress actions can be overridden by the use of the Unsuppress - -- pragma. This variable is initialized by Osint.Initialize. + -- Indicates outer level setting of check suppression. This initializes + -- the settings of the outer scope level in any unit compiled. This is + -- initialized by Osint.Initialize, and further initialized by the + -- Adjust_Global_Switches flag in Gnat1drv. Suppress_Back_Annotation : Boolean := False; -- GNAT diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 3e452b5d6de..af355a16a26 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -1655,11 +1655,12 @@ package body Osint is Src_Search_Directories.Init; Lib_Search_Directories.Init; - -- Start off by setting all suppress options to False, these will - -- be reset later (turning some on if -gnato is not specified, and - -- turning all of them on if -gnatp is specified). + -- Start off by setting all suppress options, to False. The special + -- overflow fields are set to Not_Set (they will be set by -gnatp, or + -- by -gnato, or, if neither of these appear, in Adjust_Global_Switches + -- in Gnat1drv. - Suppress_Options := ((others => False), Check_All, Check_All); + Suppress_Options := ((others => False), Not_Set, Not_Set); -- 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/par-prag.adb b/gcc/ada/par-prag.adb index e0834764865..8b071424567 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1199,6 +1199,7 @@ begin Pragma_Ordered | Pragma_Optimize | Pragma_Optimize_Alignment | + Pragma_Overflow_Checks | Pragma_Pack | Pragma_Passive | Pragma_Preelaborable_Initialization | diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 17b72ea29aa..d70480e152b 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -638,11 +638,6 @@ package body Prj.Part is -- Remove from the potentially virtual any project extended by one -- of these imported projects. - -- For non extending imported projects, check that they do not belong - -- to the project tree of the project being "extended-all" by the - -- main project. - -- Where is this check performed??? - declare With_Clause : Project_Node_Id; Imported : Project_Node_Id := Empty_Node; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 46fd546fa76..f4beaa63b99 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -33,6 +33,7 @@ with Fname; use Fname; with Lib; use Lib; with Lib.Load; use Lib.Load; with Nlists; use Nlists; +with Opt; use Opt; with Output; use Output; with Restrict; use Restrict; with Sem_Attr; use Sem_Attr; @@ -1353,13 +1354,14 @@ package body Sem is -- these variables, and also that such calls do not disturb the settings -- for units being analyzed at a higher level. - S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; - S_Full_Analysis : constant Boolean := Full_Analysis; - S_GNAT_Mode : constant Boolean := GNAT_Mode; - S_Global_Dis_Names : constant Boolean := Global_Discard_Names; - S_In_Spec_Expr : constant Boolean := In_Spec_Expression; - S_Inside_A_Generic : constant Boolean := Inside_A_Generic; - S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope; + S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; + S_Full_Analysis : constant Boolean := Full_Analysis; + S_GNAT_Mode : constant Boolean := GNAT_Mode; + S_Global_Dis_Names : constant Boolean := Global_Discard_Names; + S_In_Assertion_Expr : constant Nat := In_Assertion_Expr; + S_In_Spec_Expr : constant Boolean := In_Spec_Expression; + S_Inside_A_Generic : constant Boolean := Inside_A_Generic; + S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope; Generic_Main : constant Boolean := Nkind (Unit (Cunit (Main_Unit))) @@ -1453,6 +1455,7 @@ package body Sem is Full_Analysis := True; Inside_A_Generic := False; + In_Assertion_Expr := 0; In_Spec_Expression := False; Set_Comes_From_Source_Default (False); @@ -1526,6 +1529,7 @@ package body Sem is Full_Analysis := S_Full_Analysis; Global_Discard_Names := S_Global_Dis_Names; GNAT_Mode := S_GNAT_Mode; + In_Assertion_Expr := S_In_Assertion_Expr; In_Spec_Expression := S_In_Spec_Expr; Inside_A_Generic := S_Inside_A_Generic; Outer_Generic_Scope := S_Outer_Gen_Scope; diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 00bce6969b6..f219b923668 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -203,7 +203,6 @@ with Alloc; with Einfo; use Einfo; -with Opt; use Opt; with Table; with Types; use Types; @@ -243,6 +242,15 @@ package Sem is -- frozen from start, because the tree on which they depend will not -- be available at the freeze point. + In_Assertion_Expr : Nat := 0; + -- This is set non-zero if we are within the expression of an assertion + -- pragma or aspect. It is a counter which is incremented at the start + -- of expanding such an expression, and decremented on completion of + -- expanding that expression. Probably a boolean would be good enough, + -- since we think that such expressions cannot nest, but that might not + -- be true in the future (e.g. if let expressions are added to Ada) so + -- we prepare for that future possibility by making it a counter. + In_Inlined_Body : Boolean := False; -- Switch to indicate that we are analyzing and resolving an inlined body. -- Type checking is disabled in this context, because types are known to be @@ -310,13 +318,13 @@ 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_Record := Suppress_Options; + Scope_Suppress : Suppress_Record; -- 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 - -- may be rapidly checked to determine the current status of a check if - -- no specific entity is involved or if the specific entity involved is + -- switches. It is initialized from Suppress_Options in Gnat1drv, 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 may be rapidly checked to determine the current status of a check + -- if no specific entity is involved or if the specific entity involved is -- one for which no specific Suppress/Unsuppress pragma has been set (as -- indicated by the Checks_May_Be_Suppressed flag being set). diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 8553ce62875..888f3b25c1a 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -743,6 +743,16 @@ package body Sem_Eval is begin Diff.all := No_Uint; + -- In preanalysis mode, always return Unknown, it is too early to be + -- thinking we know the result of a comparison, save that judgment for + -- the full analysis. This is particularly important in the case of + -- pre and postconditions, which otherwise can be prematurely collapsed + -- into having True or False conditions when this is inappropriate. + + if not Full_Analysis then + return Unknown; + end if; + -- If either operand could raise constraint error, then we cannot -- know the result at compile time (since CE may be raised!) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 55f391fa630..2b3d7b81ad7 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -286,7 +286,9 @@ package body Sem_Prag is -- Preanalyze the boolean expression, we treat this as a spec expression -- (i.e. similar to a default expression). + In_Assertion_Expr := In_Assertion_Expr + 1; Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); + In_Assertion_Expr := In_Assertion_Expr - 1; -- In ASIS mode, for a pragma generated from a source aspect, also -- analyze the original aspect expression. @@ -5672,12 +5674,11 @@ package body Sem_Prag is 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; + Scope_Suppress.Overflow_Checks_General := Suppressed; + Scope_Suppress.Overflow_Checks_Assertions := Suppressed; else - Scope_Suppress.Overflow_Checks_General := Check_All; - Scope_Suppress.Overflow_Checks_Assertions := Check_All; - Opt.Overflow_Checks_Unsuppressed := True; + Scope_Suppress.Overflow_Checks_General := Minimized; + Scope_Suppress.Overflow_Checks_Assertions := Minimized; end if; end if; @@ -6799,7 +6800,7 @@ package body Sem_Prag is -- Assertion_Policy -- ---------------------- - -- pragma Assertion_Policy (Check | Disable |Ignore) + -- pragma Assertion_Policy (Check | Disable | Ignore) when Pragma_Assertion_Policy => Assertion_Policy : declare Policy : Node_Id; @@ -7289,7 +7290,9 @@ package body Sem_Prag is -- Check is active else + In_Assertion_Expr := In_Assertion_Expr + 1; Analyze_And_Resolve (Expr, Any_Boolean); + In_Assertion_Expr := In_Assertion_Expr - 1; end if; end Check; @@ -11753,6 +11756,76 @@ package body Sem_Prag is Optimize_Alignment_Local := True; end Optimize_Alignment; + --------------------- + -- Overflow_Checks -- + --------------------- + + -- pragma Overflow_Checks + -- ([General => ] MODE [, [Assertions => ] MODE); + + -- MODE := SUPPRESSED | CHECKED | MINIMIZED | ELIMINATED + + when Pragma_Overflow_Checks => Overflow_Checks : declare + function Get_Check_Mode + (Name : Name_Id; + Arg : Node_Id) return Overflow_Check_Type; + -- Function to process one pragma argument, Arg. If an identifier + -- is present, it must be Name. Check type is returned if a valid + -- argument exists, otherwise an error is signalled. + + -------------------- + -- Get_Check_Mode -- + -------------------- + + function Get_Check_Mode + (Name : Name_Id; + Arg : Node_Id) return Overflow_Check_Type + is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Check_Optional_Identifier (Arg, Name); + Check_Arg_Is_Identifier (Argx); + + if Chars (Argx) = Name_Suppressed then + return Suppressed; + elsif Chars (Argx) = Name_Checked then + return Checked; + elsif Chars (Argx) = Name_Minimized then + return Minimized; + elsif Chars (Argx) = Name_Eliminated then + return Eliminated; + else + Error_Pragma_Arg ("invalid argument for pragma%", Argx); + end if; + end Get_Check_Mode; + + -- Start of processing for Overflow_Checks + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + + -- Process first argument + + Suppress_Options.Overflow_Checks_General := + Get_Check_Mode (Name_General, Arg1); + + -- Case of only one argument + + if Arg_Count = 1 then + Scope_Suppress.Overflow_Checks_Assertions := + Scope_Suppress.Overflow_Checks_General; + + -- Case of two arguments present + + else + Scope_Suppress.Overflow_Checks_Assertions := + Get_Check_Mode (Name_Assertions, Arg2); + end if; + end Overflow_Checks; + ------------- -- Ordered -- ------------- @@ -15173,6 +15246,7 @@ package body Sem_Prag is Pragma_Obsolescent => 0, Pragma_Optimize => -1, Pragma_Optimize_Alignment => -1, + Pragma_Overflow_Checks => 0, Pragma_Ordered => 0, Pragma_Pack => 0, Pragma_Page => -1, diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 16e92cd60e9..3eab5982cfc 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -4289,6 +4289,14 @@ package Sinfo is -- Note: Exception_Junk is set for the wrapping blocks created during -- local raise optimization (Exp_Ch11.Expand_Local_Exception_Handlers). + -- Note: from a control flow viewpoint, a block statement defines an + -- extended basic block, i.e. the entry of the block dominates every + -- statement in the sequence. When generating new statements with + -- exception handlers in the expander at the end of a sequence that + -- comes from source code, it can be necessary to wrap them all in a + -- block statement in order to expose the implicit control flow to + -- gigi and thus prevent it from issuing bogus control flow warnings. + -- N_Block_Statement -- Sloc points to DECLARE or BEGIN -- Identifier (Node1) block direct name (set to Empty if not present) diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index f4b31aa7996..167d110749a 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -408,6 +408,7 @@ package Snames is Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT Name_Normalize_Scalars : constant Name_Id := N + $; Name_Optimize_Alignment : constant Name_Id := N + $; -- GNAT + Name_Overflow_Checks : constant Name_Id := N + $; -- GNAT Name_Persistent_BSS : constant Name_Id := N + $; -- GNAT Name_Polling : constant Name_Id := N + $; -- GNAT Name_Priority_Specific_Dispatching : constant Name_Id := N + $; -- Ada 05 @@ -651,6 +652,7 @@ package Snames is Name_As_Is : constant Name_Id := N + $; Name_Assertion : constant Name_Id := N + $; + Name_Assertions : constant Name_Id := N + $; Name_Attribute_Name : constant Name_Id := N + $; Name_Body_File_Name : constant Name_Id := N + $; Name_Boolean_Entry_Barriers : constant Name_Id := N + $; @@ -658,6 +660,8 @@ package Snames is Name_By_Entry : constant Name_Id := N + $; Name_By_Protected_Procedure : constant Name_Id := N + $; Name_Casing : constant Name_Id := N + $; + Name_Check_All : constant Name_Id := N + $; + Name_Checked : constant Name_Id := N + $; Name_Code : constant Name_Id := N + $; Name_Component : constant Name_Id := N + $; Name_Component_Size_4 : constant Name_Id := N + $; @@ -667,6 +671,7 @@ package Snames is Name_Disable : constant Name_Id := N + $; Name_Dot_Replacement : constant Name_Id := N + $; Name_Dynamic : constant Name_Id := N + $; + Name_Eliminated : constant Name_Id := N + $; Name_Ensures : constant Name_Id := N + $; Name_Entity : constant Name_Id := N + $; Name_Entry_Count : constant Name_Id := N + $; @@ -676,6 +681,7 @@ package Snames is Name_Form : constant Name_Id := N + $; Name_G_Float : constant Name_Id := N + $; Name_Gcc : constant Name_Id := N + $; + Name_General : constant Name_Id := N + $; Name_Gnat : constant Name_Id := N + $; Name_GPL : constant Name_Id := N + $; Name_IEEE_Float : constant Name_Id := N + $; @@ -689,6 +695,7 @@ package Snames is Name_Max_Size : constant Name_Id := N + $; Name_Mechanism : constant Name_Id := N + $; Name_Message : constant Name_Id := N + $; + Name_Minimized : constant Name_Id := N + $; Name_Mixedcase : constant Name_Id := N + $; Name_Mode : constant Name_Id := N + $; Name_Modified_GPL : constant Name_Id := N + $; @@ -727,6 +734,7 @@ package Snames is Name_Static : constant Name_Id := N + $; Name_Stack_Size : constant Name_Id := N + $; Name_Subunit_File_Name : constant Name_Id := N + $; + Name_Suppressed : constant Name_Id := N + $; Name_Task_Stack_Size_Default : constant Name_Id := N + $; Name_Task_Type : constant Name_Id := N + $; Name_Time_Slicing_Enabled : constant Name_Id := N + $; @@ -1656,6 +1664,7 @@ package Snames is Pragma_No_Strict_Aliasing, Pragma_Normalize_Scalars, Pragma_Optimize_Alignment, + Pragma_Overflow_Checks, Pragma_Persistent_BSS, Pragma_Polling, Pragma_Priority_Specific_Dispatching, diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 4815c097302..04de8900ca4 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -128,9 +128,8 @@ package body Switch.C is -- Handle switches that do not start with -gnat - if Ptr + 3 > Max - or else Switch_Chars (Ptr .. Ptr + 3) /= "gnat" - then + if Ptr + 3 > Max or else Switch_Chars (Ptr .. Ptr + 3) /= "gnat" then + -- There are two front-end switches that do not start with -gnat: -- -I, --RTS @@ -755,10 +754,77 @@ package body Switch.C is when 'o' => Ptr := Ptr + 1; - 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; + + -- Case of no digits after the -gnato + + if Ptr > Max or else Switch_Chars (Ptr) not in '0' .. '3' then + Suppress_Options.Overflow_Checks_General := Checked; + Suppress_Options.Overflow_Checks_Assertions := Checked; + + -- At least one digit after the -gnato + + else + -- Handle first digit after -gnato + + case Switch_Chars (Ptr) is + when '0' => + Suppress_Options.Overflow_Checks_General := + Suppressed; + + when '1' => + Suppress_Options.Overflow_Checks_General := + Checked; + + when '2' => + Suppress_Options.Overflow_Checks_General := + Minimized; + + when '3' => + Suppress_Options.Overflow_Checks_General := + Eliminated; + + when others => + raise Program_Error; + end case; + + Ptr := Ptr + 1; + + -- Only one digit after -gnato, set assertions mode to + -- be the same as general mode. + + if Ptr > Max + or else Switch_Chars (Ptr) not in '0' .. '3' + then + Suppress_Options.Overflow_Checks_Assertions := + Suppress_Options.Overflow_Checks_General; + + -- Process second digit after -gnato + + else + case Switch_Chars (Ptr) is + when '0' => + Suppress_Options.Overflow_Checks_Assertions := + Suppressed; + + when '1' => + Suppress_Options.Overflow_Checks_Assertions := + Checked; + + when '2' => + Suppress_Options.Overflow_Checks_Assertions := + Minimized; + + when '3' => + Suppress_Options.Overflow_Checks_Assertions := + Eliminated; + + when others => + raise Program_Error; + end case; + + Ptr := Ptr + 1; + end if; + end if; -- Processing for O switch @@ -793,13 +859,12 @@ package body Switch.C is Suppress_Options.Suppress (J) := True; end if; - Suppress_Options.Overflow_Checks_General := Suppress; - Suppress_Options.Overflow_Checks_Assertions := Suppress; + Suppress_Options.Overflow_Checks_General := Suppressed; + Suppress_Options.Overflow_Checks_Assertions := Suppressed; end loop; - Validity_Checks_On := False; - Opt.Suppress_Checks := True; - Opt.Enable_Overflow_Checks := False; + Validity_Checks_On := False; + Opt.Suppress_Checks := True; end if; -- Processing for P switch diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 03370cff666..0f9cea25eb3 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -706,51 +706,56 @@ package Types is -- 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 + type Overflow_Check_Type is ( + Not_Set, + -- Dummy value used during initialization process to show that the + -- corresponding value has not yet been initialized. + + Suppressed, + -- Overflow checking is 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. + 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. - Minimize, + Minimized, -- 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); + -- 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. + + Eliminated); -- 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. + -- 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 + -- Indicates suppression status of each possible check. Note: there + -- is an entry for Overflow_Checks 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; - -- 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. + -- This field 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. + -- This field 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); + ((others => True), Suppressed, Suppressed); -- Constant used to initialize Suppress_Record value to all suppressed. ----------------------------------- |