diff options
Diffstat (limited to 'gcc/ada/libgnat')
123 files changed, 956 insertions, 11120 deletions
diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb index c776623..d0a1d7f 100644 --- a/gcc/ada/libgnat/a-except.adb +++ b/gcc/ada/libgnat/a-except.adb @@ -450,6 +450,8 @@ package body Ada.Exceptions is (File : System.Address; Line : Integer); procedure Rcheck_CE_Tag_Check (File : System.Address; Line : Integer); + procedure Rcheck_PE_Abstract_Type_Component + (File : System.Address; Line : Integer); procedure Rcheck_PE_Access_Before_Elaboration (File : System.Address; Line : Integer); procedure Rcheck_PE_Accessibility_Check @@ -542,6 +544,8 @@ package body Ada.Exceptions is "__gnat_rcheck_CE_Range_Check"); pragma Export (C, Rcheck_CE_Tag_Check, "__gnat_rcheck_CE_Tag_Check"); + pragma Export (C, Rcheck_PE_Abstract_Type_Component, + "__gnat_rcheck_PE_Abstract_Type_Component"); pragma Export (C, Rcheck_PE_Access_Before_Elaboration, "__gnat_rcheck_PE_Access_Before_Elaboration"); pragma Export (C, Rcheck_PE_Accessibility_Check, @@ -620,6 +624,7 @@ package body Ada.Exceptions is pragma No_Return (Rcheck_CE_Partition_Check); pragma No_Return (Rcheck_CE_Range_Check); pragma No_Return (Rcheck_CE_Tag_Check); + pragma No_Return (Rcheck_PE_Abstract_Type_Component); pragma No_Return (Rcheck_PE_Access_Before_Elaboration); pragma No_Return (Rcheck_PE_Accessibility_Check); pragma No_Return (Rcheck_PE_Address_Of_Intrinsic); @@ -683,6 +688,8 @@ package body Ada.Exceptions is "expected_throw"); pragma Machine_Attribute (Rcheck_CE_Tag_Check, "expected_throw"); + pragma Machine_Attribute (Rcheck_PE_Abstract_Type_Component, + "expected_throw"); pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration, "expected_throw"); pragma Machine_Attribute (Rcheck_PE_Accessibility_Check, @@ -775,6 +782,8 @@ package body Ada.Exceptions is "strub", "callable"); pragma Machine_Attribute (Rcheck_CE_Tag_Check, "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Abstract_Type_Component, + "strub", "callable"); pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration, "strub", "callable"); pragma Machine_Attribute (Rcheck_PE_Accessibility_Check, @@ -885,6 +894,8 @@ package body Ada.Exceptions is Rmsg_36 : constant String := "stream operation not allowed" & NUL; Rmsg_37 : constant String := "build-in-place mismatch" & NUL; Rmsg_38 : constant String := "raise check failed" & NUL; + Rmsg_39 : constant String := "initialization of abstract type" & + " component not allowed" & NUL; --------- -- AAA -- @@ -1471,6 +1482,13 @@ package body Ada.Exceptions is Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address); end Rcheck_CE_Tag_Check; + procedure Rcheck_PE_Abstract_Type_Component + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_39'Address); + end Rcheck_PE_Abstract_Type_Component; + procedure Rcheck_PE_Access_Before_Elaboration (File : System.Address; Line : Integer) is diff --git a/gcc/ada/libgnat/a-nbnbig.adb b/gcc/ada/libgnat/a-nbnbig.adb deleted file mode 100644 index e487a05..0000000 --- a/gcc/ada/libgnat/a-nbnbig.adb +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS_GHOST -- --- -- --- B o d y -- --- -- --- Copyright (C) 2021-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This body is provided as a work-around for a GNAT compiler bug, as GNAT --- currently does not compile instantiations of the spec with imported ghost --- generics for packages Signed_Conversions and Unsigned_Conversions. - --- Ghost code in this unit is meant for analysis only, not for run-time --- checking. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore); - -package body Ada.Numerics.Big_Numbers.Big_Integers_Ghost with - SPARK_Mode => Off -is - - package body Signed_Conversions with - SPARK_Mode => Off - is - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer is - begin - raise Program_Error; - return (null record); - end To_Big_Integer; - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int is - begin - raise Program_Error; - return 0; - end From_Big_Integer; - - end Signed_Conversions; - - package body Unsigned_Conversions with - SPARK_Mode => Off - is - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer is - begin - raise Program_Error; - return (null record); - end To_Big_Integer; - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int is - begin - raise Program_Error; - return 0; - end From_Big_Integer; - - end Unsigned_Conversions; - -end Ada.Numerics.Big_Numbers.Big_Integers_Ghost; diff --git a/gcc/ada/libgnat/a-nbnbig.ads b/gcc/ada/libgnat/a-nbnbig.ads deleted file mode 100644 index 04aa62a..0000000 --- a/gcc/ada/libgnat/a-nbnbig.ads +++ /dev/null @@ -1,241 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.BIG_NUMBERS.BIG_INTEGERS_GHOST -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a reduced and non-executable implementation of the --- ARM A.5.6 defined ``Ada.Numerics.Big_Numbers.Big_Integers`` for use in --- SPARK proofs in the runtime. As it is only intended for SPARK proofs, this --- package is marked as a Ghost package and consequently does not have a --- runtime footprint. - --- Contrary to Ada.Numerics.Big_Numbers.Big_Integers, this unit does not --- depend on System or Ada.Finalization, which makes it more convenient for --- use in run-time units. Note, since it is a ghost unit, all subprograms are --- marked as imported. - --- Ghost code in this unit is meant for analysis only, not for run-time --- checking. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore); - -package Ada.Numerics.Big_Numbers.Big_Integers_Ghost with - SPARK_Mode, - Ghost, - Pure, - Always_Terminates -is - - type Big_Integer is private - with Integer_Literal => From_Universal_Image; - -- Private type that holds the integer value - - function Is_Valid (Arg : Big_Integer) return Boolean - with - Import, - Global => null; - -- Return whether a passed big integer is valid - - subtype Valid_Big_Integer is Big_Integer - with Dynamic_Predicate => Is_Valid (Valid_Big_Integer), - Predicate_Failure => raise Program_Error; - -- Holds a valid Big_Integer - - -- Comparison operators defined for valid Big_Integer values - function "=" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function "<" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function "<=" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function ">" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function ">=" (L, R : Valid_Big_Integer) return Boolean with - Import, - Global => null; - - function To_Big_Integer (Arg : Integer) return Valid_Big_Integer - with - Import, - Global => null; - -- Create a Big_Integer from an Integer value - - subtype Big_Positive is Big_Integer - with Dynamic_Predicate => - (if Is_Valid (Big_Positive) - then Big_Positive > To_Big_Integer (0)), - Predicate_Failure => raise Constraint_Error; - -- Positive subtype of Big_Integers, analogous to Positive and Integer - - subtype Big_Natural is Big_Integer - with Dynamic_Predicate => - (if Is_Valid (Big_Natural) - then Big_Natural >= To_Big_Integer (0)), - Predicate_Failure => raise Constraint_Error; - -- Natural subtype of Big_Integers, analogous to Natural and Integer - - function In_Range - (Arg : Valid_Big_Integer; Low, High : Big_Integer) return Boolean - is (Low <= Arg and Arg <= High) - with - Import, - Global => null; - -- Check whether Arg is in the range Low .. High - - function To_Integer (Arg : Valid_Big_Integer) return Integer - with - Import, - Pre => In_Range (Arg, - Low => To_Big_Integer (Integer'First), - High => To_Big_Integer (Integer'Last)) - or else raise Constraint_Error, - Global => null; - -- Convert a valid Big_Integer into an Integer - - generic - type Int is range <>; - package Signed_Conversions is - -- Generic package to implement conversion functions for - -- arbitrary ranged types. - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer - with - Global => null; - -- Convert a ranged type into a valid Big_Integer - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int - with - Pre => In_Range (Arg, - Low => To_Big_Integer (Int'First), - High => To_Big_Integer (Int'Last)) - or else raise Constraint_Error, - Global => null; - -- Convert a valid Big_Integer into a ranged type - end Signed_Conversions; - - generic - type Int is mod <>; - package Unsigned_Conversions is - -- Generic package to implement conversion functions for - -- arbitrary modular types. - - function To_Big_Integer (Arg : Int) return Valid_Big_Integer - with - Global => null; - -- Convert a modular type into a valid Big_Integer - - function From_Big_Integer (Arg : Valid_Big_Integer) return Int - with - Pre => In_Range (Arg, - Low => To_Big_Integer (Int'First), - High => To_Big_Integer (Int'Last)) - or else raise Constraint_Error, - Global => null; - -- Convert a valid Big_Integer into a modular type - - end Unsigned_Conversions; - - function From_String (Arg : String) return Valid_Big_Integer - with - Import, - Global => null; - -- Create a valid Big_Integer from a String - - function From_Universal_Image (Arg : String) return Valid_Big_Integer - renames From_String; - - -- Mathematical operators defined for valid Big_Integer values - function "+" (L : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "-" (L : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "abs" (L : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "+" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "-" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "*" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "/" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "mod" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "rem" (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function "**" (L : Valid_Big_Integer; R : Natural) return Valid_Big_Integer - with - Import, - Global => null; - - function Min (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function Max (L, R : Valid_Big_Integer) return Valid_Big_Integer - with - Import, - Global => null; - - function Greatest_Common_Divisor - (L, R : Valid_Big_Integer) return Big_Positive - with - Import, - Pre => (L /= To_Big_Integer (0) and R /= To_Big_Integer (0)) - or else raise Constraint_Error, - Global => null; - -- Calculate the greatest common divisor for two Big_Integer values - -private - pragma SPARK_Mode (Off); - - type Big_Integer is null record; - -- Solely consists of Ghost code - -end Ada.Numerics.Big_Numbers.Big_Integers_Ghost; diff --git a/gcc/ada/libgnat/a-ngelfu.adb b/gcc/ada/libgnat/a-ngelfu.adb index 7ce2a4c..d7b6c0c 100644 --- a/gcc/ada/libgnat/a-ngelfu.adb +++ b/gcc/ada/libgnat/a-ngelfu.adb @@ -965,7 +965,6 @@ is P, Q, R : Float_Type'Base; Y : constant Float_Type'Base := abs X; - G : constant Float_Type'Base := Y * Y; Float_Type_Digits_15_Or_More : constant Boolean := Float_Type'Digits > 14; @@ -983,10 +982,14 @@ is elsif Y < Half_Ln3 and then Float_Type_Digits_15_Or_More then - P := (P2 * G + P1) * G + P0; - Q := ((Q3 * G + Q2) * G + Q1) * G + Q0; - R := G * (P / Q); - return X + X * R; + declare + G : constant Float_Type'Base := Y * Y; + begin + P := (P2 * G + P1) * G + P0; + Q := ((Q3 * G + Q2) * G + Q1) * G + Q0; + R := G * (P / Q); + return X + X * R; + end; else return Aux.Tanh (X); diff --git a/gcc/ada/libgnat/a-nudira.ads b/gcc/ada/libgnat/a-nudira.ads index 647470b..3b2ca18 100644 --- a/gcc/ada/libgnat/a-nudira.ads +++ b/gcc/ada/libgnat/a-nudira.ads @@ -44,38 +44,60 @@ generic type Result_Subtype is (<>); package Ada.Numerics.Discrete_Random with - SPARK_Mode => Off + SPARK_Mode => On, + Always_Terminates is -- Basic facilities - type Generator is limited private; + type Generator is limited private with Default_Initial_Condition; - function Random (Gen : Generator) return Result_Subtype; + function Random (Gen : Generator) return Result_Subtype with + Global => null, + Side_Effects; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); function Random (Gen : Generator; First : Result_Subtype; Last : Result_Subtype) return Result_Subtype - with Post => Random'Result in First .. Last; + with + Post => Random'Result in First .. Last, + Global => null, + Side_Effects; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); - procedure Reset (Gen : Generator; Initiator : Integer); - procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + + procedure Reset (Gen : Generator) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); -- Advanced facilities type State is private; - procedure Save (Gen : Generator; To_State : out State); - procedure Reset (Gen : Generator; From_State : State); + procedure Save (Gen : Generator; To_State : out State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + + procedure Reset (Gen : Generator; From_State : State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; - function Image (Of_State : State) return String; - function Value (Coded_State : String) return State; + function Image (Of_State : State) return String with + Global => null; + function Value (Coded_State : String) return State with + Global => null; private + pragma SPARK_Mode (Off); + type Generator is new System.Random_Numbers.Generator; type State is new System.Random_Numbers.State; diff --git a/gcc/ada/libgnat/a-nuflra.ads b/gcc/ada/libgnat/a-nuflra.ads index 7eb0494..9ea73d4 100644 --- a/gcc/ada/libgnat/a-nuflra.ads +++ b/gcc/ada/libgnat/a-nuflra.ads @@ -39,34 +39,50 @@ with System.Random_Numbers; package Ada.Numerics.Float_Random with - SPARK_Mode => Off + SPARK_Mode => On, + Always_Terminates is -- Basic facilities - type Generator is limited private; + type Generator is limited private with Default_Initial_Condition; subtype Uniformly_Distributed is Float range 0.0 .. 1.0; - function Random (Gen : Generator) return Uniformly_Distributed; + function Random (Gen : Generator) return Uniformly_Distributed with + Global => null, + Side_Effects; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + procedure Reset (Gen : Generator) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); - procedure Reset (Gen : Generator); - procedure Reset (Gen : Generator; Initiator : Integer); + procedure Reset (Gen : Generator; Initiator : Integer) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); -- Advanced facilities type State is private; - procedure Save (Gen : Generator; To_State : out State); - procedure Reset (Gen : Generator; From_State : State); + procedure Save (Gen : Generator; To_State : out State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); + procedure Reset (Gen : Generator; From_State : State) with + Global => null; + pragma Annotate (GNATprove, Mutable_In_Parameters, Generator); Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; - function Image (Of_State : State) return String; - function Value (Coded_State : String) return State; + function Image (Of_State : State) return String with + Global => null; + function Value (Coded_State : String) return State with + Global => null; private + pragma SPARK_Mode (Off); + type Generator is new System.Random_Numbers.Generator; type State is new System.Random_Numbers.State; diff --git a/gcc/ada/libgnat/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb index 5acfef4..50bb214 100644 --- a/gcc/ada/libgnat/a-strfix.adb +++ b/gcc/ada/libgnat/a-strfix.adb @@ -38,14 +38,6 @@ -- bounds of function return results were also fixed, and use of & removed for -- efficiency reasons. --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with Ada.Strings.Maps; use Ada.Strings.Maps; package body Ada.Strings.Fixed with SPARK_Mode is @@ -153,12 +145,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is Right : Character) return String is begin - return Result : String (1 .. Left) with Relaxed_Initialization do + return Result : String (1 .. Left) do for J in Result'Range loop Result (J) := Right; - pragma Loop_Invariant - (for all K in 1 .. J => - Result (K)'Initialized and then Result (K) = Right); end loop; end return; end "*"; @@ -168,82 +157,15 @@ package body Ada.Strings.Fixed with SPARK_Mode is Right : String) return String is Ptr : Integer := 0; - - -- Parts of the proof involving manipulations with the modulo operator - -- are complicated for the prover and can't be done automatically in - -- the global subprogram. That's why we isolate them in these two ghost - -- lemmas. - - procedure Lemma_Mod (K : Integer) with - Ghost, - Pre => - Right'Length /= 0 - and then Ptr mod Right'Length = 0 - and then Ptr in 0 .. Natural'Last - Right'Length - and then K in Ptr .. Ptr + Right'Length - 1, - Post => K mod Right'Length = K - Ptr; - -- Lemma_Mod is applied to an index considered in Lemma_Split to prove - -- that it has the right value modulo Right'Length. - - procedure Lemma_Split (Result : String) with - Ghost, - Relaxed_Initialization => Result, - Pre => - Right'Length /= 0 - and then Result'First = 1 - and then Result'Last >= 0 - and then Ptr mod Right'Length = 0 - and then Ptr in 0 .. Result'Last - Right'Length - and then Result (Result'First .. Ptr + Right'Length)'Initialized - and then Result (Ptr + 1 .. Ptr + Right'Length) = Right, - Post => - (for all K in Ptr + 1 .. Ptr + Right'Length => - Result (K) = Right (Right'First + (K - 1) mod Right'Length)); - -- Lemma_Split is used after Result (Ptr + 1 .. Ptr + Right'Length) is - -- updated to Right and concludes that the characters match for each - -- index when taken modulo Right'Length, as the considered slice starts - -- at index 1 modulo Right'Length. - - --------------- - -- Lemma_Mod -- - --------------- - - procedure Lemma_Mod (K : Integer) is null; - - ----------------- - -- Lemma_Split -- - ----------------- - - procedure Lemma_Split (Result : String) - is - begin - for K in Ptr + 1 .. Ptr + Right'Length loop - Lemma_Mod (K - 1); - pragma Loop_Invariant - (for all J in Ptr + 1 .. K => - Result (J) = Right (Right'First + (J - 1) mod Right'Length)); - end loop; - end Lemma_Split; - - -- Start of processing for "*" - begin if Right'Length = 0 then return ""; end if; - return Result : String (1 .. Left * Right'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Left * Right'Length) do for J in 1 .. Left loop Result (Ptr + 1 .. Ptr + Right'Length) := Right; - Lemma_Split (Result); Ptr := Ptr + Right'Length; - pragma Loop_Invariant (Ptr = J * Right'Length); - pragma Loop_Invariant (Result (1 .. Ptr)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Ptr => - Result (K) = Right (Right'First + (K - 1) mod Right'Length)); end loop; end return; end "*"; @@ -255,8 +177,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is function Delete (Source : String; From : Positive; - Through : Natural) return String - is + Through : Natural) return String is begin if From > Through then declare @@ -279,9 +200,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is Result_Length : constant Integer := Front_Len + Back_Len; -- Length of result begin - return Result : String (1 .. Result_Length) - with Relaxed_Initialization - do + return Result : String (1 .. Result_Length) do Result (1 .. Front_Len) := Source (Source'First .. From - 1); @@ -325,14 +244,11 @@ package body Ada.Strings.Fixed with SPARK_Mode is Result_Type (Source (Source'First .. Source'First + (Count - 1))); else - return Result : Result_Type with Relaxed_Initialization do + return Result : Result_Type do Result (1 .. Source'Length) := Source; for J in Source'Length + 1 .. Count loop Result (J) := Pad; - pragma Loop_Invariant - (for all K in Source'Length + 1 .. J => - Result (K)'Initialized and then Result (K) = Pad); end loop; end return; end if; @@ -342,8 +258,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Count : Natural; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Source => Head (Source, Count, Pad), Target => Source, @@ -362,37 +277,21 @@ package body Ada.Strings.Fixed with SPARK_Mode is New_Item : String) return String is Front : constant Integer := Before - Source'First; - begin if Before - 1 not in Source'First - 1 .. Source'Last then raise Index_Error; end if; - return Result : String (1 .. Source'Length + New_Item'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Source'Length + New_Item'Length) do Result (1 .. Front) := Source (Source'First .. Before - 1); Result (Front + 1 .. Front + New_Item'Length) := New_Item; - pragma Assert - (Result (1 .. Before - Source'First) - = Source (Source'First .. Before - 1)); - pragma Assert - (Result - (Before - Source'First + 1 - .. Before - Source'First + New_Item'Length) - = New_Item); - if Before <= Source'Last then Result (Front + New_Item'Length + 1 .. Result'Last) := Source (Before .. Source'Last); end if; - - pragma Assert - (Result (1 .. Before - Source'First) - = Source (Source'First .. Before - 1)); end return; end Insert; @@ -400,8 +299,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Before : Positive; New_Item : String; - Drop : Truncation := Error) - is + Drop : Truncation := Error) is begin Move (Source => Insert (Source, Before, New_Item), Target => Source, @@ -536,38 +434,14 @@ package body Ada.Strings.Fixed with SPARK_Mode is Front : constant Integer := Position - Source'First; begin - return Result : String (1 .. Result_Length) - with Relaxed_Initialization - do + return Result : String (1 .. Result_Length) do Result (1 .. Front) := Source (Source'First .. Position - 1); - pragma Assert - (Result (1 .. Position - Source'First) - = Source (Source'First .. Position - 1)); Result (Front + 1 .. Front + New_Item'Length) := New_Item; - pragma Assert - (Result - (Position - Source'First + 1 - .. Position - Source'First + New_Item'Length) - = New_Item); if Position <= Source'Last - New_Item'Length then Result (Front + New_Item'Length + 1 .. Result'Last) := Source (Position + New_Item'Length .. Source'Last); - - pragma Assert - (Result - (Position - Source'First + New_Item'Length + 1 - .. Result'Last) - = Source (Position + New_Item'Length .. Source'Last)); end if; - - pragma Assert - (if Position <= Source'Last - New_Item'Length - then - Result - (Position - Source'First + New_Item'Length + 1 - .. Result'Last) - = Source (Position + New_Item'Length .. Source'Last)); end return; end; end Overwrite; @@ -576,8 +450,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Position : Positive; New_Item : String; - Drop : Truncation := Right) - is + Drop : Truncation := Right) is begin Move (Source => Overwrite (Source, Position, New_Item), Target => Source, @@ -612,39 +485,14 @@ package body Ada.Strings.Fixed with SPARK_Mode is -- Length of result begin - return Result : String (1 .. Result_Length) - with Relaxed_Initialization do + return Result : String (1 .. Result_Length) do Result (1 .. Front_Len) := Source (Source'First .. Low - 1); - pragma Assert - (Result (1 .. Integer'Max (0, Low - Source'First)) - = Source (Source'First .. Low - 1)); Result (Front_Len + 1 .. Front_Len + By'Length) := By; - pragma Assert - (Result - (Integer'Max (0, Low - Source'First) + 1 - .. Integer'Max (0, Low - Source'First) + By'Length) - = By); if High < Source'Last then Result (Front_Len + By'Length + 1 .. Result'Last) := Source (High + 1 .. Source'Last); end if; - - pragma Assert - (Result (1 .. Integer'Max (0, Low - Source'First)) - = Source (Source'First .. Low - 1)); - pragma Assert - (Result - (Integer'Max (0, Low - Source'First) + 1 - .. Integer'Max (0, Low - Source'First) + By'Length) - = By); - pragma Assert - (if High < Source'Last - then - Result - (Integer'Max (0, Low - Source'First) + By'Length + 1 - .. Result'Last) - = Source (High + 1 .. Source'Last)); end return; end; else @@ -659,8 +507,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is By : String; Drop : Truncation := Error; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); end Replace_Slice; @@ -675,7 +522,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is Pad : Character := Space) return String is subtype Result_Type is String (1 .. Count); - begin if Count = 0 then return ""; @@ -686,12 +532,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is -- Pad on left else - return Result : Result_Type with Relaxed_Initialization do + return Result : Result_Type do for J in 1 .. Count - Source'Length loop Result (J) := Pad; - pragma Loop_Invariant - (for all K in 1 .. J => - Result (K)'Initialized and then Result (K) = Pad); end loop; if Source'Length /= 0 then @@ -705,8 +548,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Count : Natural; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Source => Tail (Source, Count, Pad), Target => Source, @@ -721,35 +563,21 @@ package body Ada.Strings.Fixed with SPARK_Mode is function Translate (Source : String; - Mapping : Maps.Character_Mapping) return String - is + Mapping : Maps.Character_Mapping) return String is begin - return Result : String (1 .. Source'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Source'Length) do for J in Source'Range loop Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1))'Initialized); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1)) = - Value (Mapping, Source (K))); end loop; end return; end Translate; procedure Translate (Source : in out String; - Mapping : Maps.Character_Mapping) - is + Mapping : Maps.Character_Mapping) is begin for J in Source'Range loop Source (J) := Value (Mapping, Source (J)); - pragma Loop_Invariant - (for all K in Source'First .. J => - Source (K) = Value (Mapping, Source'Loop_Entry (K))); end loop; end Translate; @@ -759,23 +587,9 @@ package body Ada.Strings.Fixed with SPARK_Mode is is pragma Unsuppress (Access_Check); begin - return Result : String (1 .. Source'Length) - with Relaxed_Initialization - do + return Result : String (1 .. Source'Length) do for J in Source'Range loop Result (J - (Source'First - 1)) := Mapping.all (Source (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1))'Initialized); - pragma Loop_Invariant - (for all K in Source'First .. J => - Result (K - (Source'First - 1)) = Mapping (Source (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; end return; end Translate; @@ -788,15 +602,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is begin for J in Source'Range loop Source (J) := Mapping.all (Source (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant - (for all K in Source'First .. J => - Source (K) = Mapping (Source'Loop_Entry (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; end Translate; @@ -872,8 +677,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Side : Trim_End; Justify : Alignment := Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Trim (Source, Side), Source, @@ -887,7 +691,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is Right : Maps.Character_Set) return String is High, Low : Integer; - begin Low := Index (Source, Set => Left, Test => Outside, Going => Forward); @@ -908,7 +711,6 @@ package body Ada.Strings.Fixed with SPARK_Mode is declare Result_Length : constant Integer := High - Low + 1; subtype Result_Type is String (1 .. Result_Length); - begin return Result_Type (Source (Low .. High)); end; @@ -919,8 +721,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is Left : Maps.Character_Set; Right : Maps.Character_Set; Justify : Alignment := Strings.Left; - Pad : Character := Space) - is + Pad : Character := Space) is begin Move (Source => Trim (Source, Left, Right), Target => Source, diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb index 7490780..2f4cceb 100644 --- a/gcc/ada/libgnat/a-strmap.adb +++ b/gcc/ada/libgnat/a-strmap.adb @@ -35,14 +35,6 @@ -- is bit-by-bit or character-by-character and therefore rather slow. -- Generally for character sets we favor the full 32-byte representation. --- Assertions, ghost code and loop invariants in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Assert => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore); - package body Ada.Strings.Maps with SPARK_Mode is @@ -131,36 +123,15 @@ is --------------- function To_Domain (Map : Character_Mapping) return Character_Sequence is - Result : String (1 .. Map'Length) with Relaxed_Initialization; + Result : String (1 .. Map'Length); J : Natural; - - type Character_Index is array (Character) of Natural with Ghost; - Indexes : Character_Index := [others => 0] with Ghost; - begin J := 0; for C in Map'Range loop if Map (C) /= C then J := J + 1; Result (J) := C; - Indexes (C) := J; end if; - - pragma Loop_Invariant (if Map = Identity then J = 0); - pragma Loop_Invariant (J <= Character'Pos (C) + 1); - pragma Loop_Invariant (for all K in 1 .. J => Result (K)'Initialized); - pragma Loop_Invariant (for all K in 1 .. J => Result (K) <= C); - pragma Loop_Invariant - (SPARK_Proof_Sorted_Character_Sequence (Result (1 .. J))); - pragma Loop_Invariant - (for all D in Map'First .. C => - (if Map (D) = D then - Indexes (D) = 0 - else - Indexes (D) in 1 .. J - and then Result (Indexes (D)) = D)); - pragma Loop_Invariant - (for all Char of Result (1 .. J) => Map (Char) /= Char); end loop; return Result (1 .. J); @@ -173,7 +144,7 @@ is function To_Mapping (From, To : Character_Sequence) return Character_Mapping is - Result : Character_Mapping with Relaxed_Initialization; + Result : Character_Mapping; Inserted : Character_Set := Null_Set; From_Len : constant Natural := From'Length; To_Len : constant Natural := To'Length; @@ -185,9 +156,6 @@ is for Char in Character loop Result (Char) := Char; - pragma Loop_Invariant (Result (Result'First .. Char)'Initialized); - pragma Loop_Invariant - (for all C in Result'First .. Char => Result (C) = C); end loop; for J in From'Range loop @@ -197,23 +165,6 @@ is Result (From (J)) := To (J - From'First + To'First); Inserted (From (J)) := True; - - pragma Loop_Invariant (Result'Initialized); - pragma Loop_Invariant - (for all K in From'First .. J => - Result (From (K)) = To (K - From'First + To'First) - and then Inserted (From (K))); - pragma Loop_Invariant - (for all Char in Character => - (Inserted (Char) = - (for some K in From'First .. J => Char = From (K)))); - pragma Loop_Invariant - (for all Char in Character => - (if not Inserted (Char) then Result (Char) = Char)); - pragma Loop_Invariant - (if (for all K in From'First .. J => - From (K) = To (J - From'First + To'First)) - then Result = Identity); end loop; return Result; @@ -224,195 +175,16 @@ is -------------- function To_Range (Map : Character_Mapping) return Character_Sequence is - - -- Extract from the postcondition of To_Domain the essential properties - -- that define Seq as the domain of Map. - function Is_Domain - (Map : Character_Mapping; - Seq : Character_Sequence) - return Boolean - is - (Seq'First = 1 - and then - SPARK_Proof_Sorted_Character_Sequence (Seq) - and then - (for all Char in Character => - (if (for all X of Seq => X /= Char) - then Map (Char) = Char)) - and then - (for all Char of Seq => Map (Char) /= Char)) - with - Ghost; - - -- Given Map, there is a unique sequence Seq for which - -- Is_Domain(Map,Seq) holds. - procedure Lemma_Domain_Unicity - (Map : Character_Mapping; - Seq1, Seq2 : Character_Sequence) - with - Ghost, - Pre => Is_Domain (Map, Seq1) - and then Is_Domain (Map, Seq2), - Post => Seq1 = Seq2; - - -- Isolate the proof that To_Domain(Map) returns a sequence for which - -- Is_Domain holds. - procedure Lemma_Is_Domain (Map : Character_Mapping) - with - Ghost, - Post => Is_Domain (Map, To_Domain (Map)); - - -- Deduce the alternative expression of sortedness from the one in - -- SPARK_Proof_Sorted_Character_Sequence which compares consecutive - -- elements. - procedure Lemma_Is_Sorted (Seq : Character_Sequence) - with - Ghost, - Pre => SPARK_Proof_Sorted_Character_Sequence (Seq), - Post => (for all J in Seq'Range => - (for all K in Seq'Range => - (if J < K then Seq (J) < Seq (K)))); - - -------------------------- - -- Lemma_Domain_Unicity -- - -------------------------- - - procedure Lemma_Domain_Unicity - (Map : Character_Mapping; - Seq1, Seq2 : Character_Sequence) - is - J : Positive := 1; - - begin - while J <= Seq1'Last - and then J <= Seq2'Last - and then Seq1 (J) = Seq2 (J) - loop - pragma Loop_Invariant - (Seq1 (Seq1'First .. J) = Seq2 (Seq2'First .. J)); - pragma Loop_Variant (Increases => J); - - if J = Positive'Last then - return; - end if; - - J := J + 1; - end loop; - - Lemma_Is_Sorted (Seq1); - Lemma_Is_Sorted (Seq2); - - if J <= Seq1'Last - and then J <= Seq2'Last - then - if Seq1 (J) < Seq2 (J) then - pragma Assert (for all X of Seq2 => X /= Seq1 (J)); - pragma Assert (Map (Seq1 (J)) = Seq1 (J)); - pragma Assert (False); - else - pragma Assert (for all X of Seq1 => X /= Seq2 (J)); - pragma Assert (Map (Seq2 (J)) = Seq2 (J)); - pragma Assert (False); - end if; - - elsif J <= Seq1'Last then - pragma Assert (for all X of Seq2 => X /= Seq1 (J)); - pragma Assert (Map (Seq1 (J)) = Seq1 (J)); - pragma Assert (False); - - elsif J <= Seq2'Last then - pragma Assert (for all X of Seq1 => X /= Seq2 (J)); - pragma Assert (Map (Seq2 (J)) = Seq2 (J)); - pragma Assert (False); - end if; - end Lemma_Domain_Unicity; - - --------------------- - -- Lemma_Is_Domain -- - --------------------- - - procedure Lemma_Is_Domain (Map : Character_Mapping) is - Ignore : constant Character_Sequence := To_Domain (Map); - begin - null; - end Lemma_Is_Domain; - - --------------------- - -- Lemma_Is_Sorted -- - --------------------- - - procedure Lemma_Is_Sorted (Seq : Character_Sequence) is - begin - for A in Seq'Range loop - exit when A = Positive'Last; - - for B in A + 1 .. Seq'Last loop - pragma Loop_Invariant - (for all K in A + 1 .. B => Seq (A) < Seq (K)); - end loop; - - pragma Loop_Invariant - (for all J in Seq'First .. A => - (for all K in Seq'Range => - (if J < K then Seq (J) < Seq (K)))); - end loop; - end Lemma_Is_Sorted; - - -- Local variables - - Result : String (1 .. Map'Length) with Relaxed_Initialization; + Result : String (1 .. Map'Length); J : Natural; - - -- Repeat the computation from To_Domain in ghost code, in order to - -- prove the relationship between Result and To_Domain(Map). - - Domain : String (1 .. Map'Length) with Ghost, Relaxed_Initialization; - type Character_Index is array (Character) of Natural with Ghost; - Indexes : Character_Index := [others => 0] with Ghost; - - -- Start of processing for To_Range - begin J := 0; for C in Map'Range loop if Map (C) /= C then J := J + 1; Result (J) := Map (C); - Domain (J) := C; - Indexes (C) := J; end if; - - -- Repeat the loop invariants from To_Domain regarding Domain and - -- Indexes. Add similar loop invariants for Result and Indexes. - - pragma Loop_Invariant (J <= Character'Pos (C) + 1); - pragma Loop_Invariant (Result (1 .. J)'Initialized); - pragma Loop_Invariant (Domain (1 .. J)'Initialized); - pragma Loop_Invariant (for all K in 1 .. J => Domain (K) <= C); - pragma Loop_Invariant - (SPARK_Proof_Sorted_Character_Sequence (Domain (1 .. J))); - pragma Loop_Invariant - (for all D in Map'First .. C => - (if Map (D) = D then - Indexes (D) = 0 - else - Indexes (D) in 1 .. J - and then Domain (Indexes (D)) = D - and then Result (Indexes (D)) = Map (D))); - pragma Loop_Invariant - (for all Char of Domain (1 .. J) => Map (Char) /= Char); - pragma Loop_Invariant - (for all K in 1 .. J => Result (K) = Map (Domain (K))); end loop; - pragma Assert (Is_Domain (Map, Domain (1 .. J))); - - -- Show the equality of Domain and To_Domain(Map) - - Lemma_Is_Domain (Map); - Lemma_Domain_Unicity (Map, Domain (1 .. J), To_Domain (Map)); - pragma Assert - (for all K in 1 .. J => Domain (K) = To_Domain (Map) (K)); - pragma Assert (To_Domain (Map)'Length = J); return Result (1 .. J); end To_Range; @@ -422,27 +194,18 @@ is --------------- function To_Ranges (Set : Character_Set) return Character_Ranges is - Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1) - with Relaxed_Initialization; + Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1); Range_Num : Natural; C : Character; - C_Iter : Character with Ghost; begin C := Character'First; Range_Num := 0; loop - C_Iter := C; - -- Skip gap between subsets while not Set (C) loop - pragma Loop_Invariant - (Character'Pos (C) >= Character'Pos (C'Loop_Entry)); - pragma Loop_Invariant - (for all Char in C'Loop_Entry .. C => not Set (Char)); - pragma Loop_Variant (Increases => C); exit when C = Character'Last; C := Character'Succ (C); end loop; @@ -455,12 +218,6 @@ is -- Span a subset loop - pragma Loop_Invariant - (Character'Pos (C) >= Character'Pos (C'Loop_Entry)); - pragma Loop_Invariant - (for all Char in C'Loop_Entry .. C => - (if Char /= C then Set (Char))); - pragma Loop_Variant (Increases => C); exit when not Set (C) or else C = Character'Last; C := Character'Succ (C); end loop; @@ -471,31 +228,6 @@ is else Max_Ranges (Range_Num).High := Character'Pred (C); end if; - - pragma Assert - (for all Char in C_Iter .. C => - (Set (Char) = - (Char in Max_Ranges (Range_Num).Low .. - Max_Ranges (Range_Num).High))); - pragma Assert - (for all Char in Character'First .. C_Iter => - (if Char /= C_Iter then - (Set (Char) = - (for some Span of Max_Ranges (1 .. Range_Num - 1) => - Char in Span.Low .. Span.High)))); - - pragma Loop_Invariant (2 * Range_Num <= Character'Pos (C) + 1); - pragma Loop_Invariant (Max_Ranges (1 .. Range_Num)'Initialized); - pragma Loop_Invariant (not Set (C)); - pragma Loop_Invariant - (for all Char in Character'First .. C => - (Set (Char) = - (for some Span of Max_Ranges (1 .. Range_Num) => - Char in Span.Low .. Span.High))); - pragma Loop_Invariant - (for all Span of Max_Ranges (1 .. Range_Num) => - (for all Char in Span.Low .. Span.High => Set (Char))); - pragma Loop_Variant (Increases => Range_Num); end loop; return Max_Ranges (1 .. Range_Num); @@ -506,8 +238,7 @@ is ----------------- function To_Sequence (Set : Character_Set) return Character_Sequence is - Result : String (1 .. Character'Pos (Character'Last) + 1) - with Relaxed_Initialization; + Result : String (1 .. Character'Pos (Character'Last) + 1); Count : Natural := 0; begin for Char in Set'Range loop @@ -515,17 +246,6 @@ is Count := Count + 1; Result (Count) := Char; end if; - - pragma Loop_Invariant (Count <= Character'Pos (Char) + 1); - pragma Loop_Invariant (Result (1 .. Count)'Initialized); - pragma Loop_Invariant (for all K in 1 .. Count => Result (K) <= Char); - pragma Loop_Invariant - (SPARK_Proof_Sorted_Character_Sequence (Result (1 .. Count))); - pragma Loop_Invariant - (for all C in Set'First .. Char => - (Set (C) = (for some X of Result (1 .. Count) => C = X))); - pragma Loop_Invariant - (for all Char of Result (1 .. Count) => Is_In (Char, Set)); end loop; return Result (1 .. Count); @@ -541,19 +261,7 @@ is for R in Ranges'Range loop for C in Ranges (R).Low .. Ranges (R).High loop Result (C) := True; - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = - ((for some Prev in Ranges'First .. R - 1 => - Char in Ranges (Prev).Low .. Ranges (Prev).High) - or else Char in Ranges (R).Low .. C)); end loop; - - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = - (for some Prev in Ranges'First .. R => - Char in Ranges (Prev).Low .. Ranges (Prev).High)); end loop; return Result; @@ -564,9 +272,6 @@ is begin for C in Span.Low .. Span.High loop Result (C) := True; - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = (Char in Span.Low .. C)); end loop; return Result; @@ -577,10 +282,6 @@ is begin for J in Sequence'Range loop Result (Sequence (J)) := True; - pragma Loop_Invariant - (for all Char in Character => - Result (Char) = - (for some K in Sequence'First .. J => Char = Sequence (K))); end loop; return Result; @@ -599,8 +300,6 @@ is function Value (Map : Character_Mapping; - Element : Character) return Character - is - (Map (Element)); + Element : Character) return Character is (Map (Element)); end Ada.Strings.Maps; diff --git a/gcc/ada/libgnat/a-strsea.adb b/gcc/ada/libgnat/a-strsea.adb index 45fb682..55bf767 100644 --- a/gcc/ada/libgnat/a-strsea.adb +++ b/gcc/ada/libgnat/a-strsea.adb @@ -35,14 +35,6 @@ -- case of identity mappings for Count and Index, and also Index_Non_Blank -- is specialized (rather than using the general Index routine). --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with Ada.Strings.Maps; use Ada.Strings.Maps; with System; use System; @@ -110,10 +102,6 @@ package body Ada.Strings.Search with SPARK_Mode is Num := Num + 1; Ind := Ind + PL1; end if; - - pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); - pragma Loop_Invariant (Ind >= Source'First); - pragma Loop_Variant (Increases => Ind); end loop; -- Mapped case @@ -125,25 +113,15 @@ package body Ada.Strings.Search with SPARK_Mode is if Pattern (K) /= Value (Mapping, Source (Ind + (K - Pattern'First))) then - pragma Assert (not Match (Source, Pattern, Mapping, Ind)); goto Cont; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Value (Mapping, - Source (Ind + (J - Pattern'First)))); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); Num := Num + 1; Ind := Ind + PL1; <<Cont>> null; - pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); - pragma Loop_Invariant (Ind >= Source'First); - pragma Loop_Variant (Increases => Ind); end loop; end if; @@ -185,30 +163,15 @@ package body Ada.Strings.Search with SPARK_Mode is Ind := Ind + 1; for K in Pattern'Range loop if Pattern (K) /= Mapping (Source (Ind + (K - Pattern'First))) then - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Assert (not Match (Source, Pattern, Mapping, Ind)); goto Cont; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); Num := Num + 1; Ind := Ind + PL1; <<Cont>> null; - pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); - pragma Loop_Invariant (Ind >= Source'First); - pragma Loop_Variant (Increases => Ind); end loop; return Num; @@ -219,10 +182,8 @@ package body Ada.Strings.Search with SPARK_Mode is Set : Maps.Character_Set) return Natural is N : Natural := 0; - begin for J in Source'Range loop - pragma Loop_Invariant (N <= J - Source'First); if Is_In (Source (J), Set) then N := N + 1; end if; @@ -241,8 +202,7 @@ package body Ada.Strings.Search with SPARK_Mode is From : Positive; Test : Membership; First : out Positive; - Last : out Natural) - is + Last : out Natural) is begin -- AI05-031: Raise Index error if Source non-empty and From not in range @@ -264,10 +224,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := K - 1; return; end if; - - pragma Loop_Invariant - (for all L in J .. K => - Belongs (Source (L), Set, Test)); end loop; end if; @@ -277,10 +233,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := Source'Last; return; end if; - - pragma Loop_Invariant - (for all K in Integer'Max (From, Source'First) .. J => - not Belongs (Source (K), Set, Test)); end loop; -- Here if no token found @@ -294,8 +246,7 @@ package body Ada.Strings.Search with SPARK_Mode is Set : Maps.Character_Set; Test : Membership; First : out Positive; - Last : out Natural) - is + Last : out Natural) is begin for J in Source'Range loop if Belongs (Source (J), Set, Test) then @@ -307,10 +258,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := K - 1; return; end if; - - pragma Loop_Invariant - (for all L in J .. K => - Belongs (Source (L), Set, Test)); end loop; end if; @@ -320,10 +267,6 @@ package body Ada.Strings.Search with SPARK_Mode is Last := Source'Last; return; end if; - - pragma Loop_Invariant - (for all K in Source'First .. J => - not Belongs (Source (K), Set, Test)); end loop; -- Here if no token found @@ -335,7 +278,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Source'First not in Positive then raise Constraint_Error; - else First := Source'First; Last := 0; @@ -353,7 +295,6 @@ package body Ada.Strings.Search with SPARK_Mode is Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is PL1 : constant Integer := Pattern'Length - 1; - begin if Pattern = "" then raise Pattern_Error; @@ -374,13 +315,8 @@ package body Ada.Strings.Search with SPARK_Mode is if Is_Identity (Mapping) then for Ind in Source'First .. Source'Last - PL1 loop if Pattern = Source (Ind .. Ind + PL1) then - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; end if; - - pragma Loop_Invariant - (for all J in Source'First .. Ind => - not Match (Source, Pattern, Mapping, J)); end loop; -- Mapped forward case @@ -393,20 +329,11 @@ package body Ada.Strings.Search with SPARK_Mode is then goto Cont1; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Value (Mapping, - Source (Ind + (J - Pattern'First)))); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; <<Cont1>> - pragma Loop_Invariant - (for all J in Source'First .. Ind => - not Match (Source, Pattern, Mapping, J)); null; end loop; end if; @@ -419,13 +346,8 @@ package body Ada.Strings.Search with SPARK_Mode is if Is_Identity (Mapping) then for Ind in reverse Source'First .. Source'Last - PL1 loop if Pattern = Source (Ind .. Ind + PL1) then - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; end if; - - pragma Loop_Invariant - (for all J in Ind .. Source'Last - PL1 => - not Match (Source, Pattern, Mapping, J)); end loop; -- Mapped backward case @@ -438,20 +360,11 @@ package body Ada.Strings.Search with SPARK_Mode is then goto Cont2; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Value (Mapping, - Source (Ind + (J - Pattern'First)))); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; <<Cont2>> - pragma Loop_Invariant - (for all J in Ind .. Source'Last - PL1 => - not Match (Source, Pattern, Mapping, J)); null; end loop; end if; @@ -495,27 +408,17 @@ package body Ada.Strings.Search with SPARK_Mode is if Pattern (K) /= Mapping.all (Source (Ind + (K - Pattern'First))) then - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); goto Cont1; end if; pragma Loop_Invariant (for all J in Pattern'First .. K => Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; - pragma Assert (Match (Source, Pattern, Mapping, Ind)); return Ind; <<Cont1>> - pragma Loop_Invariant - (for all J in Source'First .. Ind => - not Match (Source, Pattern, Mapping, J)); null; end loop; @@ -527,26 +430,13 @@ package body Ada.Strings.Search with SPARK_Mode is if Pattern (K) /= Mapping.all (Source (Ind + (K - Pattern'First))) then - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); goto Cont2; end if; - - pragma Loop_Invariant - (for all J in Pattern'First .. K => - Pattern (J) = Mapping (Source (Ind + (J - Pattern'First)))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; return Ind; <<Cont2>> - pragma Loop_Invariant - (for all J in Ind .. Source'Last - PL1 => - not Match (Source, Pattern, Mapping, J)); null; end loop; end if; @@ -561,8 +451,7 @@ package body Ada.Strings.Search with SPARK_Mode is (Source : String; Set : Maps.Character_Set; Test : Membership := Inside; - Going : Direction := Forward) return Natural - is + Going : Direction := Forward) return Natural is begin -- Forwards case @@ -571,10 +460,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Belongs (Source (J), Set, Test) then return J; end if; - - pragma Loop_Invariant - (for all C of Source (Source'First .. J) => - not Belongs (C, Set, Test)); end loop; -- Backwards case @@ -584,10 +469,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Belongs (Source (J), Set, Test) then return J; end if; - - pragma Loop_Invariant - (for all C of Source (J .. Source'Last) => - not Belongs (C, Set, Test)); end loop; end if; @@ -604,7 +485,6 @@ package body Ada.Strings.Search with SPARK_Mode is Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is Result : Natural; - PL1 : constant Integer := Pattern'Length - 1; begin -- AI05-056: If source is empty result is always zero @@ -619,12 +499,6 @@ package body Ada.Strings.Search with SPARK_Mode is Result := Index (Source (From .. Source'Last), Pattern, Forward, Mapping); - pragma Assert - (if (for some J in From .. Source'Last - PL1 => - Match (Source, Pattern, Mapping, J)) - then Result in From .. Source'Last - PL1 - and then Match (Source, Pattern, Mapping, Result) - else Result = 0); else if From > Source'Last then @@ -633,12 +507,6 @@ package body Ada.Strings.Search with SPARK_Mode is Result := Index (Source (Source'First .. From), Pattern, Backward, Mapping); - pragma Assert - (if (for some J in Source'First .. From - PL1 => - Match (Source, Pattern, Mapping, J)) - then Result in Source'First .. From - PL1 - and then Match (Source, Pattern, Mapping, Result) - else Result = 0); end if; return Result; @@ -722,9 +590,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Source (J) /= ' ' then return J; end if; - - pragma Loop_Invariant - (for all C of Source (Source'First .. J) => C = ' '); end loop; else -- Going = Backward @@ -732,9 +597,6 @@ package body Ada.Strings.Search with SPARK_Mode is if Source (J) /= ' ' then return J; end if; - - pragma Loop_Invariant - (for all C of Source (J .. Source'Last) => C = ' '); end loop; end if; diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb index 6540924..8afde71 100644 --- a/gcc/ada/libgnat/a-strsup.adb +++ b/gcc/ada/libgnat/a-strsup.adb @@ -29,15 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop (in)variants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Loop_Variant => Ignore, - Assert => Ignore); - with Ada.Strings.Maps; use Ada.Strings.Maps; package body Ada.Strings.Superbounded with SPARK_Mode is @@ -1438,91 +1429,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Indx : Natural; Ilen : constant Natural := Item'Length; - -- Parts of the proof involving manipulations with the modulo operator - -- are complicated for the prover and can't be done automatically in - -- the global subprogram. That's why we isolate them in these two ghost - -- lemmas. - - procedure Lemma_Mod (K : Natural; Q : Natural) with - Ghost, - Pre => Ilen /= 0 - and then Q mod Ilen = 0 - and then K - Q in 0 .. Ilen - 1, - Post => K mod Ilen = K - Q; - -- Lemma_Mod is applied to an index considered in Lemma_Split to prove - -- that it has the right value modulo Item'Length. - - procedure Lemma_Mod_Zero (X : Natural) with - Ghost, - Pre => Ilen /= 0 - and then X mod Ilen = 0 - and then X <= Natural'Last - Ilen, - Post => (X + Ilen) mod Ilen = 0; - -- Lemma_Mod_Zero is applied to prove that the length of the range - -- of indexes considered in the loop, when dropping on the Left, is - -- a multiple of Item'Length. - - procedure Lemma_Split (Going : Direction) with - Ghost, - Pre => - Ilen /= 0 - and then Indx in 0 .. Max_Length - Ilen - and then - (if Going = Forward - then Indx mod Ilen = 0 - else (Max_Length - Indx - Ilen) mod Ilen = 0) - and then Result.Data (Indx + 1 .. Indx + Ilen)'Initialized - and then String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item, - Post => - (if Going = Forward then - (for all J in Indx + 1 .. Indx + Ilen => - Result.Data (J) = Item (Item'First + (J - 1) mod Ilen)) - else - (for all J in Indx + 1 .. Indx + Ilen => - Result.Data (J) = - Item (Item'Last - (Max_Length - J) mod Ilen))); - -- Lemma_Split is used after Result.Data (Indx + 1 .. Indx + Ilen) is - -- updated to Item and concludes that the characters match for each - -- index when taken modulo Item'Length, as the considered slice starts - -- at index 1 (or ends at index Max_Length, if Going = Backward) modulo - -- Item'Length. - - --------------- - -- Lemma_Mod -- - --------------- - - procedure Lemma_Mod (K : Natural; Q : Natural) is null; - - -------------------- - -- Lemma_Mod_Zero -- - -------------------- - - procedure Lemma_Mod_Zero (X : Natural) is null; - - ----------------- - -- Lemma_Split -- - ----------------- - - procedure Lemma_Split (Going : Direction) is - begin - if Going = Forward then - for K in Indx + 1 .. Indx + Ilen loop - Lemma_Mod (K - 1, Indx); - pragma Loop_Invariant - (for all J in Indx + 1 .. K => - Result.Data (J) = Item (Item'First + (J - 1) mod Ilen)); - end loop; - else - for K in Indx + 1 .. Indx + Ilen loop - Lemma_Mod (Max_Length - K, Max_Length - Indx - Ilen); - pragma Loop_Invariant - (for all J in Indx + 1 .. K => - Result.Data (J) = - Item (Item'Last - (Max_Length - J) mod Ilen)); - end loop; - end if; - end Lemma_Split; - begin if Count = 0 or else Ilen <= Max_Length / Count then if Count * Ilen > 0 then @@ -1531,19 +1437,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is for J in 1 .. Count loop Result.Data (Indx + 1 .. Indx + Ilen) := Super_String_Data (Item); - pragma Assert - (for all K in 1 .. Ilen => - Result.Data (Indx + K) = Item (Item'First - 1 + K)); - pragma Assert - (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); - Lemma_Split (Forward); Indx := Indx + Ilen; - pragma Loop_Invariant (Indx = J * Ilen); - pragma Loop_Invariant (Result.Data (1 .. Indx)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Indx => - Result.Data (K) = - Item (Item'First + (K - 1) mod Ilen)); end loop; end if; @@ -1557,36 +1451,11 @@ package body Ada.Strings.Superbounded with SPARK_Mode is while Indx < Max_Length - Ilen loop Result.Data (Indx + 1 .. Indx + Ilen) := Super_String_Data (Item); - pragma Assert - (for all K in 1 .. Ilen => - Result.Data (Indx + K) = Item (Item'First - 1 + K)); - pragma Assert - (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); - Lemma_Split (Forward); Indx := Indx + Ilen; - pragma Loop_Invariant (Indx mod Ilen = 0); - pragma Loop_Invariant (Indx in 0 .. Max_Length - 1); - pragma Loop_Invariant (Result.Data (1 .. Indx)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Indx => - Result.Data (K) = - Item (Item'First + (K - 1) mod Ilen)); - pragma Loop_Variant (Increases => Indx); end loop; Result.Data (Indx + 1 .. Max_Length) := Super_String_Data (Item (Item'First .. Item'First + (Max_Length - Indx - 1))); - pragma Assert - (for all J in Indx + 1 .. Max_Length => - Result.Data (J) = Item (Item'First - 1 - Indx + J)); - - for J in Indx + 1 .. Max_Length loop - Lemma_Mod (J - 1, Indx); - pragma Loop_Invariant - (for all K in 1 .. J => - Result.Data (K) = - Item (Item'First + (K - 1) mod Ilen)); - end loop; when Strings.Left => Indx := Max_Length; @@ -1595,40 +1464,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Indx := Indx - Ilen; Result.Data (Indx + 1 .. Indx + Ilen) := Super_String_Data (Item); - pragma Assert - (for all K in 1 .. Ilen => - Result.Data (Indx + K) = Item (Item'First - 1 + K)); - pragma Assert - (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); - Lemma_Split (Backward); - Lemma_Mod_Zero (Max_Length - Indx - Ilen); - pragma Loop_Invariant - ((Max_Length - Indx) mod Ilen = 0); - pragma Loop_Invariant (Indx in 1 .. Max_Length); - pragma Loop_Invariant - (Result.Data (Indx + 1 .. Max_Length)'Initialized); - pragma Loop_Invariant - (for all K in Indx + 1 .. Max_Length => - Result.Data (K) = - Item (Item'Last - (Max_Length - K) mod Ilen)); - pragma Loop_Variant (Decreases => Indx); end loop; Result.Data (1 .. Indx) := Super_String_Data (Item (Item'Last - Indx + 1 .. Item'Last)); - pragma Assert - (for all J in 1 .. Indx => - Result.Data (J) = Item (Item'Last - Indx + J)); - - for J in reverse 1 .. Indx loop - Lemma_Mod (Max_Length - J, Max_Length - Indx); - pragma Loop_Invariant - (for all K in J .. Max_Length => - Result.Data (K) = - Item (Item'Last - (Max_Length - K) mod Ilen)); - end loop; - pragma Assert - (Result.Data (1 .. Max_Length)'Initialized); when Strings.Error => raise Ada.Strings.Length_Error; @@ -1643,8 +1482,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is function Super_Replicate (Count : Natural; Item : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is + Drop : Strings.Truncation := Strings.Error) return Super_String is begin return Super_Replicate (Count, Super_To_String (Item), Drop, Item.Max_Length); @@ -1820,14 +1658,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Mapping : Maps.Character_Mapping) return Super_String is Result : Super_String (Source.Max_Length); - begin for J in 1 .. Source.Current_Length loop Result.Data (J) := Value (Mapping, Source.Data (J)); - pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - Result.Data (K) = Value (Mapping, Source.Data (K))); end loop; Result.Current_Length := Source.Current_Length; @@ -1836,14 +1669,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is procedure Super_Translate (Source : in out Super_String; - Mapping : Maps.Character_Mapping) - is + Mapping : Maps.Character_Mapping) is begin for J in 1 .. Source.Current_Length loop Source.Data (J) := Value (Mapping, Source.Data (J)); - pragma Loop_Invariant - (for all K in 1 .. J => - Source.Data (K) = Value (Mapping, Source'Loop_Entry.Data (K))); end loop; end Super_Translate; @@ -1852,20 +1681,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Mapping : Maps.Character_Mapping_Function) return Super_String is Result : Super_String (Source.Max_Length); - begin for J in 1 .. Source.Current_Length loop Result.Data (J) := Mapping.all (Source.Data (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - Result.Data (K) = Mapping (Source.Data (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; Result.Current_Length := Source.Current_Length; @@ -1874,20 +1692,10 @@ package body Ada.Strings.Superbounded with SPARK_Mode is procedure Super_Translate (Source : in out Super_String; - Mapping : Maps.Character_Mapping_Function) - is + Mapping : Maps.Character_Mapping_Function) is begin for J in 1 .. Source.Current_Length loop Source.Data (J) := Mapping.all (Source.Data (J)); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); - pragma Loop_Invariant - (for all K in 1 .. J => - Source.Data (K) = Mapping (Source'Loop_Entry.Data (K))); - pragma Annotate (GNATprove, False_Positive, - "call via access-to-subprogram", - "function Mapping must always terminate"); end loop; end Super_Translate; @@ -1901,7 +1709,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is is Result : Super_String (Source.Max_Length); Last : constant Natural := Source.Current_Length; - begin case Side is when Strings.Left => @@ -2101,13 +1908,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is begin if Left > Max_Length then raise Ada.Strings.Length_Error; - else for J in 1 .. Left loop Result.Data (J) := Right; - pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => Result.Data (K) = Right); end loop; Result.Current_Length := Left; @@ -2126,80 +1929,15 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Rlen : constant Natural := Right'Length; Nlen : constant Natural := Left * Rlen; - -- Parts of the proof involving manipulations with the modulo operator - -- are complicated for the prover and can't be done automatically in - -- the global subprogram. That's why we isolate them in these two ghost - -- lemmas. - - procedure Lemma_Mod (K : Integer) with - Ghost, - Pre => - Rlen /= 0 - and then Pos mod Rlen = 0 - and then Pos in 0 .. Max_Length - Rlen - and then K in Pos .. Pos + Rlen - 1, - Post => K mod Rlen = K - Pos; - -- Lemma_Mod is applied to an index considered in Lemma_Split to prove - -- that it has the right value modulo Right'Length. - - procedure Lemma_Split with - Ghost, - Pre => - Rlen /= 0 - and then Pos mod Rlen = 0 - and then Pos in 0 .. Max_Length - Rlen - and then Result.Data (1 .. Pos + Rlen)'Initialized - and then String (Result.Data (Pos + 1 .. Pos + Rlen)) = Right, - Post => - (for all K in Pos + 1 .. Pos + Rlen => - Result.Data (K) = Right (Right'First + (K - 1) mod Rlen)); - -- Lemma_Split is used after Result.Data (Pos + 1 .. Pos + Rlen) is - -- updated to Right and concludes that the characters match for each - -- index when taken modulo Right'Length, as the considered slice starts - -- at index 1 modulo Right'Length. - - --------------- - -- Lemma_Mod -- - --------------- - - procedure Lemma_Mod (K : Integer) is null; - - ----------------- - -- Lemma_Split -- - ----------------- - - procedure Lemma_Split is - begin - for K in Pos + 1 .. Pos + Rlen loop - Lemma_Mod (K - 1); - pragma Loop_Invariant - (for all J in Pos + 1 .. K => - Result.Data (J) = Right (Right'First + (J - 1) mod Rlen)); - end loop; - end Lemma_Split; - begin if Nlen > Max_Length then raise Ada.Strings.Length_Error; - else if Nlen > 0 then for J in 1 .. Left loop Result.Data (Pos + 1 .. Pos + Rlen) := Super_String_Data (Right); - pragma Assert - (for all K in 1 .. Rlen => Result.Data (Pos + K) = - Right (Right'First - 1 + K)); - pragma Assert - (String (Result.Data (Pos + 1 .. Pos + Rlen)) = Right); - Lemma_Split; Pos := Pos + Rlen; - pragma Loop_Invariant (Pos = J * Rlen); - pragma Loop_Invariant (Result.Data (1 .. Pos)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Pos => - Result.Data (K) = - Right (Right'First + (K - 1) mod Rlen)); end loop; end if; @@ -2221,19 +1959,12 @@ package body Ada.Strings.Superbounded with SPARK_Mode is begin if Nlen > Right.Max_Length then raise Ada.Strings.Length_Error; - else if Nlen > 0 then for J in 1 .. Left loop Result.Data (Pos + 1 .. Pos + Rlen) := Right.Data (1 .. Rlen); Pos := Pos + Rlen; - pragma Loop_Invariant (Pos = J * Rlen); - pragma Loop_Invariant (Result.Data (1 .. Pos)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. Pos => - Result.Data (K) = - Right.Data (1 + (K - 1) mod Rlen)); end loop; end if; @@ -2259,7 +1990,6 @@ package body Ada.Strings.Superbounded with SPARK_Mode is if Slen <= Max_Length then Result.Data (1 .. Slen) := Super_String_Data (Source); Result.Current_Length := Slen; - else case Drop is when Strings.Right => diff --git a/gcc/ada/libgnat/a-strsup.ads b/gcc/ada/libgnat/a-strsup.ads index 65d13ed..68098ea 100644 --- a/gcc/ada/libgnat/a-strsup.ads +++ b/gcc/ada/libgnat/a-strsup.ads @@ -42,10 +42,11 @@ -- contract cases should not be executed at runtime as well, in order not to -- slow down the execution of these functions. -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore, + Ghost_Predicate => Ignore); with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function; with Ada.Strings.Search; diff --git a/gcc/ada/libgnat/g-dyntab.ads b/gcc/ada/libgnat/g-dyntab.ads index 7e2e3b2..7810986 100644 --- a/gcc/ada/libgnat/g-dyntab.ads +++ b/gcc/ada/libgnat/g-dyntab.ads @@ -168,8 +168,9 @@ package GNAT.Dynamic_Tables is -- -- Tab : Table_Type renames X.Table (First .. X.Last); -- - -- Note: The Table component must come first. See declarations of - -- SCO_Unit_Table and SCO_Table in scos.h. + -- Note: The Table component must come first to simplify interfacing + -- with C, similar to how we do it for the Table unit; see declarations + -- of Names_Ptr and Names_Char_Ptr in namet.h. Locked : Boolean := False; -- Table reallocation is permitted only if this is False. A client may diff --git a/gcc/ada/libgnat/i-c.adb b/gcc/ada/libgnat/i-c.adb index d248ceb..e63c014 100644 --- a/gcc/ada/libgnat/i-c.adb +++ b/gcc/ada/libgnat/i-c.adb @@ -29,78 +29,10 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body Interfaces.C with SPARK_Mode is - -------------------- - -- C_Length_Ghost -- - -------------------- - - function C_Length_Ghost (Item : char_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - - function C_Length_Ghost (Item : wchar_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = wide_nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= wide_nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - - function C_Length_Ghost (Item : char16_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = char16_nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char16_nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - - function C_Length_Ghost (Item : char32_array) return size_t is - begin - for J in Item'Range loop - if Item (J) = char32_nul then - return J - Item'First; - end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char32_nul); - end loop; - - raise Program_Error; - end C_Length_Ghost; - ----------------------- -- Is_Nul_Terminated -- ----------------------- @@ -113,9 +45,6 @@ is if Item (J) = nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= nul); end loop; return False; @@ -129,9 +58,6 @@ is if Item (J) = wide_nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= wide_nul); end loop; return False; @@ -145,9 +71,6 @@ is if Item (J) = char16_nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char16_nul); end loop; return False; @@ -161,9 +84,6 @@ is if Item (J) = char32_nul then return True; end if; - - pragma Loop_Invariant - (for all K in Item'First .. J => Item (K) /= char32_nul); end loop; return False; @@ -194,14 +114,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = nul then @@ -211,8 +123,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -220,17 +130,10 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : String (1 .. Count_Cst) with Relaxed_Initialization; - + R : String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -252,14 +155,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = nul then @@ -285,19 +180,6 @@ is for J in 1 .. Count loop Target (To) := Character (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -329,14 +211,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = wide_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= wide_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = wide_nul then @@ -346,8 +220,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -355,17 +227,10 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : Wide_String (1 .. Count_Cst) with Relaxed_Initialization; - + R : Wide_String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -387,14 +252,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = wide_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= wide_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = wide_nul then @@ -420,19 +277,6 @@ is for J in 1 .. Count loop Target (To) := To_Ada (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -464,14 +308,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char16_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char16_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char16_nul then @@ -481,8 +317,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -490,17 +324,10 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : Wide_String (1 .. Count_Cst) with Relaxed_Initialization; - + R : Wide_String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -522,14 +349,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char16_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char16_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char16_nul then @@ -555,19 +374,6 @@ is for J in 1 .. Count loop Target (To) := To_Ada (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -599,15 +405,6 @@ is From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char32_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char32_nul); - pragma Loop_Invariant (From <= Item'First + C_Length_Ghost (Item)); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char32_nul then @@ -617,8 +414,6 @@ is end if; end loop; - pragma Assert (From = Item'First + C_Length_Ghost (Item)); - Count := Natural (From - Item'First); else @@ -626,17 +421,11 @@ is end if; declare - Count_Cst : constant Natural := Count; - R : Wide_Wide_String (1 .. Count_Cst) with Relaxed_Initialization; + R : Wide_Wide_String (1 .. Count); begin for J in R'Range loop R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); - - pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); - pragma Loop_Invariant - (for all K in 1 .. J => - R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); end loop; return R; @@ -658,14 +447,6 @@ is if Trim_Nul then From := Item'First; loop - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant - (for some J in From .. Item'Last => Item (J) = char32_nul); - pragma Loop_Invariant - (for all J in Item'First .. From when J /= From => - Item (J) /= char32_nul); - pragma Loop_Variant (Increases => From); - if From > Item'Last then raise Terminator_Error; elsif Item (From) = char32_nul then @@ -691,19 +472,6 @@ is for J in 1 .. Count loop Target (To) := To_Ada (Item (From)); - pragma Loop_Invariant (From in Item'Range); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant (To = Target'First + (J - 1)); - pragma Loop_Invariant (From = Item'First + size_t (J - 1)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all K in Target'First .. To => - Target (K) = - To_Ada (Item (size_t (K - Target'First) + Item'First))); - -- Avoid possible overflow when incrementing To in the last -- iteration of the loop. exit when J = Count; @@ -734,26 +502,14 @@ is begin if Append_Nul then declare - R : char_array (0 .. Item'Length) with Relaxed_Initialization; - + R : char_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -774,19 +530,10 @@ is else declare - R : char_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : char_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -814,18 +561,6 @@ is for From in Item'Range loop Target (To) := char (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; @@ -836,7 +571,6 @@ is Target (To) := nul; Count := Item'Length + 1; end if; - else Count := Item'Length; end if; @@ -859,26 +593,14 @@ is begin if Append_Nul then declare - R : wchar_array (0 .. Item'Length) with Relaxed_Initialization; - + R : wchar_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := wide_nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -895,19 +617,10 @@ is else declare - R : wchar_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : wchar_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -925,40 +638,17 @@ is Append_Nul : Boolean := True) is To : size_t; - begin if Target'Length < Item'Length then raise Constraint_Error; - else To := Target'First; for From in Item'Range loop Target (To) := To_C (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; - pragma Assert - (for all J in Item'Range => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - pragma Assert - (if Item'Length /= 0 then - Target (Target'First .. - Target'First + (Item'Length - 1))'Initialized); - if Append_Nul then if To > Target'Last then raise Constraint_Error; @@ -966,7 +656,6 @@ is Target (To) := wide_nul; Count := Item'Length + 1; end if; - else Count := Item'Length; end if; @@ -989,26 +678,14 @@ is begin if Append_Nul then declare - R : char16_array (0 .. Item'Length) with Relaxed_Initialization; - + R : char16_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := char16_nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -1022,22 +699,12 @@ is if Item'Length = 0 then raise Constraint_Error; - else declare - R : char16_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : char16_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -1055,7 +722,6 @@ is Append_Nul : Boolean := True) is To : size_t; - begin if Target'Length < Item'Length then raise Constraint_Error; @@ -1065,30 +731,9 @@ is for From in Item'Range loop Target (To) := To_C (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; - pragma Assert - (for all J in Item'Range => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - pragma Assert - (if Item'Length /= 0 then - Target (Target'First .. - Target'First + (Item'Length - 1))'Initialized); - if Append_Nul then if To > Target'Last then raise Constraint_Error; @@ -1096,7 +741,6 @@ is Target (To) := char16_nul; Count := Item'Length + 1; end if; - else Count := Item'Length; end if; @@ -1119,26 +763,14 @@ is begin if Append_Nul then declare - R : char32_array (0 .. Item'Length) with Relaxed_Initialization; - + R : char32_array (0 .. Item'Length); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; R (R'Last) := char32_nul; - pragma Assert - (for all J in Item'Range => - R (size_t (J - Item'First)) = To_C (Item (J))); - return R; end; @@ -1154,19 +786,10 @@ is else declare - R : char32_array (0 .. Item'Length - 1) - with Relaxed_Initialization; - + R : char32_array (0 .. Item'Length - 1); begin for J in Item'Range loop R (size_t (J - Item'First)) := To_C (Item (J)); - - pragma Loop_Invariant - (for all K in 0 .. size_t (J - Item'First) => - R (K)'Initialized); - pragma Loop_Invariant - (for all K in Item'First .. J => - R (size_t (K - Item'First)) = To_C (Item (K))); end loop; return R; @@ -1188,36 +811,15 @@ is begin if Target'Length < Item'Length + (if Append_Nul then 1 else 0) then raise Constraint_Error; - else To := Target'First; + for From in Item'Range loop Target (To) := To_C (Item (From)); - pragma Loop_Invariant (To in Target'Range); - pragma Loop_Invariant - (To - Target'First = size_t (From - Item'First)); - pragma Loop_Invariant - (for all J in Target'First .. To => Target (J)'Initialized); - pragma Loop_Invariant - (Target (Target'First .. To)'Initialized); - pragma Loop_Invariant - (for all J in Item'First .. From => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - To := To + 1; end loop; - pragma Assert - (for all J in Item'Range => - Target (Target'First + size_t (J - Item'First)) = - To_C (Item (J))); - pragma Assert - (if Item'Length /= 0 then - Target (Target'First .. - Target'First + (Item'Length - 1))'Initialized); - if Append_Nul then Target (To) := char32_nul; Count := Item'Length + 1; @@ -1226,7 +828,5 @@ is end if; end if; end To_C; - pragma Annotate (CodePeer, False_Positive, "validity check", - "Count is only uninitialized on abnormal return."); end Interfaces.C; diff --git a/gcc/ada/libgnat/i-c.ads b/gcc/ada/libgnat/i-c.ads index f9f9f75..fc77caf 100644 --- a/gcc/ada/libgnat/i-c.ads +++ b/gcc/ada/libgnat/i-c.ads @@ -133,6 +133,7 @@ is function C_Length_Ghost (Item : char_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = nul @@ -274,6 +275,7 @@ is function C_Length_Ghost (Item : wchar_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = wide_nul @@ -395,6 +397,7 @@ is function C_Length_Ghost (Item : char16_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = char16_nul @@ -510,6 +513,7 @@ is function C_Length_Ghost (Item : char32_array) return size_t with Ghost, + Import, Pre => Is_Nul_Terminated (Item), Post => C_Length_Ghost'Result <= Item'Last - Item'First and then Item (Item'First + C_Length_Ghost'Result) = char32_nul diff --git a/gcc/ada/libgnat/i-cheri.adb b/gcc/ada/libgnat/i-cheri.adb index 37e5c3d..1575705 100644 --- a/gcc/ada/libgnat/i-cheri.adb +++ b/gcc/ada/libgnat/i-cheri.adb @@ -31,6 +31,30 @@ package body Interfaces.CHERI is + ---------------- + -- Set_Bounds -- + ---------------- + + procedure Set_Bounds + (Cap : in out Capability; + Length : Bounds_Length) + is + begin + Cap := Capability_With_Bounds (Cap, Length); + end Set_Bounds; + + ---------------------- + -- Set_Exact_Bounds -- + ---------------------- + + procedure Set_Exact_Bounds + (Cap : in out Capability; + Length : Bounds_Length) + is + begin + Cap := Capability_With_Exact_Bounds (Cap, Length); + end Set_Exact_Bounds; + ---------------------------- -- Set_Address_And_Bounds -- ---------------------------- diff --git a/gcc/ada/libgnat/i-cheri.ads b/gcc/ada/libgnat/i-cheri.ads index ed26e55..4186b6d 100644 --- a/gcc/ada/libgnat/i-cheri.ads +++ b/gcc/ada/libgnat/i-cheri.ads @@ -273,8 +273,7 @@ is (Cap : in out Capability; Length : Bounds_Length) with - Import, Convention => Intrinsic, - External_Name => "__builtin_cheri_bounds_set"; + Inline; -- Narrow the bounds of a capability so that the lower bound is the -- current address and the upper bound is suitable for the Length. -- @@ -287,8 +286,7 @@ is (Cap : in out Capability; Length : Bounds_Length) with - Import, Convention => Intrinsic, - External_Name => "__builtin_cheri_bounds_set_exact"; + Inline; -- Narrow the bounds of a capability so that the lower bound is the -- current address and the upper bound is suitable for the Length. -- diff --git a/gcc/ada/libgnat/i-cpoint.adb b/gcc/ada/libgnat/i-cpoint.adb index 40a5834..994e639 100644 --- a/gcc/ada/libgnat/i-cpoint.adb +++ b/gcc/ada/libgnat/i-cpoint.adb @@ -148,7 +148,7 @@ package body Interfaces.C.Pointers is S : Pointer := Source; begin - if Source = null or Target = null then + if Source = null or else Target = null then raise Dereference_Error; end if; diff --git a/gcc/ada/libgnat/i-cstrin.adb b/gcc/ada/libgnat/i-cstrin.adb index 7bf881f..8279562 100644 --- a/gcc/ada/libgnat/i-cstrin.adb +++ b/gcc/ada/libgnat/i-cstrin.adb @@ -66,8 +66,11 @@ is pragma Inline ("+"); -- Address arithmetic on chars_ptr value - function Position_Of_Nul (Into : char_array) return size_t; - -- Returns position of the first Nul in Into or Into'Last + 1 if none + procedure Position_Of_Nul + (Into : char_array; Found : out Boolean; Index : out size_t); + -- If into contains a Nul character, Found is set to True and Index + -- contains the position of the first Nul character in Into. Otherwise + -- Found is set to False and the value of Index is not meaningful. -- We can't use directly System.Memory because the categorization is not -- compatible, so we directly import here the malloc and free routines. @@ -107,6 +110,7 @@ is -------------------- function New_Char_Array (Chars : char_array) return chars_ptr is + Found : Boolean; Index : size_t; Pointer : chars_ptr; @@ -114,24 +118,25 @@ is -- Get index of position of null. If Index > Chars'Last, -- nul is absent and must be added explicitly. - Index := Position_Of_Nul (Into => Chars); - Pointer := Memory_Alloc ((Index - Chars'First + 1)); + Position_Of_Nul (Into => Chars, Found => Found, Index => Index); -- If nul is present, transfer string up to and including nul - if Index <= Chars'Last then - Update (Item => Pointer, - Offset => 0, - Chars => Chars (Chars'First .. Index), - Check => False); + if Found then + Pointer := Memory_Alloc (Index - Chars'First + 1); + + Update + (Item => Pointer, + Offset => 0, + Chars => Chars (Chars'First .. Index), + Check => False); else -- If original string has no nul, transfer whole string and add -- terminator explicitly. - Update (Item => Pointer, - Offset => 0, - Chars => Chars, - Check => False); + Pointer := Memory_Alloc (Chars'Length + 1); + + Update (Item => Pointer, Offset => 0, Chars => Chars, Check => False); Poke (nul, Into => Pointer + size_t'(Chars'Length)); end if; @@ -148,20 +153,33 @@ is -- the result, and doesn't copy the string on the stack, otherwise its -- use is limited when used from tasks on large strings. - Result : constant chars_ptr := Memory_Alloc (Str'Length + 1); + Len : Natural := 0; + -- Length of the longest prefix of Str that doesn't contain NUL - Result_Array : char_array (1 .. Str'Length + 1); - for Result_Array'Address use To_Address (Result); - pragma Import (Ada, Result_Array); + Result : chars_ptr; + begin + for C of Str loop + if C = ASCII.NUL then + exit; + end if; + Len := Len + 1; + end loop; - Count : size_t; + Result := Memory_Alloc (size_t (Len) + 1); + + declare + Result_Array : char_array (1 .. size_t (Len) + 1) + with Address => To_Address (Result), Import, Convention => Ada; + + Count : size_t; + begin + To_C + (Item => Str (Str'First .. Str'First + Len - 1), + Target => Result_Array, + Count => Count, + Append_Nul => True); + end; - begin - To_C - (Item => Str, - Target => Result_Array, - Count => Count, - Append_Nul => True); return Result; end New_String; @@ -187,19 +205,19 @@ is -- Position_Of_Nul -- --------------------- - function Position_Of_Nul (Into : char_array) return size_t is + procedure Position_Of_Nul + (Into : char_array; Found : out Boolean; Index : out size_t) is begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "early returns for performance"); + Found := False; + Index := 0; + for J in Into'Range loop if Into (J) = nul then - return J; + Found := True; + Index := J; + return; end if; end loop; - - return Into'Last + 1; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end Position_Of_Nul; ------------ @@ -231,19 +249,22 @@ is (Item : char_array_access; Nul_Check : Boolean := False) return chars_ptr is + Found : Boolean; + Index : size_t; begin pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", "early returns for performance"); if Item = null then return Null_Ptr; - elsif Nul_Check - and then Position_Of_Nul (Into => Item.all) > Item'Last - then - raise Terminator_Error; - else - return To_chars_ptr (Item (Item'First)'Address); + elsif Nul_Check then + Position_Of_Nul (Item.all, Found, Index); + if not Found then + raise Terminator_Error; + end if; end if; + return To_chars_ptr (Item (Item'First)'Address); + pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end To_Chars_Ptr; @@ -260,6 +281,11 @@ is Index : chars_ptr := Item + Offset; begin + -- Check for null pointer as mandated by the RM. + if Item = Null_Ptr then + raise Dereference_Error; + end if; + if Check and then Offset + Chars'Length > Strlen (Item) then raise Update_Error; end if; diff --git a/gcc/ada/libgnat/s-aridou.adb b/gcc/ada/libgnat/s-aridou.adb index e4140e8..dd2f150 100644 --- a/gcc/ada/libgnat/s-aridou.adb +++ b/gcc/ada/libgnat/s-aridou.adb @@ -29,74 +29,20 @@ -- -- ------------------------------------------------------------------------------ -pragma Annotate (Gnatcheck, Exempt_On, "Metrics_LSLOC", - "limit exceeded due to proof code"); - with Ada.Unchecked_Conversion; -with System.SPARK.Cut_Operations; use System.SPARK.Cut_Operations; package body System.Arith_Double with SPARK_Mode is - -- Contracts, ghost code, loop invariants and assertions in this unit are - -- meant for analysis only, not for run-time checking, as it would be too - -- costly otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore); - pragma Suppress (Overflow_Check); pragma Suppress (Range_Check); - pragma Warnings - (Off, "statement has no effect", - Reason => "Ghost code on dead paths is used for verification only"); - function To_Uns is new Ada.Unchecked_Conversion (Double_Int, Double_Uns); function To_Int is new Ada.Unchecked_Conversion (Double_Uns, Double_Int); Double_Size : constant Natural := Double_Int'Size; Single_Size : constant Natural := Double_Int'Size / 2; - -- Log of Single_Size in base 2, so that Single_Size = 2 ** Log_Single_Size - Log_Single_Size : constant Natural := - (case Single_Size is - when 32 => 5, - when 64 => 6, - when 128 => 7, - when others => raise Program_Error) - with Ghost; - - -- Power-of-two constants - - pragma Warnings - (Off, "non-preelaborable call not allowed in preelaborated unit", - Reason => "Ghost code is not compiled"); - pragma Warnings - (Off, "non-static constant in preelaborated unit", - Reason => "Ghost code is not compiled"); - Big_0 : constant Big_Integer := - Big (Double_Uns'(0)) - with Ghost; - Big_2xxSingle : constant Big_Integer := - Big (Double_Int'(2 ** Single_Size)) - with Ghost; - Big_2xxDouble_Minus_1 : constant Big_Integer := - Big (Double_Uns'(2 ** (Double_Size - 1))) - with Ghost; - Big_2xxDouble : constant Big_Integer := - Big (Double_Uns'(2 ** Double_Size - 1)) + 1 - with Ghost; - pragma Warnings - (On, "non-preelaborable call not allowed in preelaborated unit"); - pragma Warnings (On, "non-static constant in preelaborated unit"); - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", "early returns for performance"); @@ -115,9 +61,7 @@ is -- Length doubling multiplication function "/" (A : Double_Uns; B : Single_Uns) return Double_Uns is - (A / Double_Uns (B)) - with - Pre => B /= 0; + (A / Double_Uns (B)); -- Length doubling division function "&" (Hi, Lo : Single_Uns) return Double_Uns is @@ -127,37 +71,15 @@ is function "abs" (X : Double_Int) return Double_Uns is (if X = Double_Int'First then Double_Uns'(2 ** (Double_Size - 1)) - else Double_Uns (Double_Int'(abs X))) - with Post => abs Big (X) = Big ("abs"'Result), - Annotate => (GNATprove, Hide_Info, "Expression_Function_Body"); + else Double_Uns (Double_Int'(abs X))); -- Convert absolute value of X to unsigned. Note that we can't just use -- the expression of the Else since it overflows for X = Double_Int'First. function "rem" (A : Double_Uns; B : Single_Uns) return Double_Uns is - (A rem Double_Uns (B)) - with - Pre => B /= 0; + (A rem Double_Uns (B)); -- Length doubling remainder - function Big_2xx (N : Natural) return Big_Positive is - (Big (Double_Uns'(2 ** N))) - with - Ghost, - Pre => N < Double_Size, - Post => Big_2xx'Result > 0; - -- 2**N as a big integer - - function Big3 (X1, X2, X3 : Single_Uns) return Big_Natural is - (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (X1)) - + Big_2xxSingle * Big (Double_Uns (X2)) - + Big (Double_Uns (X3))) - with - Ghost; - -- X1&X2&X3 as a big integer - - function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean - with - Post => Le3'Result = (Big3 (X1, X2, X3) <= Big3 (Y1, Y2, Y3)); + function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean; -- Determines if (3 * Single_Size)-bit value X1&X2&X3 <= Y1&Y2&Y3 function Lo (A : Double_Uns) return Single_Uns is @@ -168,654 +90,41 @@ is (Single_Uns (Shift_Right (A, Single_Size))); -- High order half of double value - procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns) - with - Pre => Big3 (X1, X2, X3) >= Big3 (Y1, Y2, Y3), - Post => Big3 (X1, X2, X3) = Big3 (X1, X2, X3)'Old - Big3 (Y1, Y2, Y3); + procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns); -- Computes X1&X2&X3 := X1&X2&X3 - Y1&Y1&Y3 mod 2 ** (3 * Single_Size) - function To_Neg_Int (A : Double_Uns) return Double_Int - with - Pre => In_Double_Int_Range (-Big (A)), - Post => Big (To_Neg_Int'Result) = -Big (A); + function To_Neg_Int (A : Double_Uns) return Double_Int; -- Convert to negative integer equivalent. If the input is in the range -- 0 .. 2 ** (Double_Size - 1), then the corresponding nonpositive signed -- integer (obtained by negating the given value) is returned, otherwise -- constraint error is raised. - function To_Pos_Int (A : Double_Uns) return Double_Int - with - Pre => In_Double_Int_Range (Big (A)), - Post => Big (To_Pos_Int'Result) = Big (A); + function To_Pos_Int (A : Double_Uns) return Double_Int; -- Convert to positive integer equivalent. If the input is in the range -- 0 .. 2 ** (Double_Size - 1) - 1, then the corresponding non-negative -- signed integer is returned, otherwise constraint error is raised. - procedure Raise_Error with - Exceptional_Cases => (Constraint_Error => True); - pragma No_Return (Raise_Error); + procedure Raise_Error with No_Return; -- Raise constraint error with appropriate message - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Inline_Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => Le3 (X1, X2, X3, Y1, Y2, Y3), - Post => Big3 (X1, X2, X3) <= Big3 (Y1, Y2, Y3); - - procedure Lemma_Abs_Commutation (X : Double_Int) - with - Ghost, - Post => abs Big (X) = Big (Double_Uns'(abs X)); - - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X / Y) = abs X / abs Y; - - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) - with - Ghost, - Post => abs (X * Y) = abs X * abs Y; - - procedure Lemma_Abs_Range (X : Big_Integer) - with - Ghost, - Pre => In_Double_Int_Range (X), - Post => abs X <= Big_2xxDouble_Minus_1 - and then In_Double_Int_Range (-abs X); - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X rem Y) = (abs X) rem (abs Y); - - procedure Lemma_Add_Commutation (X : Double_Uns; Y : Single_Uns) - with - Ghost, - Pre => X <= 2 ** Double_Size - 2 ** Single_Size, - Post => Big (X) + Big (Double_Uns (Y)) = Big (X + Double_Uns (Y)); - - procedure Lemma_Add_One (X : Double_Uns) - with - Ghost, - Pre => X /= Double_Uns'Last, - Post => Big (X + Double_Uns'(1)) = Big (X) + 1; - - procedure Lemma_Big_Of_Double_Uns (X : Double_Uns) - with - Ghost, - Post => Big (X) < Big_2xxDouble; - - procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns) - with - Ghost, - Post => Big (Double_Uns (X)) >= 0 - and then Big (Double_Uns (X)) < Big_2xxSingle; - - procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural) - with - Ghost, - Pre => M < N and then N < Double_Size, - Post => Double_Uns'(2)**M < Double_Uns'(2)**N; - - procedure Lemma_Concat_Definition (X, Y : Single_Uns) - with - Ghost, - Post => Big (X & Y) = Big_2xxSingle * Big (Double_Uns (X)) - + Big (Double_Uns (Y)); - - procedure Lemma_Deep_Mult_Commutation - (Factor : Big_Integer; - X, Y : Single_Uns) - with - Ghost, - Post => - Factor * Big (Double_Uns (X)) * Big (Double_Uns (Y)) = - Factor * Big (Double_Uns (X) * Double_Uns (Y)); - - procedure Lemma_Div_Commutation (X, Y : Double_Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Definition - (A : Double_Uns; - B : Single_Uns; - Q : Double_Uns; - R : Double_Uns) - with - Ghost, - Pre => B /= 0 and then Q = A / B and then R = A rem B, - Post => Big (A) = Big (Double_Uns (B)) * Big (Q) + Big (R); - - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Z > 0 and then X >= Y * Z, - Post => X / Z >= Y; - - procedure Lemma_Div_Lt (X, Y, Z : Big_Natural) - with - Ghost, - Pre => Z > 0 and then X < Y * Z, - Post => X / Z < Y; - - procedure Lemma_Div_Eq (A, B, S, R : Big_Integer) - with - Ghost, - Pre => A * S = B * S + R and then S /= 0, - Post => A = B + R / S; - - procedure Lemma_Div_Mult (X : Big_Natural; Y : Big_Positive) - with - Ghost, - Post => X / Y * Y > X - Y; - - procedure Lemma_Double_Big_2xxSingle - with - Ghost, - Post => Big_2xxSingle * Big_2xxSingle = Big_2xxDouble; - - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Double_Uns) - with - Ghost, - Pre => S <= Double_Uns (Double_Size) - and then S1 <= Double_Uns (Double_Size), - Post => Shift_Left (Shift_Left (X, Natural (S)), Natural (S1)) = - Shift_Left (X, Natural (S + S1)); - - procedure Lemma_Double_Shift (X : Single_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Single_Size - S1, - Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1); - - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Double_Size - S1, - Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1); - - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Double_Uns) - with - Ghost, - Pre => S <= Double_Uns (Double_Size) - and then S1 <= Double_Uns (Double_Size), - Post => Shift_Left (Shift_Left (X, Natural (S)), Natural (S1)) = - Shift_Left (X, Natural (S + S1)); - - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Double_Size - S1, - Post => Shift_Left (Shift_Left (X, S), S1) = Shift_Left (X, S + S1); - - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Double_Uns) - with - Ghost, - Pre => S <= Double_Uns (Double_Size) - and then S1 <= Double_Uns (Double_Size), - Post => Shift_Right (Shift_Right (X, Natural (S)), Natural (S1)) = - Shift_Right (X, Natural (S + S1)); - - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Natural) - with - Ghost, - Pre => S <= Double_Size - S1, - Post => Shift_Right (Shift_Right (X, S), S1) = Shift_Right (X, S + S1); - - procedure Lemma_Ge_Commutation (A, B : Double_Uns) - with - Ghost, - Pre => A >= B, - Post => Big (A) >= Big (B); - - procedure Lemma_Ge_Mult (A, B, C, D : Big_Integer) - with - Ghost, - Pre => A >= B and then B * C >= D and then C > 0, - Post => A * C >= D; - - procedure Lemma_Gt_Commutation (A, B : Double_Uns) - with - Ghost, - Pre => A > B, - Post => Big (A) > Big (B); - - procedure Lemma_Gt_Mult (A, B, C, D : Big_Integer) - with - Ghost, - Pre => A >= B and then B * C > D and then C > 0, - Post => A * C > D; - - procedure Lemma_Hi_Lo (Xu : Double_Uns; Xhi, Xlo : Single_Uns) - with - Ghost, - Pre => Xhi = Hi (Xu) and Xlo = Lo (Xu), - Post => Big (Xu) = - Big_2xxSingle * Big (Double_Uns (Xhi)) + Big (Double_Uns (Xlo)); - - procedure Lemma_Hi_Lo_3 (Xu : Double_Uns; Xhi, Xlo : Single_Uns) - with - Ghost, - Pre => Xhi = Hi (Xu) and then Xlo = Lo (Xu), - Post => Big (Xu) = Big3 (0, Xhi, Xlo); - - procedure Lemma_Lo_Is_Ident (X : Double_Uns) - with - Ghost, - Pre => Big (X) < Big_2xxSingle, - Post => Double_Uns (Lo (X)) = X; - - procedure Lemma_Lt_Commutation (A, B : Double_Uns) - with - Ghost, - Pre => A < B, - Post => Big (A) < Big (B); - - procedure Lemma_Lt_Mult (A, B, C, D : Big_Integer) - with - Ghost, - Pre => A < B and then B * C <= D and then C > 0, - Post => A * C < D; - - procedure Lemma_Mult_Commutation (X, Y : Single_Uns) - with - Ghost, - Post => - Big (Double_Uns (X)) * Big (Double_Uns (Y)) = - Big (Double_Uns (X) * Double_Uns (Y)); - - procedure Lemma_Mult_Commutation (X, Y : Double_Int) - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)), - Post => Big (X) * Big (Y) = Big (X * Y); - - procedure Lemma_Mult_Commutation (X, Y, Z : Double_Uns) - with - Ghost, - Pre => Big (X) * Big (Y) < Big_2xxDouble and then Z = X * Y, - Post => Big (X) * Big (Y) = Big (Z); - - procedure Lemma_Mult_Decomposition - (Mult : Big_Integer; - Xu, Yu : Double_Uns; - Xhi, Xlo, Yhi, Ylo : Single_Uns) - with - Ghost, - Pre => Mult = Big (Xu) * Big (Yu) - and then Xhi = Hi (Xu) - and then Xlo = Lo (Xu) - and then Yhi = Hi (Yu) - and then Ylo = Lo (Yu), - Post => Mult = - Big_2xxSingle * Big_2xxSingle * (Big (Double_Uns'(Xhi * Yhi))) - + Big_2xxSingle * (Big (Double_Uns'(Xhi * Ylo))) - + Big_2xxSingle * (Big (Double_Uns'(Xlo * Yhi))) - + (Big (Double_Uns'(Xlo * Ylo))); - - procedure Lemma_Mult_Distribution (X, Y, Z : Big_Integer) - with - Ghost, - Post => X * (Y + Z) = X * Y + X * Z; - - procedure Lemma_Mult_Div (A, B : Big_Integer) - with - Ghost, - Pre => B /= 0, - Post => A * B / B = A; - - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) - with - Ghost, - Pre => (X >= 0 and then Y >= 0) - or else (X <= 0 and then Y <= 0), - Post => X * Y >= 0; - - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) - with - Ghost, - Pre => (X <= Big_0 and then Y >= Big_0) - or else (X >= Big_0 and then Y <= Big_0), - Post => X * Y <= Big_0; - - procedure Lemma_Mult_Positive (X, Y : Big_Integer) - with - Ghost, - Pre => (X > Big_0 and then Y > Big_0) - or else (X < Big_0 and then Y < Big_0), - Post => X * Y > Big_0; - - procedure Lemma_Neg_Div (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X / Y = (-X) / (-Y); - - procedure Lemma_Neg_Rem (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X rem Y = X rem (-Y); - - procedure Lemma_Not_In_Range_Big2xx64 - with - Post => not In_Double_Int_Range (Big_2xxDouble) - and then not In_Double_Int_Range (-Big_2xxDouble); - - procedure Lemma_Powers (A : Big_Natural; B, C : Natural) - with - Ghost, - Pre => B <= Natural'Last - C, - Post => A**B * A**C = A**(B + C); - - procedure Lemma_Powers_Of_2 (M, N : Natural) - with - Ghost, - Pre => M < Double_Size - and then N < Double_Size - and then M + N <= Double_Size, - Post => - Big_2xx (M) * Big_2xx (N) = - (if M + N = Double_Size then Big_2xxDouble else Big_2xx (M + N)); - - procedure Lemma_Powers_Of_2_Commutation (M : Natural) - with - Ghost, - Subprogram_Variant => (Decreases => M), - Pre => M <= Double_Size, - Post => Big (Double_Uns'(2))**M = - (if M < Double_Size then Big_2xx (M) else Big_2xxDouble); - - procedure Lemma_Powers_Of_2_Increasing (M, N : Natural) - with - Ghost, - Subprogram_Variant => (Increases => M), - Pre => M < N, - Post => Big (Double_Uns'(2))**M < Big (Double_Uns'(2))**N; - - procedure Lemma_Rem_Abs (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X rem Y = X rem (abs Y); - pragma Unreferenced (Lemma_Rem_Abs); - - procedure Lemma_Rem_Commutation (X, Y : Double_Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) rem Big (Y) = Big (X rem Y); - - procedure Lemma_Rem_Is_Ident (X, Y : Big_Integer) - with - Ghost, - Pre => abs X < abs Y, - Post => X rem Y = X; - pragma Unreferenced (Lemma_Rem_Is_Ident); - - procedure Lemma_Rem_Sign (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => Same_Sign (X rem Y, X); - pragma Unreferenced (Lemma_Rem_Sign); - - procedure Lemma_Rev_Div_Definition (A, B, Q, R : Big_Natural) - with - Ghost, - Pre => A = B * Q + R and then R < B, - Post => Q = A / B and then R = A rem B; - - procedure Lemma_Shift_Left (X : Double_Uns; Shift : Natural) - with - Ghost, - Pre => Shift < Double_Size - and then Big (X) * Big_2xx (Shift) < Big_2xxDouble, - Post => Big (Shift_Left (X, Shift)) = Big (X) * Big_2xx (Shift); - - procedure Lemma_Shift_Right (X : Double_Uns; Shift : Natural) - with - Ghost, - Pre => Shift < Double_Size, - Post => Big (Shift_Right (X, Shift)) = Big (X) / Big_2xx (Shift); - - procedure Lemma_Shift_Without_Drop - (X, Y : Double_Uns; - Mask : Single_Uns; - Shift : Natural) - with - Ghost, - Pre => (Hi (X) and Mask) = 0 -- X has the first Shift bits off - and then Shift <= Single_Size - and then Mask = Shift_Left (Single_Uns'Last, Single_Size - Shift) - and then Y = Shift_Left (X, Shift), - Post => Big (Y) = Big_2xx (Shift) * Big (X); - - procedure Lemma_Simplify (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X * Y / Y = X; - - procedure Lemma_Substitution (A, B, C, C1, D : Big_Integer) - with - Ghost, - Pre => C = C1 and then A = B * C + D, - Post => A = B * C1 + D; - - procedure Lemma_Subtract_Commutation (X, Y : Double_Uns) - with - Ghost, - Pre => X >= Y, - Post => Big (X) - Big (Y) = Big (X - Y); - - procedure Lemma_Subtract_Double_Uns (X, Y : Double_Int) - with - Ghost, - Pre => X >= 0 and then X <= Y, - Post => Double_Uns (Y - X) = Double_Uns (Y) - Double_Uns (X); - - procedure Lemma_Word_Commutation (X : Single_Uns) - with - Ghost, - Post => Big_2xxSingle * Big (Double_Uns (X)) - = Big (2**Single_Size * Double_Uns (X)); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Inline_Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is null; - procedure Lemma_Abs_Commutation (X : Double_Int) is null; - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) is null; - procedure Lemma_Abs_Range (X : Big_Integer) is null; - procedure Lemma_Add_Commutation (X : Double_Uns; Y : Single_Uns) is null; - procedure Lemma_Add_One (X : Double_Uns) is null; - procedure Lemma_Big_Of_Double_Uns (X : Double_Uns) is null; - procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns) is null; - procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural) is null; - procedure Lemma_Deep_Mult_Commutation - (Factor : Big_Integer; - X, Y : Single_Uns) - is null; - procedure Lemma_Div_Commutation (X, Y : Double_Uns) is null; - procedure Lemma_Div_Definition - (A : Double_Uns; - B : Single_Uns; - Q : Double_Uns; - R : Double_Uns) - is null; - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) is null; - procedure Lemma_Div_Lt (X, Y, Z : Big_Natural) is null; - procedure Lemma_Div_Mult (X : Big_Natural; Y : Big_Positive) is null; - procedure Lemma_Double_Big_2xxSingle is null; - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Double_Uns) is null; - procedure Lemma_Double_Shift (X : Single_Uns; S, S1 : Natural) is null; - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Double_Uns) - is null; - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Double_Uns) - is null; - procedure Lemma_Ge_Commutation (A, B : Double_Uns) is null; - procedure Lemma_Ge_Mult (A, B, C, D : Big_Integer) is null; - procedure Lemma_Gt_Commutation (A, B : Double_Uns) is null; - procedure Lemma_Gt_Mult (A, B, C, D : Big_Integer) is null; - procedure Lemma_Lo_Is_Ident (X : Double_Uns) is null; - procedure Lemma_Lt_Commutation (A, B : Double_Uns) is null; - procedure Lemma_Lt_Mult (A, B, C, D : Big_Integer) is null; - procedure Lemma_Mult_Commutation (X, Y : Single_Uns) is null; - procedure Lemma_Mult_Commutation (X, Y : Double_Int) is null; - procedure Lemma_Mult_Commutation (X, Y, Z : Double_Uns) is null; - procedure Lemma_Mult_Distribution (X, Y, Z : Big_Integer) is null; - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) is null; - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) is null; - procedure Lemma_Mult_Positive (X, Y : Big_Integer) is null; - procedure Lemma_Neg_Rem (X, Y : Big_Integer) is null; - procedure Lemma_Not_In_Range_Big2xx64 is null; - procedure Lemma_Powers (A : Big_Natural; B, C : Natural) is null; - procedure Lemma_Rem_Commutation (X, Y : Double_Uns) is null; - procedure Lemma_Rem_Is_Ident (X, Y : Big_Integer) is null; - procedure Lemma_Rem_Sign (X, Y : Big_Integer) is null; - procedure Lemma_Rev_Div_Definition (A, B, Q, R : Big_Natural) is null; - procedure Lemma_Simplify (X, Y : Big_Integer) is null; - procedure Lemma_Substitution (A, B, C, C1, D : Big_Integer) is null; - procedure Lemma_Subtract_Commutation (X, Y : Double_Uns) is null; - procedure Lemma_Subtract_Double_Uns (X, Y : Double_Int) is null; - procedure Lemma_Word_Commutation (X : Single_Uns) is null; - -------------------------- -- Add_With_Ovflo_Check -- -------------------------- function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is R : constant Double_Int := To_Int (To_Uns (X) + To_Uns (Y)); - - -- Local lemmas - - procedure Prove_Negative_X - with - Ghost, - Pre => X < 0 and then (Y > 0 or else R < 0), - Post => R = X + Y; - - procedure Prove_Non_Negative_X - with - Ghost, - Pre => X >= 0 and then (Y < 0 or else R >= 0), - Post => R = X + Y; - - procedure Prove_Overflow_Case - with - Ghost, - Pre => - (if X >= 0 then Y >= 0 and then R < 0 - else Y <= 0 and then R >= 0), - Post => not In_Double_Int_Range (Big (X) + Big (Y)); - - ---------------------- - -- Prove_Negative_X -- - ---------------------- - - procedure Prove_Negative_X is - begin - if X = Double_Int'First then - if Y > 0 then - null; - else - pragma Assert - (To_Uns (X) + To_Uns (Y) = - 2 ** (Double_Size - 1) - Double_Uns (-Y)); - pragma Assert -- as R < 0 - (To_Uns (X) + To_Uns (Y) >= 2 ** (Double_Size - 1)); - pragma Assert (Y = 0); - end if; - - elsif Y = Double_Int'First then - pragma Assert - (To_Uns (X) + To_Uns (Y) = - 2 ** (Double_Size - 1) - Double_Uns (-X)); - pragma Assert (False); - - elsif Y <= 0 then - pragma Assert - (To_Uns (X) + To_Uns (Y) = -Double_Uns (-X) - Double_Uns (-Y)); - - else -- Y > 0, 0 > X > Double_Int'First - declare - Ru : constant Double_Uns := To_Uns (X) + To_Uns (Y); - begin - pragma Assert (Ru = -Double_Uns (-X) + Double_Uns (Y)); - if Ru < 2 ** (Double_Size - 1) then -- R >= 0 - Lemma_Subtract_Double_Uns (-X, Y); - pragma Assert (Ru = Double_Uns (X + Y)); - - elsif Ru = 2 ** (Double_Size - 1) then - pragma Assert (Double_Uns (Y) < 2 ** (Double_Size - 1)); - pragma Assert (Double_Uns (-X) < 2 ** (Double_Size - 1)); - pragma Assert (False); - - else - pragma Assert - (R = -Double_Int (-(-Double_Uns (-X) + Double_Uns (Y)))); - pragma Assert - (R = -Double_Int (-Double_Uns (Y) + Double_Uns (-X))); - end if; - end; - end if; - end Prove_Negative_X; - - -------------------------- - -- Prove_Non_Negative_X -- - -------------------------- - - procedure Prove_Non_Negative_X is - begin - if Y >= 0 or else Y = Double_Int'First then - null; - else - pragma Assert - (To_Uns (X) + To_Uns (Y) = Double_Uns (X) - Double_Uns (-Y)); - end if; - end Prove_Non_Negative_X; - - ------------------------- - -- Prove_Overflow_Case -- - ------------------------- - - procedure Prove_Overflow_Case is - begin - if X < 0 and then X /= Double_Int'First and then Y /= Double_Int'First - then - pragma Assert - (To_Uns (X) + To_Uns (Y) = -Double_Uns (-X) - Double_Uns (-Y)); - end if; - end Prove_Overflow_Case; - - -- Start of processing for Add_With_Ovflo_Check - begin if X >= 0 then if Y < 0 or else R >= 0 then - Prove_Non_Negative_X; return R; end if; else -- X < 0 if Y > 0 or else R < 0 then - Prove_Negative_X; return R; end if; end if; - Prove_Overflow_Case; Raise_Error; end Add_With_Ovflo_Check; @@ -823,8 +132,6 @@ is -- Double_Divide -- ------------------- - pragma Annotate (Gnatcheck, Exempt_On, "Metrics_Cyclomatic_Complexity", - "limit exceeded due to proof code"); procedure Double_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; @@ -844,183 +151,11 @@ is Du, Qu, Ru : Double_Uns; Den_Pos : constant Boolean := (Y < 0) = (Z < 0); - -- Local ghost variables - - Mult : constant Big_Integer := abs (Big (Y) * Big (Z)) with Ghost; - Quot : Big_Integer with Ghost; - Big_R : Big_Integer with Ghost; - Big_Q : Big_Integer with Ghost; - - -- Local lemmas - - procedure Prove_Overflow_Case - with - Ghost, - Pre => X = Double_Int'First and then Big (Y) * Big (Z) = -1, - Post => not In_Double_Int_Range (Big (X) / (Big (Y) * Big (Z))) - and then not In_Double_Int_Range - (Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z)))); - -- Proves the special case where -2**(Double_Size - 1) is divided by -1, - -- generating an overflow. - - procedure Prove_Quotient_Zero - with - Ghost, - Pre => Mult >= Big_2xxDouble - and then - not (Mult = Big_2xxDouble - and then X = Double_Int'First - and then Round) - and then Q = 0 - and then R = X, - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (R)) - else Big (Q) = Big (X) / (Big (Y) * Big (Z))); - -- Proves the general case where divisor doesn't fit in Double_Uns and - -- quotient is 0. - - procedure Prove_Round_To_One - with - Ghost, - Pre => Mult = Big_2xxDouble - and then X = Double_Int'First - and then Q = (if Den_Pos then -1 else 1) - and then R = X - and then Round, - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (R)); - -- Proves the special case where the divisor doesn't fit in Double_Uns - -- but quotient is still 1 or -1 due to rounding - -- (abs (Y*Z) = 2**Double_Size and X = -2**(Double_Size - 1) and Round). - - procedure Prove_Rounding_Case - with - Ghost, - Pre => Mult /= 0 - and then Quot = Big (X) / (Big (Y) * Big (Z)) - and then Big_R = Big (X) rem (Big (Y) * Big (Z)) - and then Big_Q = - Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R) - and then Big (Ru) = abs Big_R - and then Big (Du) = Mult - and then Big (Qu) = - (if Ru > (Du - Double_Uns'(1)) / Double_Uns'(2) - then abs Quot + 1 - else abs Quot), - Post => abs Big_Q = Big (Qu); - -- Proves correctness of the rounding of the unsigned quotient - - procedure Prove_Sign_Quotient - with - Ghost, - Pre => Mult /= 0 - and then Quot = Big (X) / (Big (Y) * Big (Z)) - and then Big_R = Big (X) rem (Big (Y) * Big (Z)) - and then Big_Q = - (if Round then - Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R) - else Quot), - Post => - (if X >= 0 then - (if Den_Pos then Big_Q >= 0 else Big_Q <= 0) - else - (if Den_Pos then Big_Q <= 0 else Big_Q >= 0)); - -- Proves the correct sign of the signed quotient Big_Q - - procedure Prove_Signs - with - Ghost, - Pre => Mult /= 0 - and then Quot = Big (X) / (Big (Y) * Big (Z)) - and then Big_R = Big (X) rem (Big (Y) * Big (Z)) - and then Big_Q = - (if Round then - Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R) - else Quot) - and then Big (Ru) = abs Big_R - and then Big (Qu) = abs Big_Q - and then R = (if X >= 0 then To_Int (Ru) else To_Int (-Ru)) - and then - Q = (if (X >= 0) = Den_Pos then To_Int (Qu) else To_Int (-Qu)) - and then not (X = Double_Int'First and then Big (Y) * Big (Z) = -1), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (R)) - else Big (Q) = Big (X) / (Big (Y) * Big (Z))); - -- Proves final signs match the intended result after the unsigned - -- division is done. - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Overflow_Case is null; - procedure Prove_Quotient_Zero is null; - procedure Prove_Round_To_One is null; - procedure Prove_Sign_Quotient is null; - - ------------------------- - -- Prove_Rounding_Case -- - ------------------------- - - procedure Prove_Rounding_Case is - begin - if Same_Sign (Big (X), Big (Y) * Big (Z)) then - pragma Assert (abs Big_Q = Big (Qu)); - end if; - end Prove_Rounding_Case; - - ----------------- - -- Prove_Signs -- - ----------------- - - procedure Prove_Signs is - begin - if (X >= 0) = Den_Pos then - pragma Assert (Quot >= 0); - pragma Assert (Big_Q >= 0); - pragma Assert (Q >= 0); - pragma Assert (Big (Q) = Big_Q); - else - pragma Assert ((X >= 0) /= (Big (Y) * Big (Z) >= 0)); - pragma Assert (Quot <= 0); - pragma Assert (Big_Q <= 0); - pragma Assert (if X >= 0 then R >= 0); - pragma Assert (if X < 0 then R <= 0); - pragma Assert (Big (R) = Big_R); - end if; - end Prove_Signs; - - -- Start of processing for Double_Divide - begin if Yu = 0 or else Zu = 0 then Raise_Error; end if; - pragma Assert (Mult /= 0); - pragma Assert (Den_Pos = (Big (Y) * Big (Z) > 0)); - Quot := Big (X) / (Big (Y) * Big (Z)); - Big_R := Big (X) rem (Big (Y) * Big (Z)); - if Round then - Big_Q := Round_Quotient (Big (X), Big (Y) * Big (Z), Quot, Big_R); - else - Big_Q := Quot; - end if; - Lemma_Abs_Mult_Commutation (Big (Y), Big (Z)); - Lemma_Mult_Decomposition (Mult, Yu, Zu, Yhi, Ylo, Zhi, Zlo); - -- Compute Y * Z. Note that if the result overflows Double_Uns, then -- the rounded result is zero, except for the very special case where -- X = -2 ** (Double_Size - 1) and abs (Y * Z) = 2 ** Double_Size, when @@ -1040,66 +175,21 @@ is and then Round then Q := (if Den_Pos then -1 else 1); - - Prove_Round_To_One; - else Q := 0; - - pragma Assert (Double_Uns'(Yhi * Zhi) >= Double_Uns (Yhi)); - pragma Assert (Double_Uns'(Yhi * Zhi) >= Double_Uns (Zhi)); - pragma Assert (Big (Double_Uns'(Yhi * Zhi)) >= 1); - if Yhi > 1 or else Zhi > 1 then - pragma Assert (Big (Double_Uns'(Yhi * Zhi)) > 1); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Zlo > 0 then - pragma Assert (Big (Double_Uns'(Yhi * Zlo)) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Ylo > 0 then - pragma Assert (Double_Uns'(Ylo * Zhi) > 0); - pragma Assert (Big (Double_Uns'(Ylo * Zhi)) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - else - pragma Assert (not (X = Double_Int'First and then Round)); - end if; - Prove_Quotient_Zero; end if; return; else T2 := Yhi * Zlo; - pragma Assert (Big (T2) = Big (Double_Uns'(Yhi * Zlo))); - pragma Assert (Big_0 = Big (Double_Uns'(Ylo * Zhi))); end if; - else T2 := Ylo * Zhi; - pragma Assert (Big (T2) = Big (Double_Uns'(Ylo * Zhi))); - pragma Assert (Big_0 = Big (Double_Uns'(Yhi * Zlo))); end if; T1 := Ylo * Zlo; - - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns'(Yhi * Zlo)), - Big (Double_Uns'(Ylo * Zhi))); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (T2), - Big (Double_Uns (Hi (T1)))); - Lemma_Add_Commutation (T2, Hi (T1)); - T2 := T2 + Hi (T1); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns (Hi (T2))), - Big (Double_Uns (Lo (T2)))); - Lemma_Double_Big_2xxSingle; - if Hi (T2) /= 0 then R := X; @@ -1112,41 +202,8 @@ is and then Round then Q := (if Den_Pos then -1 else 1); - - Prove_Round_To_One; - else Q := 0; - - pragma Assert (Big (Double_Uns (Hi (T2))) >= 1); - pragma Assert (Big (Double_Uns (Lo (T2))) >= 0); - pragma Assert (Big (Double_Uns (Lo (T1))) >= 0); - pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1))) >= 0); - pragma Assert (Mult >= Big_2xxDouble * Big (Double_Uns (Hi (T2)))); - pragma Assert (Mult >= Big_2xxDouble); - if Hi (T2) > 1 then - pragma Assert (Big (Double_Uns (Hi (T2))) > 1); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Lo (T2) > 0 then - pragma Assert (Big (Double_Uns (Lo (T2))) > 0); - pragma Assert (Big_2xxSingle > 0); - pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) > 0); - pragma Assert (Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1))) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - elsif Lo (T1) > 0 then - pragma Assert (Double_Uns (Lo (T1)) > 0); - Lemma_Gt_Commutation (Double_Uns (Lo (T1)), 0); - pragma Assert (Big (Double_Uns (Lo (T1))) > 0); - pragma Assert (if X = Double_Int'First and then Round then - Mult > Big_2xxDouble); - else - pragma Assert (not (X = Double_Int'First and then Round)); - end if; - Prove_Quotient_Zero; end if; return; @@ -1154,22 +211,9 @@ is Du := Lo (T2) & Lo (T1); - Lemma_Hi_Lo (Du, Lo (T2), Lo (T1)); - pragma Assert (Mult = Big (Du)); - pragma Assert (Du /= 0); - -- Multiplication of 2-limb arguments Yu and Zu leads to 4-limb result - -- (where each limb is a single value). Cases where 4 limbs are needed - -- require Yhi /= 0 and Zhi /= 0 and lead to early exit. Remaining cases - -- where 3 limbs are needed correspond to Hi(T2) /= 0 and lead to early - -- exit. Thus, at this point, the result fits in 2 limbs which are - -- exactly Lo (T2) and Lo (T1), which corresponds to the value of Du. - -- As the case where one of Yu or Zu is null also led to early exit, - -- we have Du /= 0 here. - -- Check overflow case of largest negative number divided by -1 if X = Double_Int'First and then Du = 1 and then not Den_Pos then - Prove_Overflow_Case; Raise_Error; end if; @@ -1188,29 +232,14 @@ is Qu := Xu / Du; Ru := Xu rem Du; - Lemma_Div_Commutation (Xu, Du); - Lemma_Abs_Div_Commutation (Big (X), Big (Y) * Big (Z)); - Lemma_Abs_Commutation (X); - pragma Assert (abs Quot = Big (Qu)); - Lemma_Rem_Commutation (Xu, Du); - Lemma_Abs_Rem_Commutation (Big (X), Big (Y) * Big (Z)); - pragma Assert (abs Big_R = Big (Ru)); - -- Deal with rounding case if Round then if Ru > (Du - Double_Uns'(1)) / Double_Uns'(2) then - Lemma_Add_Commutation (Qu, 1); - Qu := Qu + Double_Uns'(1); end if; - - Prove_Rounding_Case; end if; - pragma Assert (abs Big_Q = Big (Qu)); - Prove_Sign_Quotient; - -- Set final signs (RM 4.5.5(27-30)) -- Case of dividend (X) sign positive @@ -1229,10 +258,7 @@ is R := To_Int (-Ru); Q := (if Den_Pos then To_Int (-Qu) else To_Int (Qu)); end if; - - Prove_Signs; end Double_Divide; - pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_Cyclomatic_Complexity"); --------- -- Le3 -- @@ -1254,418 +280,6 @@ is end Le3; ------------------------------- - -- Lemma_Abs_Div_Commutation -- - ------------------------------- - - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) is - begin - if Y < 0 then - if X < 0 then - pragma Assert (abs (X / Y) = abs (X / (-Y))); - else - Lemma_Neg_Div (X, Y); - pragma Assert (abs (X / Y) = abs ((-X) / (-Y))); - end if; - end if; - end Lemma_Abs_Div_Commutation; - - ------------------------------- - -- Lemma_Abs_Rem_Commutation -- - ------------------------------- - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) is - begin - if Y < 0 then - Lemma_Neg_Rem (X, Y); - if X < 0 then - pragma Assert (X rem Y = -((-X) rem (-Y))); - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - else - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - end if; - end if; - end Lemma_Abs_Rem_Commutation; - - ----------------------------- - -- Lemma_Concat_Definition -- - ----------------------------- - - procedure Lemma_Concat_Definition (X, Y : Single_Uns) is - Hi : constant Double_Uns := Shift_Left (Double_Uns (X), Single_Size); - Lo : constant Double_Uns := Double_Uns (Y); - begin - pragma Assert (Hi = Double_Uns'(2 ** Single_Size) * Double_Uns (X)); - pragma Assert ((Hi or Lo) = Hi + Lo); - end Lemma_Concat_Definition; - - ------------------ - -- Lemma_Div_Eq -- - ------------------ - - procedure Lemma_Div_Eq (A, B, S, R : Big_Integer) is - begin - pragma Assert ((A - B) * S = R); - pragma Assert ((A - B) * S / S = R / S); - Lemma_Mult_Div (A - B, S); - pragma Assert (A - B = R / S); - end Lemma_Div_Eq; - - ------------------------ - -- Lemma_Double_Shift -- - ------------------------ - - procedure Lemma_Double_Shift (X : Double_Uns; S, S1 : Natural) is - begin - Lemma_Double_Shift (X, Double_Uns (S), Double_Uns (S1)); - pragma Assert (Shift_Left (Shift_Left (X, S), S1) - = Shift_Left (Shift_Left (X, S), Natural (Double_Uns (S1)))); - pragma Assert (Shift_Left (X, S + S1) - = Shift_Left (X, Natural (Double_Uns (S + S1)))); - end Lemma_Double_Shift; - - ----------------------------- - -- Lemma_Double_Shift_Left -- - ----------------------------- - - procedure Lemma_Double_Shift_Left (X : Double_Uns; S, S1 : Natural) is - begin - Lemma_Double_Shift_Left (X, Double_Uns (S), Double_Uns (S1)); - pragma Assert (Shift_Left (Shift_Left (X, S), S1) - = Shift_Left (Shift_Left (X, S), Natural (Double_Uns (S1)))); - pragma Assert (Shift_Left (X, S + S1) - = Shift_Left (X, Natural (Double_Uns (S + S1)))); - end Lemma_Double_Shift_Left; - - ------------------------------ - -- Lemma_Double_Shift_Right -- - ------------------------------ - - procedure Lemma_Double_Shift_Right (X : Double_Uns; S, S1 : Natural) is - begin - Lemma_Double_Shift_Right (X, Double_Uns (S), Double_Uns (S1)); - pragma Assert (Shift_Right (Shift_Right (X, S), S1) - = Shift_Right (Shift_Right (X, S), Natural (Double_Uns (S1)))); - pragma Assert (Shift_Right (X, S + S1) - = Shift_Right (X, Natural (Double_Uns (S + S1)))); - end Lemma_Double_Shift_Right; - - ----------------- - -- Lemma_Hi_Lo -- - ----------------- - - procedure Lemma_Hi_Lo (Xu : Double_Uns; Xhi, Xlo : Single_Uns) is - begin - pragma Assert (Double_Uns (Xhi) = Xu / Double_Uns'(2 ** Single_Size)); - pragma Assert (Double_Uns (Xlo) = Xu mod 2 ** Single_Size); - end Lemma_Hi_Lo; - - ------------------- - -- Lemma_Hi_Lo_3 -- - ------------------- - - procedure Lemma_Hi_Lo_3 (Xu : Double_Uns; Xhi, Xlo : Single_Uns) is - begin - Lemma_Hi_Lo (Xu, Xhi, Xlo); - end Lemma_Hi_Lo_3; - - ------------------------------ - -- Lemma_Mult_Decomposition -- - ------------------------------ - - procedure Lemma_Mult_Decomposition - (Mult : Big_Integer; - Xu, Yu : Double_Uns; - Xhi, Xlo, Yhi, Ylo : Single_Uns) - is - begin - Lemma_Hi_Lo (Xu, Xhi, Xlo); - Lemma_Hi_Lo (Yu, Yhi, Ylo); - - pragma Assert - (Mult = - (Big_2xxSingle * Big (Double_Uns (Xhi)) + Big (Double_Uns (Xlo))) * - (Big_2xxSingle * Big (Double_Uns (Yhi)) + Big (Double_Uns (Ylo)))); - pragma Assert (Mult = - Big_2xxSingle - * Big_2xxSingle * Big (Double_Uns (Xhi)) * Big (Double_Uns (Yhi)) - + Big_2xxSingle * Big (Double_Uns (Xhi)) * Big (Double_Uns (Ylo)) - + Big_2xxSingle * Big (Double_Uns (Xlo)) * Big (Double_Uns (Yhi)) - + Big (Double_Uns (Xlo)) * Big (Double_Uns (Ylo))); - Lemma_Deep_Mult_Commutation (Big_2xxSingle * Big_2xxSingle, Xhi, Yhi); - Lemma_Deep_Mult_Commutation (Big_2xxSingle, Xhi, Ylo); - Lemma_Deep_Mult_Commutation (Big_2xxSingle, Xlo, Yhi); - Lemma_Mult_Commutation (Xlo, Ylo); - pragma Assert (Mult = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns'(Xhi * Yhi)) - + Big_2xxSingle * Big (Double_Uns'(Xhi * Ylo)) - + Big_2xxSingle * Big (Double_Uns'(Xlo * Yhi)) - + Big (Double_Uns'(Xlo * Ylo))); - end Lemma_Mult_Decomposition; - - -------------------- - -- Lemma_Mult_Div -- - -------------------- - - procedure Lemma_Mult_Div (A, B : Big_Integer) is - begin - if B > 0 then - pragma Assert (A * B / B = A); - else - pragma Assert (A * (-B) / (-B) = A); - end if; - end Lemma_Mult_Div; - - ------------------- - -- Lemma_Neg_Div -- - ------------------- - - procedure Lemma_Neg_Div (X, Y : Big_Integer) is - begin - pragma Assert ((-X) / (-Y) = -(X / (-Y))); - pragma Assert (X / (-Y) = -(X / Y)); - end Lemma_Neg_Div; - - ----------------------- - -- Lemma_Powers_Of_2 -- - ----------------------- - - procedure Lemma_Powers_Of_2 (M, N : Natural) is - begin - if M + N < Double_Size then - pragma Assert (Double_Uns'(2**M) * Double_Uns'(2**N) - = Double_Uns'(2**(M + N))); - end if; - - Lemma_Powers_Of_2_Commutation (M); - Lemma_Powers_Of_2_Commutation (N); - Lemma_Powers_Of_2_Commutation (M + N); - Lemma_Powers (Big (Double_Uns'(2)), M, N); - - if M + N < Double_Size then - pragma Assert (Big (Double_Uns'(2))**M * Big (Double_Uns'(2))**N - = Big (Double_Uns'(2))**(M + N)); - Lemma_Powers_Of_2_Increasing (M + N, Double_Size); - Lemma_Mult_Commutation (2 ** M, 2 ** N, 2 ** (M + N)); - else - pragma Assert (Big (Double_Uns'(2))**M * Big (Double_Uns'(2))**N - = Big (Double_Uns'(2))**(M + N)); - end if; - end Lemma_Powers_Of_2; - - ----------------------------------- - -- Lemma_Powers_Of_2_Commutation -- - ----------------------------------- - - procedure Lemma_Powers_Of_2_Commutation (M : Natural) is - begin - if M > 0 then - Lemma_Powers_Of_2_Commutation (M - 1); - pragma Assert (Big (Double_Uns'(2))**(M - 1) = Big_2xx (M - 1)); - pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M - 1) * 2); - if M < Double_Size then - Lemma_Powers_Of_2_Increasing (M - 1, Double_Size - 1); - Lemma_Bounded_Powers_Of_2_Increasing (M - 1, Double_Size - 1); - pragma Assert (Double_Uns'(2 ** (M - 1)) * 2 = Double_Uns'(2**M)); - Lemma_Mult_Commutation - (Double_Uns'(2 ** (M - 1)), 2, Double_Uns'(2**M)); - pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M)); - end if; - else - pragma Assert (Big (Double_Uns'(2))**M = Big_2xx (M)); - end if; - end Lemma_Powers_Of_2_Commutation; - - ---------------------------------- - -- Lemma_Powers_Of_2_Increasing -- - ---------------------------------- - - procedure Lemma_Powers_Of_2_Increasing (M, N : Natural) is - begin - if M + 1 < N then - Lemma_Powers_Of_2_Increasing (M + 1, N); - end if; - end Lemma_Powers_Of_2_Increasing; - - ------------------- - -- Lemma_Rem_Abs -- - ------------------- - - procedure Lemma_Rem_Abs (X, Y : Big_Integer) is - begin - Lemma_Neg_Rem (X, Y); - end Lemma_Rem_Abs; - - ---------------------- - -- Lemma_Shift_Left -- - ---------------------- - - procedure Lemma_Shift_Left (X : Double_Uns; Shift : Natural) is - - procedure Lemma_Mult_Pow2 (X : Double_Uns; I : Natural) - with - Ghost, - Pre => I < Double_Size - 1, - Post => X * Double_Uns'(2) ** I * Double_Uns'(2) - = X * Double_Uns'(2) ** (I + 1); - - procedure Lemma_Mult_Pow2 (X : Double_Uns; I : Natural) is - Mul1 : constant Double_Uns := Double_Uns'(2) ** I; - Mul2 : constant Double_Uns := Double_Uns'(2); - Left : constant Double_Uns := X * Mul1 * Mul2; - begin - pragma Assert (Left = X * (Mul1 * Mul2)); - pragma Assert (Mul1 * Mul2 = Double_Uns'(2) ** (I + 1)); - end Lemma_Mult_Pow2; - - XX : Double_Uns := X; - - begin - for J in 1 .. Shift loop - declare - Cur_XX : constant Double_Uns := XX; - begin - XX := Shift_Left (XX, 1); - pragma Assert (XX = Cur_XX * Double_Uns'(2)); - Lemma_Mult_Pow2 (X, J - 1); - end; - Lemma_Double_Shift_Left (X, J - 1, 1); - pragma Loop_Invariant (XX = Shift_Left (X, J)); - pragma Loop_Invariant (XX = X * Double_Uns'(2) ** J); - end loop; - end Lemma_Shift_Left; - - ----------------------- - -- Lemma_Shift_Right -- - ----------------------- - - procedure Lemma_Shift_Right (X : Double_Uns; Shift : Natural) is - - procedure Lemma_Div_Pow2 (X : Double_Uns; I : Natural) - with - Ghost, - Pre => I < Double_Size - 1, - Post => X / Double_Uns'(2) ** I / Double_Uns'(2) - = X / Double_Uns'(2) ** (I + 1); - - procedure Lemma_Quot_Rem (X, Div, Q, R : Double_Uns) - with - Ghost, - Pre => Div /= 0 - and then X = Q * Div + R - and then Q <= Double_Uns'Last / Div - and then R <= Double_Uns'Last - Q * Div - and then R < Div, - Post => Q = X / Div; - pragma Annotate (GNATprove, False_Positive, "postcondition might fail", - "Q is the quotient of X by Div"); - - procedure Lemma_Div_Pow2 (X : Double_Uns; I : Natural) is - - -- Local lemmas - - procedure Lemma_Mult_Le (X, Y, Z : Double_Uns) - with - Ghost, - Pre => X <= 1, - Post => X * Z <= Z; - - procedure Lemma_Mult_Le (X, Y, Z : Double_Uns) is null; - - -- Local variables - - Div1 : constant Double_Uns := Double_Uns'(2) ** I; - Div2 : constant Double_Uns := Double_Uns'(2); - Left : constant Double_Uns := X / Div1 / Div2; - R2 : constant Double_Uns := X / Div1 - Left * Div2; - pragma Assert (R2 <= Div2 - 1); - R1 : constant Double_Uns := X - X / Div1 * Div1; - pragma Assert (R1 < Div1); - - -- Start of processing for Lemma_Div_Pow2 - - begin - pragma Assert (X = Left * (Div1 * Div2) + R2 * Div1 + R1); - Lemma_Mult_Le (R2, Div2 - 1, Div1); - pragma Assert (R2 * Div1 + R1 < Div1 * Div2); - Lemma_Quot_Rem (X, Div1 * Div2, Left, R2 * Div1 + R1); - pragma Assert (Left = X / (Div1 * Div2)); - pragma Assert (Div1 * Div2 = Double_Uns'(2) ** (I + 1)); - end Lemma_Div_Pow2; - - procedure Lemma_Quot_Rem (X, Div, Q, R : Double_Uns) is null; - - XX : Double_Uns := X; - - begin - for J in 1 .. Shift loop - declare - Cur_XX : constant Double_Uns := XX; - begin - XX := Shift_Right (XX, 1); - pragma Assert (XX = Cur_XX / Double_Uns'(2)); - Lemma_Div_Pow2 (X, J - 1); - end; - Lemma_Double_Shift_Right (X, J - 1, 1); - pragma Loop_Invariant (XX = Shift_Right (X, J)); - pragma Loop_Invariant (XX = X / Double_Uns'(2) ** J); - end loop; - Lemma_Div_Commutation (X, Double_Uns'(2) ** Shift); - end Lemma_Shift_Right; - - ------------------------------ - -- Lemma_Shift_Without_Drop -- - ------------------------------ - - procedure Lemma_Shift_Without_Drop - (X, Y : Double_Uns; - Mask : Single_Uns; - Shift : Natural) - is - pragma Unreferenced (Mask); - - procedure Lemma_Bound - with - Pre => Shift <= Single_Size - and then X <= 2**Single_Size - * Double_Uns'(2**(Single_Size - Shift) - 1) - + Single_Uns'(2**Single_Size - 1), - Post => X <= 2**(Double_Size - Shift) - 1; - - procedure Lemma_Exp_Pos (N : Integer) - with - Pre => N in 0 .. Double_Size - 1, - Post => Double_Uns'(2**N) > 0; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Bound is null; - procedure Lemma_Exp_Pos (N : Integer) is null; - - -- Start of processing for Lemma_Shift_Without_Drop - - begin - if Shift = 0 then - pragma Assert (Big (Y) = Big_2xx (Shift) * Big (X)); - return; - end if; - - Lemma_Bound; - Lemma_Exp_Pos (Double_Size - Shift); - pragma Assert (X < 2**(Double_Size - Shift)); - pragma Assert (Big (X) < Big_2xx (Double_Size - Shift)); - pragma Assert (Y = 2**Shift * X); - Lemma_Lt_Mult (Big (X), Big_2xx (Double_Size - Shift), Big_2xx (Shift), - Big_2xx (Shift) * Big_2xx (Double_Size - Shift)); - pragma Assert (Big_2xx (Shift) * Big (X) - < Big_2xx (Shift) * Big_2xx (Double_Size - Shift)); - Lemma_Powers_Of_2 (Shift, Double_Size - Shift); - Lemma_Mult_Commutation (2**Shift, X, Y); - pragma Assert (Big (Y) = Big_2xx (Shift) * Big (X)); - end Lemma_Shift_Without_Drop; - - ------------------------------- -- Multiply_With_Ovflo_Check -- ------------------------------- @@ -1680,160 +294,16 @@ is T1, T2 : Double_Uns; - -- Local ghost variables - - Mult : constant Big_Integer := abs (Big (X) * Big (Y)) with Ghost; - - -- Local lemmas - - procedure Prove_Both_Too_Large - with - Ghost, - Pre => Xhi /= 0 - and then Yhi /= 0 - and then Mult = - Big_2xxSingle * Big_2xxSingle * (Big (Double_Uns'(Xhi * Yhi))) - + Big_2xxSingle * (Big (Double_Uns'(Xhi * Ylo))) - + Big_2xxSingle * (Big (Double_Uns'(Xlo * Yhi))) - + (Big (Double_Uns'(Xlo * Ylo))), - Post => not In_Double_Int_Range (Big (X) * Big (Y)); - - procedure Prove_Final_Decomposition - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)) - and then Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1))) - and then Hi (T2) = 0, - Post => Mult = Big (Lo (T2) & Lo (T1)); - - procedure Prove_Neg_Int - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)) - and then Mult = Big (T2) - and then ((X >= 0 and then Y < 0) or else (X < 0 and then Y >= 0)), - Post => To_Neg_Int (T2) = X * Y; - - procedure Prove_Pos_Int - with - Ghost, - Pre => In_Double_Int_Range (Big (X) * Big (Y)) - and then Mult = Big (T2) - and then ((X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0)), - Post => In_Double_Int_Range (Big (T2)) - and then To_Pos_Int (T2) = X * Y; - - procedure Prove_Result_Too_Large - with - Ghost, - Pre => Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1))) - and then Hi (T2) /= 0, - Post => not In_Double_Int_Range (Big (X) * Big (Y)); - - procedure Prove_Too_Large - with - Ghost, - Pre => abs (Big (X) * Big (Y)) >= Big_2xxDouble, - Post => not In_Double_Int_Range (Big (X) * Big (Y)); - - -------------------------- - -- Prove_Both_Too_Large -- - -------------------------- - - procedure Prove_Both_Too_Large is - begin - pragma Assert (Mult >= - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns'(Xhi * Yhi))); - pragma Assert (Double_Uns (Xhi) * Double_Uns (Yhi) >= 1); - pragma Assert (Mult >= Big_2xxSingle * Big_2xxSingle); - Prove_Too_Large; - end Prove_Both_Too_Large; - - ------------------------------- - -- Prove_Final_Decomposition -- - ------------------------------- - - procedure Prove_Final_Decomposition is - begin - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert (Mult = Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1)))); - pragma Assert (Mult <= Big_2xxDouble_Minus_1); - Lemma_Mult_Commutation (X, Y); - pragma Assert (Mult = abs Big (X * Y)); - Lemma_Word_Commutation (Lo (T2)); - pragma Assert (Mult = Big (Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2))) - + Big (Double_Uns (Lo (T1)))); - Lemma_Add_Commutation (Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2)), - Lo (T1)); - pragma Assert (Mult = Big (Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2)) + Lo (T1))); - pragma Assert (Lo (T2) & Lo (T1) = Double_Uns'(2 ** Single_Size) - * Double_Uns (Lo (T2)) + Lo (T1)); - end Prove_Final_Decomposition; - - ------------------- - -- Prove_Neg_Int -- - ------------------- - - procedure Prove_Neg_Int is - begin - pragma Assert (X * Y <= 0); - pragma Assert (Mult = -Big (X * Y)); - end Prove_Neg_Int; - - ------------------- - -- Prove_Pos_Int -- - ------------------- - - procedure Prove_Pos_Int is - begin - pragma Assert (X * Y >= 0); - pragma Assert (Mult = Big (X * Y)); - end Prove_Pos_Int; - - ---------------------------- - -- Prove_Result_Too_Large -- - ---------------------------- - - procedure Prove_Result_Too_Large is - begin - pragma Assert (Mult >= Big_2xxSingle * Big (T2)); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert (Mult >= - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2)))); - pragma Assert (Double_Uns (Hi (T2)) >= 1); - pragma Assert (Mult >= Big_2xxSingle * Big_2xxSingle); - Prove_Too_Large; - end Prove_Result_Too_Large; - - --------------------- - -- Prove_Too_Large -- - --------------------- - - procedure Prove_Too_Large is null; - - -- Start of processing for Multiply_With_Ovflo_Check - begin - Lemma_Mult_Decomposition (Mult, Xu, Yu, Xhi, Xlo, Yhi, Ylo); - if Xhi /= 0 then if Yhi /= 0 then - Prove_Both_Too_Large; Raise_Error; else T2 := Xhi * Ylo; - pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo)) - + Big (Double_Uns'(Xlo * Yhi))); end if; elsif Yhi /= 0 then T2 := Xlo * Yhi; - pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo)) - + Big (Double_Uns'(Xlo * Yhi))); else -- Yhi = Xhi = 0 T2 := 0; @@ -1843,57 +313,27 @@ is -- result from the upper halves of the input values. T1 := Xlo * Ylo; - - pragma Assert (Big (T2) = Big (Double_Uns'(Xhi * Ylo)) - + Big (Double_Uns'(Xlo * Yhi))); - Lemma_Mult_Distribution (Big_2xxSingle, Big (Double_Uns'(Xhi * Ylo)), - Big (Double_Uns'(Xlo * Yhi))); - pragma Assert (Mult = Big_2xxSingle * Big (T2) + Big (T1)); - Lemma_Add_Commutation (T2, Hi (T1)); - pragma Assert - (Big (T2 + Hi (T1)) = Big (T2) + Big (Double_Uns (Hi (T1)))); - T2 := T2 + Hi (T1); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - pragma Assert - (Mult = Big_2xxSingle * Big (T2) + Big (Double_Uns (Lo (T1)))); - if Hi (T2) /= 0 then - Prove_Result_Too_Large; Raise_Error; end if; - Prove_Final_Decomposition; - T2 := Lo (T2) & Lo (T1); - pragma Assert (Mult = Big (T2)); - if X >= 0 then if Y >= 0 then - Prove_Pos_Int; return To_Pos_Int (T2); - pragma Annotate (CodePeer, Intentional, "precondition", - "Intentional Unsigned->Signed conversion"); else - Prove_Neg_Int; - Lemma_Abs_Range (Big (X) * Big (Y)); return To_Neg_Int (T2); end if; else -- X < 0 if Y < 0 then - Prove_Pos_Int; return To_Pos_Int (T2); - pragma Annotate (CodePeer, Intentional, "precondition", - "Intentional Unsigned->Signed conversion"); else - Prove_Neg_Int; - Lemma_Abs_Range (Big (X) * Big (Y)); return To_Neg_Int (T2); end if; end if; - end Multiply_With_Ovflo_Check; ----------------- @@ -1909,8 +349,6 @@ is -- Scaled_Divide -- ------------------- - pragma Annotate (Gnatcheck, Exempt_On, "Metrics_Cyclomatic_Complexity", - "limit exceeded due to proof code"); procedure Scaled_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; @@ -1928,10 +366,10 @@ is Zhi : Single_Uns := Hi (Zu); Zlo : Single_Uns := Lo (Zu); - D : array (1 .. 4) of Single_Uns with Relaxed_Initialization; + D : array (1 .. 4) of Single_Uns; -- The dividend, four digits (D(1) is high order) - Qd : array (1 .. 2) of Single_Uns with Relaxed_Initialization; + Qd : array (1 .. 2) of Single_Uns; -- The quotient digits, two digits (Qd(1) is high order) S1, S2, S3 : Single_Uns; @@ -1956,605 +394,6 @@ is T1, T2, T3 : Double_Uns; -- Temporary values - -- Local ghost variables - - Mult : constant Big_Natural := abs (Big (X) * Big (Y)) with Ghost; - Quot : Big_Integer with Ghost; - Big_R : Big_Integer with Ghost; - Big_Q : Big_Integer with Ghost; - Inter : Natural with Ghost; - - -- Local ghost functions - - function Is_Mult_Decomposition - (D1, D2, D3, D4 : Big_Integer) - return Boolean - is - (Mult = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * D1 - + Big_2xxSingle * Big_2xxSingle * D2 - + Big_2xxSingle * D3 - + D4) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - function Is_Scaled_Mult_Decomposition - (D1, D2, D3, D4 : Big_Integer) - return Boolean - is - (Mult * Big_2xx (Scale) - = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * D1 - + Big_2xxSingle * Big_2xxSingle * D2 - + Big_2xxSingle * D3 - + D4) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof), - Pre => Scale < Double_Size; - - -- Local lemmas - - procedure Prove_Dividend_Scaling - with - Ghost, - Pre => D'Initialized - and then Scale <= Single_Size - and then Is_Mult_Decomposition (Big (Double_Uns (D (1))), - Big (Double_Uns (D (2))), - Big (Double_Uns (D (3))), - Big (Double_Uns (D (4)))) - and then Big (D (1) & D (2)) * Big_2xx (Scale) < Big_2xxDouble - and then T1 = Shift_Left (D (1) & D (2), Scale) - and then T2 = Shift_Left (Double_Uns (D (3)), Scale) - and then T3 = Shift_Left (Double_Uns (D (4)), Scale), - Post => Is_Scaled_Mult_Decomposition - (Big (Double_Uns (Hi (T1))), - Big (Double_Uns (Lo (T1) or Hi (T2))), - Big (Double_Uns (Lo (T2) or Hi (T3))), - Big (Double_Uns (Lo (T3)))); - -- Proves the scaling of the 4-digit dividend actually multiplies it by - -- 2**Scale. - - procedure Prove_Multiplication (Q : Single_Uns) - with - Ghost, - Pre => T1 = Q * Lo (Zu) - and then T2 = Q * Hi (Zu) - and then S3 = Lo (T1) - and then T3 = Hi (T1) + Lo (T2) - and then S2 = Lo (T3) - and then S1 = Hi (T3) + Hi (T2), - Post => Big3 (S1, S2, S3) = Big (Double_Uns (Q)) * Big (Zu); - -- Proves correctness of the multiplication of divisor by quotient to - -- compute amount to subtract. - - procedure Prove_Mult_Decomposition_Split2 - (D1, D2, D2_Hi, D2_Lo, D3, D4 : Big_Integer) - with - Ghost, - Pre => Is_Mult_Decomposition (D1, D2, D3, D4) - and then D2 = Big_2xxSingle * D2_Hi + D2_Lo, - Post => Is_Mult_Decomposition (D1 + D2_Hi, D2_Lo, D3, D4); - -- Proves decomposition of Mult after splitting second component - - procedure Prove_Mult_Decomposition_Split3 - (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer) - with - Ghost, - Pre => Is_Mult_Decomposition (D1, D2, D3, D4) - and then D3 = Big_2xxSingle * D3_Hi + D3_Lo, - Post => Is_Mult_Decomposition (D1, D2 + D3_Hi, D3_Lo, D4); - -- Proves decomposition of Mult after splitting third component - - procedure Prove_Negative_Dividend - with - Ghost, - Pre => Z /= 0 - and then Big (Qu) = abs Big_Q - and then In_Double_Int_Range (Big_Q) - and then Big (Ru) = abs Big_R - and then ((X >= 0 and Y < 0) or (X < 0 and Y >= 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)) - and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => - (if Z > 0 then Big_Q <= Big_0 - and then In_Double_Int_Range (-Big (Qu)) - else Big_Q >= Big_0 - and then In_Double_Int_Range (Big (Qu))) - and then In_Double_Int_Range (-Big (Ru)); - -- Proves the sign of rounded quotient when dividend is non-positive - - procedure Prove_Overflow - with - Ghost, - Pre => Z /= 0 - and then Mult >= Big_2xxDouble * Big (Double_Uns'(abs Z)), - Post => not In_Double_Int_Range (Big (X) * Big (Y) / Big (Z)) - and then not In_Double_Int_Range - (Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z))); - -- Proves overflow case when the quotient has at least 3 digits - - procedure Prove_Positive_Dividend - with - Ghost, - Pre => Z /= 0 - and then Big (Qu) = abs Big_Q - and then In_Double_Int_Range (Big_Q) - and then Big (Ru) = abs Big_R - and then ((X >= 0 and Y >= 0) or (X < 0 and Y < 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)) - and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => - (if Z > 0 then Big_Q >= Big_0 - and then In_Double_Int_Range (Big (Qu)) - else Big_Q <= Big_0 - and then In_Double_Int_Range (-Big (Qu))) - and then In_Double_Int_Range (Big (Ru)); - -- Proves the sign of rounded quotient when dividend is non-negative - - procedure Prove_Qd_Calculation_Part_1 (J : Integer) - with - Ghost, - Pre => J in 1 .. 2 - and then D'Initialized - and then D (J) < Zhi - and then Hi (Zu) = Zhi - and then Qd (J)'Initialized - and then Qd (J) = Lo ((D (J) & D (J + 1)) / Zhi), - Post => Big (Double_Uns (Qd (J))) >= - Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu); - -- When dividing 3 digits by 2 digits, proves the initial calculation - -- of the quotient given by dividing the first 2 digits of the dividend - -- by the first digit of the divisor is not an underestimate (so - -- readjusting down works). - - procedure Prove_Q_Too_Big - with - Ghost, - Pre => In_Double_Int_Range (Big_Q) - and then abs Big_Q = Big_2xxDouble, - Post => False; - -- Proves the inconsistency when Q is equal to Big_2xx64 - - procedure Prove_Rescaling - with - Ghost, - Pre => Scale <= Single_Size - and then Z /= 0 - and then Mult * Big_2xx (Scale) = Big (Zu) * Big (Qu) + Big (Ru) - and then Big (Ru) < Big (Zu) - and then Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale) - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => abs Quot = Big (Qu) - and then abs Big_R = Big (Shift_Right (Ru, Scale)); - -- Proves scaling back only the remainder is the right thing to do after - -- computing the scaled division. - - procedure Prove_Rounding_Case - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - and then Big (Ru) = abs Big_R - and then Big (Zu) = Big (Double_Uns'(abs Z)), - Post => abs Big_Q = - (if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) - then abs Quot + 1 - else abs Quot); - -- Proves correctness of the rounding of the unsigned quotient - - procedure Prove_Scaled_Mult_Decomposition_Regroup24 - (D1, D2, D3, D4 : Big_Integer) - with - Ghost, - Pre => Scale < Double_Size - and then Is_Scaled_Mult_Decomposition (D1, D2, D3, D4), - Post => Is_Scaled_Mult_Decomposition - (0, Big_2xxSingle * D1 + D2, 0, Big_2xxSingle * D3 + D4); - -- Proves scaled decomposition of Mult after regrouping on second and - -- fourth component. - - procedure Prove_Scaled_Mult_Decomposition_Regroup3 - (D1, D2, D3, D4 : Single_Uns) - with - Ghost, - Pre => Scale < Double_Size - and then Is_Scaled_Mult_Decomposition - (Big (Double_Uns (D1)), Big (Double_Uns (D2)), - Big (Double_Uns (D3)), Big (Double_Uns (D4))), - Post => Is_Scaled_Mult_Decomposition (0, 0, Big3 (D1, D2, D3), - Big (Double_Uns (D4))); - -- Proves scaled decomposition of Mult after regrouping on third - -- component. - - procedure Prove_Sign_R - with - Ghost, - Pre => Z /= 0 and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => In_Double_Int_Range (Big_R); - - procedure Prove_Signs - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - (if Round then - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - else Quot) - and then Big (Ru) = abs Big_R - and then Big (Qu) = abs Big_Q - and then In_Double_Int_Range (Big_Q) - and then In_Double_Int_Range (Big_R) - and then R = - (if (X >= 0) = (Y >= 0) then To_Pos_Int (Ru) else To_Neg_Int (Ru)) - and then Q = - (if ((X >= 0) = (Y >= 0)) = (Z >= 0) then To_Pos_Int (Qu) - else To_Neg_Int (Qu)), -- need to ensure To_Pos_Int precondition - Post => Big (R) = Big_R and then Big (Q) = Big_Q; - -- Proves final signs match the intended result after the unsigned - -- division is done. - - procedure Prove_Z_Low - with - Ghost, - Pre => Z /= 0 - and then D'Initialized - and then Hi (abs Z) = 0 - and then Lo (abs Z) = Zlo - and then Mult = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))) - and then D (2) < Zlo - and then Quot = (Big (X) * Big (Y)) / Big (Z) - and then Big_R = (Big (X) * Big (Y)) rem Big (Z) - and then T1 = D (2) & D (3) - and then T2 = Lo (T1 rem Zlo) & D (4) - and then Qu = Lo (T1 / Zlo) & Lo (T2 / Zlo) - and then Ru = T2 rem Zlo, - Post => Big (Qu) = abs Quot - and then Big (Ru) = abs Big_R; - -- Proves the case where the divisor is only one digit - - ---------------------------- - -- Prove_Dividend_Scaling -- - ---------------------------- - - procedure Prove_Dividend_Scaling is - Big_D12 : constant Big_Integer := - Big_2xx (Scale) * Big (D (1) & D (2)); - Big_T1 : constant Big_Integer := Big (T1); - Big_D3 : constant Big_Integer := - Big_2xx (Scale) * Big (Double_Uns (D (3))); - Big_T2 : constant Big_Integer := Big (T2); - Big_D4 : constant Big_Integer := - Big_2xx (Scale) * Big (Double_Uns (D (4))); - Big_T3 : constant Big_Integer := Big (T3); - - begin - Lemma_Shift_Left (D (1) & D (2), Scale); - Lemma_Ge_Mult (Big_2xxSingle, Big_2xx (Scale), Big_2xxSingle, - Big_2xxSingle * Big_2xx (Scale)); - Lemma_Lt_Mult (Big (Double_Uns (D (3))), Big_2xxSingle, - Big_2xx (Scale), Big_2xxDouble); - Lemma_Shift_Left (Double_Uns (D (3)), Scale); - Lemma_Lt_Mult (Big (Double_Uns (D (4))), Big_2xxSingle, - Big_2xx (Scale), Big_2xxDouble); - Lemma_Shift_Left (Double_Uns (D (4)), Scale); - Lemma_Hi_Lo (D (1) & D (2), D (1), D (2)); - pragma Assert (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big_2xxSingle * Big_D12 - + Big_2xxSingle * Big_D3 - + Big_D4); - pragma Assert (Big_2xx (Scale) > 0); - declare - Two_xx_Scale : constant Double_Uns := Double_Uns'(2 ** Scale); - D12 : constant Double_Uns := D (1) & D (2); - begin - pragma Assert (Big_2xx (Scale) * Big (D12) < Big_2xxDouble); - pragma Assert (Big (Two_xx_Scale) * Big (D12) < Big_2xxDouble); - Lemma_Mult_Commutation (Two_xx_Scale, D12, T1); - end; - pragma Assert (Big_D12 = Big_T1); - pragma Assert (Big_2xxSingle * Big_2xxSingle * Big_D12 - = Big_2xxSingle * Big_2xxSingle * Big_T1); - Lemma_Mult_Commutation (2 ** Scale, Double_Uns (D (3)), T2); - pragma Assert (Big_D3 = Big_T2); - pragma Assert (Big_2xxSingle * Big_D3 = Big_2xxSingle * Big_T2); - Lemma_Mult_Commutation (2 ** Scale, Double_Uns (D (4)), T3); - pragma Assert - (Is_Scaled_Mult_Decomposition (0, Big_T1, Big_T2, Big_T3)); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Lemma_Hi_Lo (T3, Hi (T3), Lo (T3)); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big_2xxSingle * Big (Double_Uns (Hi (T1))), - Big (Double_Uns (Lo (T1)))); - Lemma_Mult_Distribution (Big_2xxSingle, - Big_2xxSingle * Big (Double_Uns (Hi (T2))), - Big (Double_Uns (Lo (T2)))); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big (Double_Uns (Lo (T1))), - Big (Double_Uns (Hi (T2)))); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns (Lo (T2))), - Big (Double_Uns (Hi (T3)))); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big (Double_Uns (Lo (T1))), - Big (Double_Uns (Hi (T2)))); - pragma Assert (Double_Uns (Lo (T1) or Hi (T2)) = - Double_Uns (Lo (T1)) + Double_Uns (Hi (T2))); - pragma Assert (Double_Uns (Lo (T2) or Hi (T3)) = - Double_Uns (Lo (T2)) + Double_Uns (Hi (T3))); - Lemma_Add_Commutation (Double_Uns (Lo (T1)), Hi (T2)); - Lemma_Add_Commutation (Double_Uns (Lo (T2)), Hi (T3)); - end Prove_Dividend_Scaling; - - -------------------------- - -- Prove_Multiplication -- - -------------------------- - - procedure Prove_Multiplication (Q : Single_Uns) is - begin - Lemma_Hi_Lo (Zu, Hi (Zu), Lo (Zu)); - Lemma_Hi_Lo (T1, Hi (T1), S3); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Lemma_Hi_Lo (T3, Hi (T3), S2); - Lemma_Mult_Commutation (Double_Uns (Q), Double_Uns (Lo (Zu)), T1); - Lemma_Mult_Commutation (Double_Uns (Q), Double_Uns (Hi (Zu)), T2); - Lemma_Mult_Distribution (Big (Double_Uns (Q)), - Big_2xxSingle * Big (Double_Uns (Hi (Zu))), - Big (Double_Uns (Lo (Zu)))); - Lemma_Substitution - (Big (Double_Uns (Q)) * Big (Zu), - Big (Double_Uns (Q)), - Big (Zu), - Big_2xxSingle * Big (Double_Uns (Hi (Zu))) - + Big (Double_Uns (Lo (Zu))), - Big_0); - pragma Assert (Big (Double_Uns (Q)) * Big (Zu) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big_2xxSingle * Big (Double_Uns (Hi (T1))) - + Big (Double_Uns (S3))); - Lemma_Add_Commutation (Double_Uns (Lo (T2)), Hi (T1)); - pragma Assert - (By (Big (Double_Uns (Q)) * Big (Zu) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) - + Big_2xxSingle * Big (T3) - + Big (Double_Uns (S3)), - By (Big_2xxSingle * Big (Double_Uns (Lo (T2))) - + Big_2xxSingle * Big (Double_Uns (Hi (T1))) - = Big_2xxSingle * Big (T3), - Double_Uns (Lo (T2)) - + Double_Uns (Hi (T1)) = T3))); - pragma Assert (Double_Uns (Hi (T3)) + Hi (T2) = Double_Uns (S1)); - Lemma_Add_Commutation (Double_Uns (Hi (T3)), Hi (T2)); - pragma Assert - (Big (Double_Uns (Hi (T3))) + Big (Double_Uns (Hi (T2))) = - Big (Double_Uns (S1))); - Lemma_Mult_Distribution (Big_2xxSingle * Big_2xxSingle, - Big (Double_Uns (Hi (T3))), - Big (Double_Uns (Hi (T2)))); - end Prove_Multiplication; - - ------------------------------------- - -- Prove_Mult_Decomposition_Split2 -- - ------------------------------------- - - procedure Prove_Mult_Decomposition_Split2 - (D1, D2, D2_Hi, D2_Lo, D3, D4 : Big_Integer) - is null; - - ------------------------------------- - -- Prove_Mult_Decomposition_Split3 -- - ------------------------------------- - - procedure Prove_Mult_Decomposition_Split3 - (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer) - is null; - - ----------------------------- - -- Prove_Negative_Dividend -- - ----------------------------- - - procedure Prove_Negative_Dividend is - begin - Lemma_Mult_Non_Positive (Big (X), Big (Y)); - end Prove_Negative_Dividend; - - -------------------- - -- Prove_Overflow -- - -------------------- - - procedure Prove_Overflow is - begin - Lemma_Div_Ge (Mult, Big_2xxDouble, Big (Double_Uns'(abs Z))); - Lemma_Abs_Commutation (Z); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - end Prove_Overflow; - - ----------------------------- - -- Prove_Positive_Dividend -- - ----------------------------- - - procedure Prove_Positive_Dividend is - begin - Lemma_Mult_Non_Negative (Big (X), Big (Y)); - end Prove_Positive_Dividend; - - --------------------------------- - -- Prove_Qd_Calculation_Part_1 -- - --------------------------------- - - procedure Prove_Qd_Calculation_Part_1 (J : Integer) is - begin - Lemma_Hi_Lo (D (J) & D (J + 1), D (J), D (J + 1)); - Lemma_Lt_Commutation (Double_Uns (D (J)), Double_Uns (Zhi)); - Lemma_Gt_Mult (Big (Double_Uns (Zhi)), - Big (Double_Uns (D (J))) + 1, - Big_2xxSingle, Big (D (J) & D (J + 1))); - Lemma_Div_Lt - (Big (D (J) & D (J + 1)), Big_2xxSingle, Big (Double_Uns (Zhi))); - Lemma_Div_Commutation (D (J) & D (J + 1), Double_Uns (Zhi)); - Lemma_Lo_Is_Ident ((D (J) & D (J + 1)) / Zhi); - Lemma_Div_Definition (D (J) & D (J + 1), Zhi, Double_Uns (Qd (J)), - (D (J) & D (J + 1)) rem Zhi); - Lemma_Lt_Commutation - ((D (J) & D (J + 1)) rem Zhi, Double_Uns (Zhi)); - Lemma_Gt_Mult - ((Big (Double_Uns (Qd (J))) + 1) * Big (Double_Uns (Zhi)), - Big (D (J) & D (J + 1)) + 1, Big_2xxSingle, - Big3 (D (J), D (J + 1), D (J + 2))); - Lemma_Hi_Lo (Zu, Zhi, Lo (Zu)); - Lemma_Gt_Mult (Big (Zu), Big_2xxSingle * Big (Double_Uns (Zhi)), - Big (Double_Uns (Qd (J))) + 1, - Big3 (D (J), D (J + 1), D (J + 2))); - Lemma_Div_Lt (Big3 (D (J), D (J + 1), D (J + 2)), - Big (Double_Uns (Qd (J))) + 1, Big (Zu)); - end Prove_Qd_Calculation_Part_1; - - --------------------- - -- Prove_Q_Too_Big -- - --------------------- - - procedure Prove_Q_Too_Big is - begin - pragma Assert (Big_Q = Big_2xxDouble or Big_Q = -Big_2xxDouble); - Lemma_Not_In_Range_Big2xx64; - end Prove_Q_Too_Big; - - --------------------- - -- Prove_Rescaling -- - --------------------- - - procedure Prove_Rescaling is - begin - Lemma_Div_Lt (Big (Ru), Big (Double_Uns'(abs Z)), Big_2xx (Scale)); - Lemma_Div_Eq (Mult, Big (Double_Uns'(abs Z)) * Big (Qu), - Big_2xx (Scale), Big (Ru)); - Lemma_Rev_Div_Definition (Mult, Big (Double_Uns'(abs Z)), - Big (Qu), Big (Ru) / Big_2xx (Scale)); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Commutation (Z); - Lemma_Shift_Right (Ru, Scale); - end Prove_Rescaling; - - ------------------------- - -- Prove_Rounding_Case -- - ------------------------- - - procedure Prove_Rounding_Case is - begin - if Same_Sign (Big (X) * Big (Y), Big (Z)) then - pragma Assert - (abs Big_Q = - (if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) - then abs Quot + 1 - else abs Quot)); - end if; - end Prove_Rounding_Case; - - ----------------------------------------------- - -- Prove_Scaled_Mult_Decomposition_Regroup24 -- - ----------------------------------------------- - - procedure Prove_Scaled_Mult_Decomposition_Regroup24 - (D1, D2, D3, D4 : Big_Integer) - is null; - - ---------------------------------------------- - -- Prove_Scaled_Mult_Decomposition_Regroup3 -- - ---------------------------------------------- - - procedure Prove_Scaled_Mult_Decomposition_Regroup3 - (D1, D2, D3, D4 : Single_Uns) - is null; - - ------------------ - -- Prove_Sign_R -- - ------------------ - - procedure Prove_Sign_R is - begin - pragma Assert (In_Double_Int_Range (Big (Z))); - end Prove_Sign_R; - - ----------------- - -- Prove_Signs -- - ----------------- - - procedure Prove_Signs is null; - - ----------------- - -- Prove_Z_Low -- - ----------------- - - procedure Prove_Z_Low is - begin - Lemma_Hi_Lo (T1, D (2), D (3)); - Lemma_Add_Commutation (Double_Uns (D (2)), 1); - pragma Assert - (Big (Double_Uns (D (2))) + 1 <= Big (Double_Uns (Zlo))); - Lemma_Div_Definition (T1, Zlo, T1 / Zlo, T1 rem Zlo); - pragma Assert - (By (Lo (T1 rem Zlo) = Hi (T2), - By (Double_Uns (Lo (T1 rem Zlo)) = T1 rem Zlo, - T1 rem Zlo <= Double_Uns (Zlo)))); - Lemma_Hi_Lo (T2, Lo (T1 rem Zlo), D (4)); - pragma Assert (T1 rem Zlo < Double_Uns (Zlo)); - pragma Assert (T1 rem Zlo + Double_Uns'(1) <= Double_Uns (Zlo)); - Lemma_Ge_Commutation (Double_Uns (Zlo), T1 rem Zlo + Double_Uns'(1)); - Lemma_Add_Commutation (T1 rem Zlo, 1); - pragma Assert (Big (T1 rem Zlo) + 1 <= Big (Double_Uns (Zlo))); - Lemma_Div_Definition (T2, Zlo, T2 / Zlo, Ru); - pragma Assert - (By (Big_2xxSingle * Big (Double_Uns (D (2))) - + Big (Double_Uns (D (3))) - < Big_2xxSingle * (Big (Double_Uns (D (2))) + 1), - Mult = Big (Double_Uns (Zlo)) * - (Big_2xxSingle * Big (T1 / Zlo) + Big (T2 / Zlo)) + Big (Ru))); - Lemma_Div_Lt (Big (T1), Big_2xxSingle, Big (Double_Uns (Zlo))); - Lemma_Div_Commutation (T1, Double_Uns (Zlo)); - Lemma_Lo_Is_Ident (T1 / Zlo); - pragma Assert - (Big (T2) <= Big_2xxSingle * (Big (Double_Uns (Zlo)) - 1) - + Big (Double_Uns (D (4)))); - Lemma_Hi_Lo (Qu, Lo (T1 / Zlo), Lo (T2 / Zlo)); - Lemma_Div_Lt (Big (T2), Big_2xxSingle, Big (Double_Uns (Zlo))); - Lemma_Div_Commutation (T2, Double_Uns (Zlo)); - Lemma_Lo_Is_Ident (T2 / Zlo); - Lemma_Substitution (Mult, Big (Double_Uns (Zlo)), - Big_2xxSingle * Big (T1 / Zlo) + Big (T2 / Zlo), - Big (Qu), Big (Ru)); - pragma Assert - (By (Ru < Double_Uns (Zlo), Ru = T2 rem Zlo)); - Lemma_Lt_Commutation (Ru, Double_Uns (Zlo)); - Lemma_Rev_Div_Definition - (Mult, Big (Double_Uns (Zlo)), Big (Qu), Big (Ru)); - pragma Assert (Double_Uns (Zlo) = abs Z); - Lemma_Abs_Commutation (Z); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z)); - end Prove_Z_Low; - -- Start of processing for Scaled_Divide begin @@ -2562,237 +401,56 @@ is Raise_Error; end if; - Quot := Big (X) * Big (Y) / Big (Z); - Big_R := Big (X) * Big (Y) rem Big (Z); - if Round then - Big_Q := Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R); - else - Big_Q := Quot; - end if; - -- First do the multiplication, giving the four digit dividend - Lemma_Abs_Mult_Commutation (Big (X), Big (Y)); - Lemma_Abs_Commutation (X); - Lemma_Abs_Commutation (Y); - Lemma_Mult_Decomposition (Mult, Xu, Yu, Xhi, Xlo, Yhi, Ylo); - T1 := Xlo * Ylo; D (4) := Lo (T1); D (3) := Hi (T1); - Lemma_Hi_Lo (T1, D (3), D (4)); - if Yhi /= 0 then T1 := Xlo * Yhi; - - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - T2 := D (3) + Lo (T1); - Lemma_Add_Commutation (Double_Uns (Lo (T1)), D (3)); - Lemma_Mult_Distribution (Big_2xxSingle, - Big (Double_Uns (D (3))), - Big (Double_Uns (Lo (T1)))); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - D (3) := Lo (T2); D (2) := Hi (T1) + Hi (T2); - pragma Assert (Double_Uns (Hi (T1)) + Hi (T2) = Double_Uns (D (2))); - Lemma_Add_Commutation (Double_Uns (Hi (T1)), Hi (T2)); - pragma Assert - (Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))) = - Big (Double_Uns (D (2)))); - if Xhi /= 0 then T1 := Xhi * Ylo; - - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - T2 := D (3) + Lo (T1); - Lemma_Add_Commutation (Double_Uns (D (3)), Lo (T1)); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Prove_Mult_Decomposition_Split3 - (D1 => 0, - D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))) - + Big (Double_Uns (Hi (T1))), - D3 => Big (T2), - D3_Hi => Big (Double_Uns (Hi (T2))), - D3_Lo => Big (Double_Uns (Lo (T2))), - D4 => Big (Double_Uns (D (4)))); - D (3) := Lo (T2); T3 := D (2) + Hi (T1); - Lemma_Add_Commutation (Double_Uns (D (2)), Hi (T1)); - Lemma_Add_Commutation (T3, Hi (T2)); - T3 := T3 + Hi (T2); T2 := Double_Uns'(Xhi * Yhi); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - pragma Assert - (Is_Mult_Decomposition - (D1 => Big (Double_Uns (Hi (T2))), - D2 => Big (T3) + Big (Double_Uns (Lo (T2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); - T1 := T3 + Lo (T2); D (2) := Lo (T1); - - Lemma_Add_Commutation (T3, Lo (T2)); - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - Prove_Mult_Decomposition_Split2 - (D1 => Big (Double_Uns (Hi (T2))), - D2 => Big (T1), - D2_Lo => Big (Double_Uns (Lo (T1))), - D2_Hi => Big (Double_Uns (Hi (T1))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4)))); - D (1) := Hi (T2) + Hi (T1); - pragma Assert_And_Cut - (D'Initialized - and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); else - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))) - + Big (Double_Uns (Xhi)) * Big (Yu), - D4 => Big (Double_Uns (D (4))))); - D (1) := 0; - - pragma Assert_And_Cut - (D'Initialized - and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); end if; - else if Xhi /= 0 then T1 := Xhi * Ylo; - - Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (Hi (T1))), - D3 => Big (Double_Uns (Lo (T1))) + Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); - T2 := D (3) + Lo (T1); - Lemma_Add_Commutation (Double_Uns (Lo (T1)), D (3)); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (Hi (T1))), - D3 => Big (T2), - D4 => Big (Double_Uns (D (4))))); - Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - D (3) := Lo (T2); D (2) := Hi (T1) + Hi (T2); - pragma Assert - (Double_Uns (Hi (T1)) + Hi (T2) = Double_Uns (D (2))); - Lemma_Add_Commutation (Double_Uns (Hi (T1)), Hi (T2)); - pragma Assert - (Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))) = - Big (Double_Uns (D (2)))); - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); else D (2) := 0; - - pragma Assert - (Is_Mult_Decomposition - (D1 => 0, - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); end if; D (1) := 0; - - pragma Assert_And_Cut - (D'Initialized - and Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); end if; - pragma Assert_And_Cut - -- Restate the precondition - (Z /= 0 - and then In_Double_Int_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)) - -- Restate the value of local variables - and then Zu = abs Z - and then Zhi = Hi (Zu) - and then Zlo = Lo (Zu) - and then Mult = abs (Big (X) * Big (Y)) - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big_Q = Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - else - Big_Q = Quot) - -- Summarize first part of the procedure - and then D'Initialized - and then Is_Mult_Decomposition (D1 => Big (Double_Uns (D (1))), - D2 => Big (Double_Uns (D (2))), - D3 => Big (Double_Uns (D (3))), - D4 => Big (Double_Uns (D (4))))); - -- Now it is time for the dreaded multiple precision division. First an -- easy case, check for the simple case of a one digit divisor. if Zhi = 0 then if D (1) /= 0 or else D (2) >= Zlo then - if D (1) > 0 then - Lemma_Double_Big_2xxSingle; - Lemma_Mult_Positive (Big_2xxDouble, Big_2xxSingle); - Lemma_Ge_Mult (Big (Double_Uns (D (1))), - 1, - Big_2xxDouble * Big_2xxSingle, - Big_2xxDouble * Big_2xxSingle); - Lemma_Mult_Positive (Big_2xxSingle, Big (Double_Uns (D (1)))); - Lemma_Ge_Mult (Big_2xxSingle * Big_2xxSingle, Big_2xxDouble, - Big_2xxSingle * Big (Double_Uns (D (1))), - Big_2xxDouble * Big_2xxSingle); - pragma Assert (Mult >= Big_2xxDouble * Big_2xxSingle); - Lemma_Ge_Commutation (2 ** Single_Size, Zu); - Lemma_Ge_Mult (Big_2xxSingle, Big (Zu), Big_2xxDouble, - Big_2xxDouble * Big (Zu)); - pragma Assert (Mult >= Big_2xxDouble * Big (Zu)); - else - Lemma_Ge_Commutation (Double_Uns (D (2)), Zu); - pragma Assert (Mult >= Big_2xxDouble * Big (Zu)); - end if; - - Prove_Overflow; Raise_Error; -- Here we are dividing at most three digits by one digit @@ -2803,18 +461,11 @@ is Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo); Ru := T2 rem Zlo; - - Prove_Z_Low; end if; -- If divisor is double digit and dividend is too large, raise error elsif (D (1) & D (2)) >= Zu then - Lemma_Hi_Lo (D (1) & D (2), D (1), D (2)); - Lemma_Ge_Commutation (D (1) & D (2), Zu); - pragma Assert - (Mult >= Big_2xxSingle * Big_2xxSingle * Big (D (1) & D (2))); - Prove_Overflow; Raise_Error; -- This is the complex case where we definitely have a double digit @@ -2827,489 +478,87 @@ is -- First normalize the divisor so that it has the leading bit on. -- We do this by finding the appropriate left shift amount. - Lemma_Hi_Lo (D (1) & D (2), D (1), D (2)); - Lemma_Lt_Commutation (D (1) & D (2), Zu); - pragma Assert - (Mult < Big_2xxDouble * Big (Zu)); - Shift := Single_Size; Mask := Single_Uns'Last; Scale := 0; - Inter := 0; - pragma Assert (Big_2xx (Scale) = 1); - while Shift > 1 loop - pragma Loop_Invariant (Scale <= Single_Size - Shift); - pragma Loop_Invariant ((Hi (Zu) and Mask) /= 0); - pragma Loop_Invariant - (Mask = Shift_Left (Single_Uns'Last, Single_Size - Shift)); - pragma Loop_Invariant (Zu = Shift_Left (abs Z, Scale)); - pragma Loop_Invariant (Big (Zu) = - Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - pragma Loop_Invariant (Inter in 0 .. Log_Single_Size - 1); - pragma Loop_Invariant (Shift = 2 ** (Log_Single_Size - Inter)); - pragma Loop_Invariant (Shift mod 2 = 0); - - declare - -- Local ghost variables - - Shift_Prev : constant Natural := Shift with Ghost; - Mask_Prev : constant Single_Uns := Mask with Ghost; - Zu_Prev : constant Double_Uns := Zu with Ghost; - - -- Local lemmas - - procedure Prove_Power - with - Ghost, - Pre => Inter in 0 .. Log_Single_Size - 1 - and then Shift = 2 ** (Log_Single_Size - Inter), - Post => Shift / 2 = 2 ** (Log_Single_Size - (Inter + 1)) - and then (Shift = 2 or (Shift / 2) mod 2 = 0); - - procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns) - with - Ghost, - Pre => Prev /= 0 - and then (Prev and Mask) = 0, - Post => (Prev and not Mask) /= 0; - - procedure Prove_Shift_Progress - with - Ghost, - Pre => Shift <= Single_Size / 2 - and then Shift_Prev = 2 * Shift - and then Mask_Prev = - Shift_Left (Single_Uns'Last, Single_Size - Shift_Prev) - and then Mask = - Shift_Left (Single_Uns'Last, - Single_Size - Shift_Prev + Shift), - Post => Mask_Prev = - Shift_Left (Single_Uns'Last, Single_Size - 2 * Shift) - and then Mask = - Shift_Left (Single_Uns'Last, Single_Size - Shift); - - procedure Prove_Shifting - with - Ghost, - Pre => Shift <= Single_Size / 2 - and then Zu = Shift_Left (Zu_Prev, Shift) - and then Mask_Prev = - Shift_Left (Single_Uns'Last, Single_Size - 2 * Shift) - and then Mask = - Shift_Left (Single_Uns'Last, Single_Size - Shift) - and then (Hi (Zu_Prev) and Mask_Prev and not Mask) /= 0, - Post => (Hi (Zu) and Mask) /= 0; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns) is null; - procedure Prove_Power is null; - procedure Prove_Shifting is null; - procedure Prove_Shift_Progress is null; - - begin - pragma Assert (Mask = Shift_Left (Single_Uns'Last, - Single_Size - Shift_Prev)); - Prove_Power; - - Shift := Shift / 2; - - Inter := Inter + 1; - pragma Assert (Shift_Prev = 2 * Shift); - - Mask := Shift_Left (Mask, Shift); - - Lemma_Double_Shift - (Single_Uns'Last, Single_Size - Shift_Prev, Shift); - Prove_Shift_Progress; - - if (Hi (Zu) and Mask) = 0 then - Zu := Shift_Left (Zu, Shift); - - pragma Assert ((Hi (Zu_Prev) and Mask_Prev) /= 0); - pragma Assert - (By ((Hi (Zu_Prev) and Mask_Prev and Mask) = 0, - (Hi (Zu_Prev) and Mask) = 0 - and then - (Hi (Zu_Prev) and Mask_Prev and Mask) - = (Hi (Zu_Prev) and Mask and Mask_Prev) - )); - Prove_Prev_And_Mask (Hi (Zu_Prev) and Mask_Prev, Mask); - Prove_Shifting; - pragma Assert (Big (Zu_Prev) = - Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - Lemma_Shift_Without_Drop (Zu_Prev, Zu, Mask, Shift); - Lemma_Substitution - (Big (Zu), Big_2xx (Shift), - Big (Zu_Prev), Big (Double_Uns'(abs Z)) * Big_2xx (Scale), - 0); - Lemma_Powers_Of_2 (Shift, Scale); - Lemma_Substitution - (Big (Zu), Big (Double_Uns'(abs Z)), - Big_2xx (Shift) * Big_2xx (Scale), - Big_2xx (Shift + Scale), 0); - Lemma_Double_Shift (abs Z, Scale, Shift); - - Scale := Scale + Shift; - - pragma Assert (Zu = Shift_Left (abs Z, Scale)); - pragma Assert - (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - end if; - - pragma Assert - (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - end; + Shift := Shift / 2; + Mask := Shift_Left (Mask, Shift); + + if (Hi (Zu) and Mask) = 0 then + Zu := Shift_Left (Zu, Shift); + Scale := Scale + Shift; + end if; end loop; - pragma Assert_And_Cut - (Scale <= Single_Size - 1 - and then (Hi (Zu) and Mask) /= 0 - and then Mask = Shift_Left (Single_Uns'Last, Single_Size - 1) - and then Zu = Shift_Left (abs Z, Scale) - and then Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale) - and then Mult < Big_2xxDouble * Big (Double_Uns'(abs Z))); Zhi := Hi (Zu); Zlo := Lo (Zu); - pragma Assert ((Zhi and Mask) /= 0); - pragma Assert (Zhi >= 2 ** (Single_Size - 1)); - pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); - -- We have Hi (Zu) /= 0 before normalization. The sequence of - -- Shift_Left operations results in the leading bit of Zu being 1 by - -- moving the leftmost 1-bit in Zu to leading position, thus - -- Zhi = Hi (Zu) >= 2 ** (Single_Size - 1) here. - -- Note that when we scale up the dividend, it still fits in four -- digits, since we already tested for overflow, and scaling does -- not change the invariant that (D (1) & D (2)) < Zu. - Lemma_Lt_Commutation (D (1) & D (2), abs Z); - Lemma_Big_Of_Double_Uns (Zu); - Lemma_Lt_Mult (Big (D (1) & D (2)), - Big (Double_Uns'(abs Z)), Big_2xx (Scale), - Big_2xxDouble); - T1 := Shift_Left (D (1) & D (2), Scale); T2 := Shift_Left (Double_Uns (D (3)), Scale); T3 := Shift_Left (Double_Uns (D (4)), Scale); - Prove_Dividend_Scaling; - D (1) := Hi (T1); D (2) := Lo (T1) or Hi (T2); D (3) := Lo (T2) or Hi (T3); D (4) := Lo (T3); - pragma Assert (D (1) = Hi (T1) and D (2) = (Lo (T1) or Hi (T2)) - and D (3) = (Lo (T2) or Hi (T3)) and D (4) = Lo (T3)); - Lemma_Substitution (Big_2xxDouble * Big (Zu), Big_2xxDouble, Big (Zu), - Big (Double_Uns'(abs Z)) * Big_2xx (Scale), 0); - pragma Assert (Mult < Big_2xxDouble * Big (Double_Uns'(abs Z))); - Lemma_Lt_Mult (Mult, Big_2xxDouble * Big (Double_Uns'(abs Z)), - Big_2xx (Scale), Big_2xxDouble * Big (Zu)); - pragma Assert (Mult >= Big_0); - pragma Assert (Big_2xx (Scale) >= Big_0); - Lemma_Mult_Non_Negative (Mult, Big_2xx (Scale)); - Lemma_Div_Lt (Mult * Big_2xx (Scale), Big (Zu), Big_2xxDouble); - Lemma_Concat_Definition (D (1), D (2)); - Lemma_Double_Big_2xxSingle; - Prove_Scaled_Mult_Decomposition_Regroup24 - (Big (Double_Uns (D (1))), - Big (Double_Uns (D (2))), - Big (Double_Uns (D (3))), - Big (Double_Uns (D (4)))); - Lemma_Substitution - (Mult * Big_2xx (Scale), Big_2xxSingle * Big_2xxSingle, - Big_2xxSingle * Big (Double_Uns (D (1))) - + Big (Double_Uns (D (2))), - Big (D (1) & D (2)), - Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); - pragma Assert - (By (Big (D (1) & D (2)) < Big (Zu), - Big_2xxDouble * (Big (Zu) - Big (D (1) & D (2))) > - Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))))); - -- Loop to compute quotient digits, runs twice for Qd (1) and Qd (2) - declare - -- Local lemmas - - procedure Prove_First_Iteration (X1, X2, X3, X4 : Single_Uns) - with - Ghost, - Pre => X1 = 0, - Post => - Big_2xxSingle * Big3 (X1, X2, X3) + Big (Double_Uns (X4)) - = Big3 (X2, X3, X4); - - --------------------------- - -- Prove_First_Iteration -- - --------------------------- - - procedure Prove_First_Iteration (X1, X2, X3, X4 : Single_Uns) is - null; - - -- Local ghost variables - - Qd1 : Single_Uns := 0 with Ghost; - D234 : Big_Integer with Ghost, Relaxed_Initialization; - D123 : constant Big_Integer := Big3 (D (1), D (2), D (3)) - with Ghost; - D4 : constant Big_Integer := Big (Double_Uns (D (4))) - with Ghost; - - begin - Prove_Scaled_Mult_Decomposition_Regroup3 - (D (1), D (2), D (3), D (4)); - pragma Assert - (By (Mult * Big_2xx (Scale) = Big_2xxSingle * D123 + D4, - Is_Scaled_Mult_Decomposition (0, 0, D123, D4))); - - for J in 1 .. 2 loop - Lemma_Hi_Lo (D (J) & D (J + 1), D (J), D (J + 1)); - pragma Assert (Big (D (J) & D (J + 1)) < Big (Zu)); - - -- Compute next quotient digit. We have to divide three digits - -- by two digits. We estimate the quotient by dividing the - -- leading two digits by the leading digit. Given the scaling - -- we did above which ensured the first bit of the divisor is - -- set, this gives an estimate of the quotient that is at most - -- two too high. - - if D (J) > Zhi then - Lemma_Lt_Commutation (Zu, D (J) & D (J + 1)); - pragma Assert (False); - - elsif D (J) = Zhi then - Qd (J) := Single_Uns'Last; - - Lemma_Concat_Definition (D (J), D (J + 1)); - Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 2)); - pragma Assert (Big_2xxSingle > Big (Double_Uns (D (J + 2)))); - pragma Assert - (By (Big3 (D (J), D (J + 1), 0) + Big_2xxSingle - > Big3 (D (J), D (J + 1), D (J + 2)), - Big3 (D (J), D (J + 1), 0) = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (J))) - + Big_2xxSingle * Big (Double_Uns (D (J + 1))))); - pragma Assert (Big (Double_Uns'(0)) = 0); - pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle = - Big_2xxSingle * (Big_2xxSingle * Big (Double_Uns (D (J))) - + Big (Double_Uns (D (J + 1))))); - pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (J))) - + Big_2xxSingle * Big (Double_Uns (D (J + 1)))); - pragma Assert (Big (D (J) & D (J + 1)) * Big_2xxSingle - = Big3 (D (J), D (J + 1), 0)); - pragma Assert ((Big (D (J) & D (J + 1)) + 1) * Big_2xxSingle - = Big3 (D (J), D (J + 1), 0) + Big_2xxSingle); - Lemma_Gt_Mult (Big (Zu), Big (D (J) & D (J + 1)) + 1, - Big_2xxSingle, - Big3 (D (J), D (J + 1), D (J + 2))); - Lemma_Div_Lt - (Big3 (D (J), D (J + 1), D (J + 2)), - Big_2xxSingle, Big (Zu)); - pragma Assert - (By (Big (Double_Uns (Qd (J))) >= - Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu), - Big (Double_Uns (Qd (J))) = Big_2xxSingle - 1)); - - else - Qd (J) := Lo ((D (J) & D (J + 1)) / Zhi); - - Prove_Qd_Calculation_Part_1 (J); - end if; - - pragma Assert (for all K in 1 .. J => Qd (K)'Initialized); - Lemma_Div_Mult (Big3 (D (J), D (J + 1), D (J + 2)), Big (Zu)); - Lemma_Gt_Mult - (Big (Double_Uns (Qd (J))), - Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu), - Big (Zu), Big3 (D (J), D (J + 1), D (J + 2)) - Big (Zu)); - - -- Compute amount to subtract - - T1 := Qd (J) * Zlo; - T2 := Qd (J) * Zhi; - S3 := Lo (T1); - T3 := Hi (T1) + Lo (T2); - S2 := Lo (T3); - S1 := Hi (T3) + Hi (T2); - - Prove_Multiplication (Qd (J)); - - -- Adjust quotient digit if it was too high - - -- We use the version of the algorithm in the 2nd Edition - -- of "The Art of Computer Programming". This had a bug not - -- discovered till 1995, see Vol 2 errata: - -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz. - -- Under rare circumstances the expression in the test could - -- overflow. This version was further corrected in 2005, see - -- Vol 2 errata: - -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz. - -- This implementation is not impacted by these bugs, due - -- to the use of a word-size comparison done in function Le3 - -- instead of a comparison on two-word integer quantities in - -- the original algorithm. - - Lemma_Hi_Lo_3 (Zu, Zhi, Zlo); - - while not Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) loop - pragma Loop_Invariant - (Qd (1)'Initialized - and (if J = 2 then Qd (2)'Initialized)); - pragma Loop_Invariant (if J = 2 then Qd (1) = Qd1); - pragma Loop_Invariant - (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu)); - pragma Loop_Invariant - (Big3 (S1, S2, S3) > Big3 (D (J), D (J + 1), D (J + 2))); - pragma Assert (Big3 (S1, S2, S3) > 0); - if Qd (J) = 0 then - pragma Assert (Big3 (S1, S2, S3) = 0); - pragma Assert (False); - end if; - Lemma_Ge_Commutation (Double_Uns (Qd (J)), 1); - Lemma_Ge_Mult - (Big (Double_Uns (Qd (J))), 1, Big (Zu), Big (Zu)); - - Sub3 (S1, S2, S3, 0, Zhi, Zlo); - - pragma Assert - (Big3 (S1, S2, S3) > - Big3 (D (J), D (J + 1), D (J + 2)) - Big (Zu)); - Lemma_Subtract_Commutation (Double_Uns (Qd (J)), 1); - pragma Assert (Double_Uns (Qd (J)) - Double_Uns'(1) - = Double_Uns (Qd (J) - 1)); - pragma Assert (Big (Double_Uns'(1)) = 1); - - declare - Prev : constant Single_Uns := Qd (J) with Ghost; - begin - Qd (J) := Qd (J) - 1; - Lemma_Substitution (Big3 (S1, S2, S3), Big (Zu), - Big (Double_Uns (Prev)) - 1, - Big (Double_Uns (Qd (J))), 0); - end; - - pragma Assert - (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu)); - end loop; - - pragma Assert_And_Cut - (Qd (1)'Initialized - and then (if J = 2 then Qd (2)'Initialized and Qd (1) = Qd1) - and then D'Initialized - and then (if J = 2 then D234'Initialized) - and then Big3 (D (J), D (J + 1), D (J + 2)) = - (if J = 1 then D123 else D234) - and then (if J = 1 then D4 = Big (Double_Uns (D (4)))) - and then Big3 (S1, S2, S3) = - Big (Double_Uns (Qd (J))) * Big (Zu) - and then Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) - and then Big3 (D (J), D (J + 1), D (J + 2)) - - Big3 (S1, S2, S3) < Big (Zu)); - - -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step - - Inline_Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)); - - declare - D4_G : constant Single_Uns := D (4) with Ghost; - begin - Sub3 (D (J), D (J + 1), D (J + 2), S1, S2, S3); - pragma Assert (if J = 1 then D (4) = D4_G); - pragma Assert - (By - (D'Initialized, - D (1)'Initialized and D (2)'Initialized - and D (3)'Initialized and D (4)'Initialized)); - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) = - (if J = 1 then D123 else D234) - - Big3 (S1, S2, S3)); - end; - - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) < Big (Zu)); - - if D (J) > 0 then - Lemma_Double_Big_2xxSingle; - pragma Assert (Big3 (D (J), D (J + 1), D (J + 2)) = - Big_2xxSingle - * Big_2xxSingle * Big (Double_Uns (D (J))) - + Big_2xxSingle * Big (Double_Uns (D (J + 1))) - + Big (Double_Uns (D (J + 2)))); - pragma Assert (Big_2xxSingle >= 0); - Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 1)); - pragma Assert (Big (Double_Uns (D (J + 1))) >= 0); - Lemma_Mult_Non_Negative - (Big_2xxSingle, Big (Double_Uns (D (J + 1)))); - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) >= - Big_2xxSingle * Big_2xxSingle - * Big (Double_Uns (D (J)))); - Lemma_Ge_Commutation (Double_Uns (D (J)), Double_Uns'(1)); - Lemma_Ge_Mult (Big (Double_Uns (D (J))), - Big (Double_Uns'(1)), - Big_2xxDouble, - Big (Double_Uns'(1)) * Big_2xxDouble); - pragma Assert - (Big_2xxDouble * Big (Double_Uns'(1)) = Big_2xxDouble); - pragma Assert - (Big3 (D (J), D (J + 1), D (J + 2)) >= Big_2xxDouble); - pragma Assert (False); - end if; - - if J = 1 then - Qd1 := Qd (1); - D234 := Big3 (D (2), D (3), D (4)); - pragma Assert (D4 = Big (Double_Uns (D (4)))); - Lemma_Substitution - (Mult * Big_2xx (Scale), Big_2xxSingle, D123, - Big3 (D (1), D (2), D (3)) + Big3 (S1, S2, S3), - Big (Double_Uns (D (4)))); - Prove_First_Iteration (D (1), D (2), D (3), D (4)); - Lemma_Substitution (Mult * Big_2xx (Scale), Big_2xxSingle, - Big3 (S1, S2, S3), - Big (Double_Uns (Qd1)) * Big (Zu), - D234); - else - pragma Assert (Qd1 = Qd (1)); - pragma Assert - (By (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + Big (Double_Uns (Qd (2))) * Big (Zu) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))), - By (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + Big3 (D (2), D (3), D (4)) + Big3 (S1, S2, S3), - Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + D234))); - - end if; + for J in 1 .. 2 loop + -- Compute next quotient digit. We have to divide three digits + -- by two digits. We estimate the quotient by dividing the + -- leading two digits by the leading digit. Given the scaling + -- we did above which ensured the first bit of the divisor is + -- set, this gives an estimate of the quotient that is at most + -- two too high. + + pragma Assert (D (J) <= Zhi); + + if D (J) = Zhi then + Qd (J) := Single_Uns'Last; + else + Qd (J) := Lo ((D (J) & D (J + 1)) / Zhi); + end if; + + -- Compute amount to subtract + + T1 := Qd (J) * Zlo; + T2 := Qd (J) * Zhi; + S3 := Lo (T1); + T3 := Hi (T1) + Lo (T2); + S2 := Lo (T3); + S1 := Hi (T3) + Hi (T2); + + -- Adjust quotient digit if it was too high + + -- We use the version of the algorithm in the 2nd Edition + -- of "The Art of Computer Programming". This had a bug not + -- discovered till 1995, see Vol 2 errata: + -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz. + -- Under rare circumstances the expression in the test could + -- overflow. This version was further corrected in 2005, see + -- Vol 2 errata: + -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz. + -- This implementation is not impacted by these bugs, due + -- to the use of a word-size comparison done in function Le3 + -- instead of a comparison on two-word integer quantities in + -- the original algorithm. + + while not Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) loop + Sub3 (S1, S2, S3, 0, Zhi, Zlo); + Qd (J) := Qd (J) - 1; end loop; - pragma Assert_And_Cut - (Qd (1)'Initialized and then Qd (2)'Initialized - and then D'Initialized - and then Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))) < Big (Zu) - and then Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) - + Big (Double_Uns (Qd (2))) * Big (Zu) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); - end; + -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step + + Sub3 (D (J), D (J + 1), D (J + 2), S1, S2, S3); + end loop; -- The two quotient digits are now set, and the remainder of the -- scaled division is in D3&D4. To get the remainder for the @@ -3321,271 +570,68 @@ is Qu := Qd (1) & Qd (2); Ru := D (3) & D (4); - Lemma_Hi_Lo (Qu, Qd (1), Qd (2)); - Lemma_Hi_Lo (Ru, D (3), D (4)); - Lemma_Substitution - (Mult * Big_2xx (Scale), Big (Zu), - Big_2xxSingle * Big (Double_Uns (Qd (1))) - + Big (Double_Uns (Qd (2))), - Big (Qu), Big (Ru)); - Prove_Rescaling; - Ru := Shift_Right (Ru, Scale); - declare - -- Local lemma required to help automatic provers - procedure Lemma_Div_Congruent - (X, Y : Big_Natural; - Z : Big_Positive) - with - Ghost, - Pre => X = Y, - Post => X / Z = Y / Z; - - procedure Lemma_Div_Congruent - (X, Y : Big_Natural; - Z : Big_Positive) - is null; - - begin - Lemma_Shift_Right (Zu, Scale); - Lemma_Div_Congruent (Big (Zu), - Big (Double_Uns'(abs Z)) * Big_2xx (Scale), - Big_2xx (Scale)); - - Zu := Shift_Right (Zu, Scale); - - Lemma_Simplify (Big (Double_Uns'(abs Z)), Big_2xx (Scale)); - pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z))); - end; + Zu := Shift_Right (Zu, Scale); end if; - pragma Assert (Big (Ru) = abs Big_R); - pragma Assert (Big (Qu) = abs Quot); - pragma Assert (Big (Zu) = Big (Double_Uns'(abs Z))); - -- Deal with rounding case if Round then - Prove_Rounding_Case; - if Ru > (Zu - Double_Uns'(1)) / Double_Uns'(2) then - pragma Assert (abs Big_Q = Big (Qu) + 1); - -- Protect against wrapping around when rounding, by signaling -- an overflow when the quotient is too large. if Qu = Double_Uns'Last then - Prove_Q_Too_Big; Raise_Error; end if; - Lemma_Add_One (Qu); - Qu := Qu + Double_Uns'(1); end if; end if; - pragma Assert (Big (Qu) = abs Big_Q); - -- Set final signs (RM 4.5.5(27-30)) -- Case of dividend (X * Y) sign positive if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then - Prove_Positive_Dividend; - R := To_Pos_Int (Ru); Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); -- Case of dividend (X * Y) sign negative else - Prove_Negative_Dividend; - R := To_Neg_Int (Ru); Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); end if; - - Prove_Sign_R; - Prove_Signs; end Scaled_Divide; - pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_Cyclomatic_Complexity"); ---------- -- Sub3 -- ---------- procedure Sub3 (X1, X2, X3 : in out Single_Uns; Y1, Y2, Y3 : Single_Uns) is - - -- Local ghost variables - - XX1 : constant Single_Uns := X1 with Ghost; - XX2 : constant Single_Uns := X2 with Ghost; - XX3 : constant Single_Uns := X3 with Ghost; - - -- Local lemmas - - procedure Lemma_Add3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => X1 <= Single_Uns'Last - Y1 - and then X2 <= Single_Uns'Last - Y2 - and then X3 <= Single_Uns'Last - Y3, - Post => Big3 (X1 + Y1, X2 + Y2, X3 + Y3) - = Big3 (X1, X2, X3) + Big3 (Y1, Y2, Y3); - - procedure Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => Big3 (X1, X2, X3) >= Big3 (Y1, Y2, Y3), - Post => X1 > Y1 - or else (X1 = Y1 and then X2 > Y2) - or else (X1 = Y1 and then X2 = Y2 and then X3 >= Y3); - - procedure Lemma_Sub3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) - with - Ghost, - Pre => X1 >= Y1 and then X2 >= Y2 and then X3 >= Y3, - Post => Big3 (X1 - Y1, X2 - Y2, X3 - Y3) - = Big3 (X1, X2, X3) - Big3 (Y1, Y2, Y3); - - procedure Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2 : Single_Uns) - with - Ghost, - Pre => X2 < Y2, - Post => Big3 (X1, X2 - Y2, X3) - = Big3 (X1, X2, X3) + Big3 (Single_Uns'(1), 0, 0) - Big3 (0, Y2, 0); - - procedure Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3 : Single_Uns) - with - Ghost, - Pre => X3 < Y3, - Post => Big3 (X1, X2, X3 - Y3) - = Big3 (X1, X2, X3) + Big3 (Single_Uns'(0), 1, 0) - Big3 (0, 0, Y3); - - ------------------------- - -- Lemma_Add3_No_Carry -- - ------------------------- - - procedure Lemma_Add3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is - begin - Lemma_Add_Commutation (Double_Uns (X1), Y1); - Lemma_Add_Commutation (Double_Uns (X2), Y2); - Lemma_Add_Commutation (Double_Uns (X3), Y3); - end Lemma_Add3_No_Carry; - - --------------------- - -- Lemma_Ge_Expand -- - --------------------- - - procedure Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is null; - - ------------------------- - -- Lemma_Sub3_No_Carry -- - ------------------------- - - procedure Lemma_Sub3_No_Carry (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) is - begin - Lemma_Subtract_Commutation (Double_Uns (X1), Double_Uns (Y1)); - Lemma_Subtract_Commutation (Double_Uns (X2), Double_Uns (Y2)); - Lemma_Subtract_Commutation (Double_Uns (X3), Double_Uns (Y3)); - end Lemma_Sub3_No_Carry; - - ---------------------------- - -- Lemma_Sub3_With_Carry2 -- - ---------------------------- - - procedure Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2 : Single_Uns) is - pragma Unreferenced (X1, X3); - begin - Lemma_Add_Commutation - (Double_Uns'(2 ** Single_Size) - Double_Uns (Y2), X2); - Lemma_Subtract_Commutation - (Double_Uns'(2 ** Single_Size), Double_Uns (Y2)); - end Lemma_Sub3_With_Carry2; - - ---------------------------- - -- Lemma_Sub3_With_Carry3 -- - ---------------------------- - - procedure Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3 : Single_Uns) is - pragma Unreferenced (X1, X2); - begin - Lemma_Add_Commutation - (Double_Uns'(2 ** Single_Size) - Double_Uns (Y3), X3); - Lemma_Subtract_Commutation - (Double_Uns'(2 ** Single_Size), Double_Uns (Y3)); - end Lemma_Sub3_With_Carry3; - - -- Start of processing for Sub3 - begin - Lemma_Ge_Expand (X1, X2, X3, Y1, Y2, Y3); - if Y3 > X3 then if X2 = 0 then pragma Assert (X1 >= 1); - Lemma_Sub3_No_Carry (X1, X2, X3, 1, 0, 0); X1 := X1 - 1; - - pragma Assert - (Big3 (X1, X2, X3) = - Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(1), 0, 0)); - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (Single_Uns'(0), Single_Uns'Last, 0) - - Big3 (Single_Uns'(0), 1, 0)); - Lemma_Add3_No_Carry (X1, X2, X3, 0, Single_Uns'Last, 0); - else - Lemma_Sub3_No_Carry (X1, X2, X3, 0, 1, 0); end if; X2 := X2 - 1; - - pragma Assert - (Big3 (X1, X2, X3) = - Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(0), 1, 0)); - Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3); - else - Lemma_Sub3_No_Carry (X1, X2, X3, 0, 0, Y3); end if; X3 := X3 - Y3; - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (0, 0, Y3)); - if Y2 > X2 then pragma Assert (X1 >= 1); - Lemma_Sub3_No_Carry (X1, X2, X3, 1, 0, 0); X1 := X1 - 1; - - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (0, 0, Y3) - Big3 (Single_Uns'(1), 0, 0)); - Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2); - else - Lemma_Sub3_No_Carry (X1, X2, X3, 0, Y2, 0); end if; X2 := X2 - Y2; - - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (0, Y2, Y3)); - pragma Assert (X1 >= Y1); - Lemma_Sub3_No_Carry (X1, Y2, X3, Y1, 0, 0); - X1 := X1 - Y1; - - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (0, Y2, Y3) - Big3 (Y1, 0, 0)); - Lemma_Add3_No_Carry (0, Y2, Y3, Y1, 0, 0); - pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (Y1, Y2, Y3)); end Sub3; ------------------------------- @@ -3594,128 +640,18 @@ is function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int is R : constant Double_Int := To_Int (To_Uns (X) - To_Uns (Y)); - - -- Local lemmas - - procedure Prove_Negative_X - with - Ghost, - Pre => X < 0 and then (Y <= 0 or else R < 0), - Post => R = X - Y; - - procedure Prove_Non_Negative_X - with - Ghost, - Pre => X >= 0 and then (Y > 0 or else R >= 0), - Post => R = X - Y; - - procedure Prove_Overflow_Case - with - Ghost, - Pre => - (if X >= 0 then Y <= 0 and then R < 0 - else Y > 0 and then R >= 0), - Post => not In_Double_Int_Range (Big (X) - Big (Y)); - - ---------------------- - -- Prove_Negative_X -- - ---------------------- - - procedure Prove_Negative_X is - begin - if X = Double_Int'First then - if Y = Double_Int'First or else Y > 0 then - null; - else - pragma Assert - (To_Uns (X) - To_Uns (Y) = - 2 ** (Double_Size - 1) + Double_Uns (-Y)); - end if; - - elsif Y >= 0 or else Y = Double_Int'First then - null; - - else - pragma Assert - (To_Uns (X) - To_Uns (Y) = -Double_Uns (-X) + Double_Uns (-Y)); - end if; - end Prove_Negative_X; - - -------------------------- - -- Prove_Non_Negative_X -- - -------------------------- - - procedure Prove_Non_Negative_X is - begin - if Y > 0 then - declare - Ru : constant Double_Uns := To_Uns (X) - To_Uns (Y); - begin - pragma Assert (Ru = Double_Uns (X) - Double_Uns (Y)); - if Ru < 2 ** (Double_Size - 1) then -- R >= 0 - pragma Assert (To_Uns (Y) <= To_Uns (X)); - Lemma_Subtract_Double_Uns (X => Y, Y => X); - pragma Assert (Ru = Double_Uns (X - Y)); - - elsif Ru = 2 ** (Double_Size - 1) then - pragma Assert (Double_Uns (Y) < 2 ** (Double_Size - 1)); - pragma Assert (False); - - else - pragma Assert - (R = -Double_Int (-(Double_Uns (X) - Double_Uns (Y)))); - pragma Assert - (R = -Double_Int (-Double_Uns (X) + Double_Uns (Y))); - pragma Assert - (R = -Double_Int (Double_Uns (Y) - Double_Uns (X))); - end if; - end; - - elsif Y = Double_Int'First then - pragma Assert - (To_Uns (X) - To_Uns (Y) = - Double_Uns (X) - 2 ** (Double_Size - 1)); - pragma Assert (False); - - else - pragma Assert - (To_Uns (X) - To_Uns (Y) = Double_Uns (X) + Double_Uns (-Y)); - end if; - end Prove_Non_Negative_X; - - ------------------------- - -- Prove_Overflow_Case -- - ------------------------- - - procedure Prove_Overflow_Case is - begin - if X >= 0 and then Y /= Double_Int'First then - pragma Assert - (To_Uns (X) - To_Uns (Y) = Double_Uns (X) + Double_Uns (-Y)); - - elsif X < 0 and then X /= Double_Int'First then - pragma Assert - (To_Uns (X) - To_Uns (Y) = -Double_Uns (-X) - Double_Uns (Y)); - end if; - end Prove_Overflow_Case; - - -- Start of processing for Subtract_With_Ovflo_Check - begin if X >= 0 then if Y > 0 or else R >= 0 then - Prove_Non_Negative_X; return R; end if; else -- X < 0 if Y <= 0 or else R < 0 then - Prove_Negative_X; return R; end if; end if; - Prove_Overflow_Case; Raise_Error; end Subtract_With_Ovflo_Check; @@ -3752,5 +688,3 @@ is pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end System.Arith_Double; - -pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_LSLOC"); diff --git a/gcc/ada/libgnat/s-aridou.ads b/gcc/ada/libgnat/s-aridou.ads index 5524cd0..f7240de 100644 --- a/gcc/ada/libgnat/s-aridou.ads +++ b/gcc/ada/libgnat/s-aridou.ads @@ -33,8 +33,6 @@ -- double word signed integer values in cases where either overflow checking -- is required, or intermediate results are longer than the result type. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic type Double_Int is range <>; @@ -55,51 +53,7 @@ generic package System.Arith_Double with Pure, SPARK_Mode is - -- Preconditions in this unit are meant for analysis only, not for run-time - -- checking, so that the expected exceptions are raised. This is enforced - -- by setting the corresponding assertion policy to Ignore. Postconditions - -- and contract cases should not be executed at runtime as well, in order - -- not to slow down the execution of these functions. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - subtype Big_Natural is BI_Ghost.Big_Natural with Ghost; - subtype Big_Positive is BI_Ghost.Big_Positive with Ghost; - use type BI_Ghost.Big_Integer; - - package Signed_Conversion is - new BI_Ghost.Signed_Conversions (Int => Double_Int); - - function Big (Arg : Double_Int) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - package Unsigned_Conversion is - new BI_Ghost.Unsigned_Conversions (Int => Double_Uns); - - function Big (Arg : Double_Uns) return Big_Integer is - (Unsigned_Conversion.To_Big_Integer (Arg)) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - function In_Double_Int_Range (Arg : Big_Integer) return Boolean is - (BI_Ghost.In_Range (Arg, Big (Double_Int'First), Big (Double_Int'Last))) - with - Ghost, - Annotate => (GNATprove, Inline_For_Proof); - - function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int - with - Pre => In_Double_Int_Range (Big (X) + Big (Y)), - Post => Add_With_Ovflo_Check'Result = X + Y; + function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int; -- Raises Constraint_Error if sum of operands overflows Double_Int, -- otherwise returns this sum of operands as Double_Int. -- @@ -114,10 +68,7 @@ is -- the exception *Constraint_Error* is raised; otherwise the result is -- correct. - function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int - with - Pre => In_Double_Int_Range (Big (X) - Big (Y)), - Post => Subtract_With_Ovflo_Check'Result = X - Y; + function Subtract_With_Ovflo_Check (X, Y : Double_Int) return Double_Int; -- Raises Constraint_Error if difference of operands overflows Double_Int, -- otherwise returns this difference of operands as Double_Int. -- @@ -127,10 +78,7 @@ is -- overflow. function Multiply_With_Ovflo_Check (X, Y : Double_Int) return Double_Int - with - Pre => In_Double_Int_Range (Big (X) * Big (Y)), - Post => Multiply_With_Ovflo_Check'Result = X * Y; - pragma Convention (C, Multiply_With_Ovflo_Check); + with Convention => C; -- Raises Constraint_Error if product of operands overflows Double_Int, -- otherwise returns this product of operands as Double_Int. The code -- generator may also generate direct calls to this routine. @@ -140,40 +88,10 @@ is -- signed value is returned. Overflow check is performed by looking at -- higher digits. - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Double_Int'(0)) - or else Y = Big (Double_Int'(0)) - or else (X < Big (Double_Int'(0))) = (Y < Big (Double_Int'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is - (if abs R > (abs Y - Big (Double_Int'(1))) / Big (Double_Int'(2)) then - (if Same_Sign (X, Y) then Q + Big (Double_Int'(1)) - else Q - Big (Double_Int'(1))) - else - Q) - with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y; - procedure Scaled_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Double_Int_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient -- in ``Q`` and the remainder in ``R``. -- @@ -204,22 +122,7 @@ is procedure Double_Divide (X, Y, Z : Double_Int; Q, R : out Double_Int; - Round : Boolean) - with - Pre => Y /= 0 - and then Z /= 0 - and then In_Double_Int_Range - (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z))) - else Big (X) / (Big (Y) * Big (Z))), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), Big (R)) - else - Big (Q) = Big (X) / (Big (Y) * Big (Z))); + Round : Boolean); -- Performs the division ``X`` / (``Y`` * ``Z``), storing the quotient in -- ``Q`` and the remainder in ``R``. Constraint_Error is raised if ``Y`` or -- ``Z`` is zero, or if the quotient does not fit in ``Double_Int``. diff --git a/gcc/ada/libgnat/s-arit128.adb b/gcc/ada/libgnat/s-arit128.adb index b9fcbd9..c4ef40d 100644 --- a/gcc/ada/libgnat/s-arit128.adb +++ b/gcc/ada/libgnat/s-arit128.adb @@ -34,7 +34,6 @@ with System.Arith_Double; package body System.Arith_128 with SPARK_Mode is - subtype Uns128 is Interfaces.Unsigned_128; subtype Uns64 is Interfaces.Unsigned_64; diff --git a/gcc/ada/libgnat/s-arit128.ads b/gcc/ada/libgnat/s-arit128.ads index 9181f0b..ea4ef6b 100644 --- a/gcc/ada/libgnat/s-arit128.ads +++ b/gcc/ada/libgnat/s-arit128.ads @@ -36,102 +36,31 @@ pragma Restrictions (No_Elaboration_Code); -- Allow direct call from gigi generated code --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; with Interfaces; package System.Arith_128 with Pure, SPARK_Mode is - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; - use type Interfaces.Integer_128; - subtype Int128 is Interfaces.Integer_128; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Signed_Conversion is new - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions - (Int => Int128); - - function Big (Arg : Int128) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int128_Range (Arg : Big_Integer) return Boolean is - (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range - (Arg, Big (Int128'First), Big (Int128'Last))) - with Ghost; - - function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128 - with - Pre => In_Int128_Range (Big (X) + Big (Y)), - Post => Add_With_Ovflo_Check128'Result = X + Y; + function Add_With_Ovflo_Check128 (X, Y : Int128) return Int128; -- Raises Constraint_Error if sum of operands overflows 128 bits, -- otherwise returns the 128-bit signed integer sum. - function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128 - with - Pre => In_Int128_Range (Big (X) - Big (Y)), - Post => Subtract_With_Ovflo_Check128'Result = X - Y; + function Subtract_With_Ovflo_Check128 (X, Y : Int128) return Int128; -- Raises Constraint_Error if difference of operands overflows 128 -- bits, otherwise returns the 128-bit signed integer difference. - function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128 - with - Pre => In_Int128_Range (Big (X) * Big (Y)), - Post => Multiply_With_Ovflo_Check128'Result = X * Y; + function Multiply_With_Ovflo_Check128 (X, Y : Int128) return Int128; pragma Export (C, Multiply_With_Ovflo_Check128, "__gnat_mulv128"); -- Raises Constraint_Error if product of operands overflows 128 -- bits, otherwise returns the 128-bit signed integer product. -- The code generator may also generate direct calls to this routine. - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Int128'(0)) - or else Y = Big (Int128'(0)) - or else (X < Big (Int128'(0))) = (Y < Big (Int128'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is - (if abs R > (abs Y - Big (Int128'(1))) / Big (Int128'(2)) then - (if Same_Sign (X, Y) then Q + Big (Int128'(1)) - else Q - Big (Int128'(1))) - else - Q) - with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y; - procedure Scaled_Divide128 (X, Y, Z : Int128; Q, R : out Int128; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Int128_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (X * Y) / Z, storing the quotient in Q -- and the remainder in R. Constraint_Error is raised if Z is zero, -- or if the quotient does not fit in 128 bits. Round indicates if @@ -143,22 +72,7 @@ is procedure Double_Divide128 (X, Y, Z : Int128; Q, R : out Int128; - Round : Boolean) - with - Pre => Y /= 0 - and then Z /= 0 - and then In_Int128_Range - (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z))) - else Big (X) / (Big (Y) * Big (Z))), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), Big (R)) - else - Big (Q) = Big (X) / (Big (Y) * Big (Z))); + Round : Boolean); -- Performs the division X / (Y * Z), storing the quotient in Q and -- the remainder in R. Constraint_Error is raised if Y or Z is zero, -- or if the quotient does not fit in 128 bits. Round indicates if the diff --git a/gcc/ada/libgnat/s-arit32.adb b/gcc/ada/libgnat/s-arit32.adb index 91082e7..0cc88ed 100644 --- a/gcc/ada/libgnat/s-arit32.adb +++ b/gcc/ada/libgnat/s-arit32.adb @@ -34,20 +34,11 @@ -- would be too costly otherwise. This is enforced by setting the assertion -- policy to Ignore. -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; with Ada.Unchecked_Conversion; package body System.Arith_32 with SPARK_Mode is - pragma Suppress (Overflow_Check); pragma Suppress (Range_Check); @@ -58,33 +49,6 @@ is function To_Int is new Ada.Unchecked_Conversion (Uns32, Int32); - package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns32); - - function Big (Arg : Uns32) return Big_Integer is - (Unsigned_Conversion.To_Big_Integer (Arg)) - with Ghost; - - package Unsigned_Conversion_64 is new Unsigned_Conversions (Int => Uns64); - - function Big (Arg : Uns64) return Big_Integer is - (Unsigned_Conversion_64.To_Big_Integer (Arg)) - with Ghost; - - pragma Warnings - (Off, "non-preelaborable call not allowed in preelaborated unit", - Reason => "Ghost code is not compiled"); - Big_0 : constant Big_Integer := - Big (Uns32'(0)) - with Ghost; - Big_2xx32 : constant Big_Integer := - Big (Uns32'(2 ** 32 - 1)) + 1 - with Ghost; - Big_2xx64 : constant Big_Integer := - Big (Uns64'(2 ** 64 - 1)) + 1 - with Ghost; - pragma Warnings - (On, "non-preelaborable call not allowed in preelaborated unit"); - ----------------------- -- Local Subprograms -- ----------------------- @@ -96,166 +60,23 @@ is -- Convert absolute value of X to unsigned. Note that we can't just use -- the expression of the Else since it overflows for X = Int32'First. - function Lo (A : Uns64) return Uns32 is (Uns32 (A and (2 ** 32 - 1))); - -- Low order half of 64-bit value - function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32))); -- High order half of 64-bit value - function To_Neg_Int (A : Uns32) return Int32 - with - Pre => In_Int32_Range (-Big (A)), - Post => Big (To_Neg_Int'Result) = -Big (A); + function To_Neg_Int (A : Uns32) return Int32; -- Convert to negative integer equivalent. If the input is in the range -- 0 .. 2**31, then the corresponding nonpositive signed integer (obtained -- by negating the given value) is returned, otherwise constraint error is -- raised. - function To_Pos_Int (A : Uns32) return Int32 - with - Pre => In_Int32_Range (Big (A)), - Post => Big (To_Pos_Int'Result) = Big (A); + function To_Pos_Int (A : Uns32) return Int32; -- Convert to positive integer equivalent. If the input is in the range -- 0 .. 2**31 - 1, then the corresponding nonnegative signed integer is -- returned, otherwise constraint error is raised. - procedure Raise_Error with - Always_Terminates, - Exceptional_Cases => (Constraint_Error => True); - pragma No_Return (Raise_Error); + procedure Raise_Error with No_Return; -- Raise constraint error with appropriate message - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Abs_Commutation (X : Int32) - with - Ghost, - Post => abs Big (X) = Big (Uns32'(abs X)); - - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X / Y) = abs X / abs Y; - - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) - with - Ghost, - Post => abs (X * Y) = abs X * abs Y; - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => abs (X rem Y) = (abs X) rem (abs Y); - - procedure Lemma_Div_Commutation (X, Y : Uns64) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Z > 0 and then X >= Y * Z, - Post => X / Z >= Y; - - procedure Lemma_Ge_Commutation (A, B : Uns32) - with - Ghost, - Pre => A >= B, - Post => Big (A) >= Big (B); - - procedure Lemma_Hi_Lo (Xu : Uns64; Xhi, Xlo : Uns32) - with - Ghost, - Pre => Xhi = Hi (Xu) and Xlo = Lo (Xu), - Post => Big (Xu) = Big_2xx32 * Big (Xhi) + Big (Xlo); - - procedure Lemma_Mult_Commutation (X, Y, Z : Uns64) - with - Ghost, - Pre => Big (X) * Big (Y) < Big_2xx64 and then Z = X * Y, - Post => Big (X) * Big (Y) = Big (Z); - - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) - with - Ghost, - Pre => (X >= Big_0 and then Y >= Big_0) - or else (X <= Big_0 and then Y <= Big_0), - Post => X * Y >= Big_0; - - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) - with - Ghost, - Pre => (X <= Big_0 and then Y >= Big_0) - or else (X >= Big_0 and then Y <= Big_0), - Post => X * Y <= Big_0; - - procedure Lemma_Neg_Rem (X, Y : Big_Integer) - with - Ghost, - Pre => Y /= 0, - Post => X rem Y = X rem (-Y); - - procedure Lemma_Not_In_Range_Big2xx32 - with - Post => not In_Int32_Range (Big_2xx32) - and then not In_Int32_Range (-Big_2xx32); - - procedure Lemma_Rem_Commutation (X, Y : Uns64) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) rem Big (Y) = Big (X rem Y); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Abs_Commutation (X : Int32) is null; - procedure Lemma_Abs_Div_Commutation (X, Y : Big_Integer) is null; - procedure Lemma_Abs_Mult_Commutation (X, Y : Big_Integer) is null; - procedure Lemma_Div_Commutation (X, Y : Uns64) is null; - procedure Lemma_Div_Ge (X, Y, Z : Big_Integer) is null; - procedure Lemma_Ge_Commutation (A, B : Uns32) is null; - procedure Lemma_Mult_Commutation (X, Y, Z : Uns64) is null; - procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) is null; - procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) is null; - procedure Lemma_Neg_Rem (X, Y : Big_Integer) is null; - procedure Lemma_Not_In_Range_Big2xx32 is null; - procedure Lemma_Rem_Commutation (X, Y : Uns64) is null; - - ------------------------------- - -- Lemma_Abs_Rem_Commutation -- - ------------------------------- - - procedure Lemma_Abs_Rem_Commutation (X, Y : Big_Integer) is - begin - if Y < 0 then - Lemma_Neg_Rem (X, Y); - if X < 0 then - pragma Assert (X rem Y = -((-X) rem (-Y))); - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - else - pragma Assert (abs (X rem Y) = (abs X) rem (abs Y)); - end if; - end if; - end Lemma_Abs_Rem_Commutation; - - ----------------- - -- Lemma_Hi_Lo -- - ----------------- - - procedure Lemma_Hi_Lo (Xu : Uns64; Xhi, Xlo : Uns32) is - begin - pragma Assert (Uns64 (Xhi) = Xu / Uns64'(2 ** 32)); - pragma Assert (Uns64 (Xlo) = Xu mod 2 ** 32); - end Lemma_Hi_Lo; - ----------------- -- Raise_Error -- ----------------- @@ -263,9 +84,6 @@ is procedure Raise_Error is begin raise Constraint_Error with "32-bit arithmetic overflow"; - pragma Annotate - (GNATprove, Intentional, "exception might be raised", - "Procedure Raise_Error is called to signal input errors"); end Raise_Error; ------------------- @@ -288,197 +106,20 @@ is Ru : Uns32; -- Unsigned quotient and remainder - -- Local ghost variables - - Mult : constant Big_Integer := abs (Big (X) * Big (Y)) with Ghost; - Quot : Big_Integer with Ghost; - Big_R : Big_Integer with Ghost; - Big_Q : Big_Integer with Ghost; - - -- Local lemmas - - procedure Prove_Negative_Dividend - with - Ghost, - Pre => Z /= 0 - and then ((X >= 0 and Y < 0) or (X < 0 and Y >= 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => - (if Z > 0 then Big_Q <= Big_0 else Big_Q >= Big_0); - -- Proves the sign of rounded quotient when dividend is non-positive - - procedure Prove_Overflow - with - Ghost, - Pre => Z /= 0 and then Mult >= Big_2xx32 * Big (Uns32'(abs Z)), - Post => not In_Int32_Range (Big (X) * Big (Y) / Big (Z)) - and then not In_Int32_Range - (Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z))); - -- Proves overflow case - - procedure Prove_Positive_Dividend - with - Ghost, - Pre => Z /= 0 - and then ((X >= 0 and Y >= 0) or (X < 0 and Y < 0)) - and then Big_Q = - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => - (if Z > 0 then Big_Q >= Big_0 else Big_Q <= Big_0); - -- Proves the sign of rounded quotient when dividend is non-negative - - procedure Prove_Rounding_Case - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - and then Big (Ru) = abs Big_R - and then Big (Zu) = Big (Uns32'(abs Z)), - Post => abs Big_Q = - (if Ru > (Zu - Uns32'(1)) / Uns32'(2) - then abs Quot + 1 - else abs Quot); - -- Proves correctness of the rounding of the unsigned quotient - - procedure Prove_Sign_R - with - Ghost, - Pre => Z /= 0 and then Big_R = Big (X) * Big (Y) rem Big (Z), - Post => In_Int32_Range (Big_R); - - procedure Prove_Signs - with - Ghost, - Pre => Z /= 0 - and then Quot = Big (X) * Big (Y) / Big (Z) - and then Big_R = Big (X) * Big (Y) rem Big (Z) - and then Big_Q = - (if Round then - Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R) - else Quot) - and then Big (Ru) = abs Big_R - and then Big (Qu) = abs Big_Q - and then In_Int32_Range (Big_Q) - and then In_Int32_Range (Big_R) - and then R = - (if (X >= 0) = (Y >= 0) then To_Pos_Int (Ru) else To_Neg_Int (Ru)) - and then Q = - (if ((X >= 0) = (Y >= 0)) = (Z >= 0) then To_Pos_Int (Qu) - else To_Neg_Int (Qu)), -- need to ensure To_Pos_Int precondition - Post => Big (R) = Big_R and then Big (Q) = Big_Q; - -- Proves final signs match the intended result after the unsigned - -- division is done. - - ----------------------------- - -- Prove_Negative_Dividend -- - ----------------------------- - - procedure Prove_Negative_Dividend is - begin - Lemma_Mult_Non_Positive (Big (X), Big (Y)); - end Prove_Negative_Dividend; - - -------------------- - -- Prove_Overflow -- - -------------------- - - procedure Prove_Overflow is - begin - Lemma_Div_Ge (Mult, Big_2xx32, Big (Uns32'(abs Z))); - Lemma_Abs_Commutation (Z); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - end Prove_Overflow; - - ----------------------------- - -- Prove_Positive_Dividend -- - ----------------------------- - - procedure Prove_Positive_Dividend is - begin - Lemma_Mult_Non_Negative (Big (X), Big (Y)); - end Prove_Positive_Dividend; - - ------------------------- - -- Prove_Rounding_Case -- - ------------------------- - - procedure Prove_Rounding_Case is - begin - if Same_Sign (Big (X) * Big (Y), Big (Z)) then - pragma Assert - (abs Big_Q = - (if Ru > (Zu - Uns32'(1)) / Uns32'(2) - then abs Quot + 1 - else abs Quot)); - end if; - end Prove_Rounding_Case; - - ------------------ - -- Prove_Sign_R -- - ------------------ - - procedure Prove_Sign_R is - begin - pragma Assert (In_Int32_Range (Big (Z))); - end Prove_Sign_R; - - ----------------- - -- Prove_Signs -- - ----------------- - - procedure Prove_Signs is - begin - if (X >= 0) = (Y >= 0) then - pragma Assert (Big (R) = Big_R and then Big (Q) = Big_Q); - else - pragma Assert (Big (R) = Big_R and then Big (Q) = Big_Q); - end if; - end Prove_Signs; - - -- Start of processing for Scaled_Divide32 - begin -- First do the 64-bit multiplication D := Uns64 (Xu) * Uns64 (Yu); - Lemma_Abs_Mult_Commutation (Big (X), Big (Y)); - pragma Assert (Mult = Big (D)); - Lemma_Hi_Lo (D, Hi (D), Lo (D)); - pragma Assert (Mult = Big_2xx32 * Big (Hi (D)) + Big (Lo (D))); - -- If divisor is zero, raise error if Z = 0 then Raise_Error; end if; - Quot := Big (X) * Big (Y) / Big (Z); - Big_R := Big (X) * Big (Y) rem Big (Z); - if Round then - Big_Q := Round_Quotient (Big (X) * Big (Y), Big (Z), Quot, Big_R); - else - Big_Q := Quot; - end if; - -- If dividend is too large, raise error if Hi (D) >= Zu then - Lemma_Ge_Commutation (Hi (D), Zu); - pragma Assert (Mult >= Big_2xx32 * Big (Zu)); - Prove_Overflow; Raise_Error; end if; @@ -487,35 +128,14 @@ is Qu := Uns32 (D / Uns64 (Zu)); Ru := Uns32 (D rem Uns64 (Zu)); - Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Commutation (X); - Lemma_Abs_Commutation (Y); - Lemma_Abs_Commutation (Z); - Lemma_Mult_Commutation (Uns64 (Xu), Uns64 (Yu), D); - Lemma_Div_Commutation (D, Uns64 (Zu)); - Lemma_Rem_Commutation (D, Uns64 (Zu)); - - pragma Assert (Uns64 (Qu) = D / Uns64 (Zu)); - pragma Assert (Uns64 (Ru) = D rem Uns64 (Zu)); - pragma Assert (Big (Ru) = abs Big_R); - pragma Assert (Big (Qu) = abs Quot); - pragma Assert (Big (Zu) = Big (Uns32'(abs Z))); - -- Deal with rounding case if Round then - Prove_Rounding_Case; - if Ru > (Zu - Uns32'(1)) / Uns32'(2) then - pragma Assert (abs Big_Q = Big (Qu) + 1); - -- Protect against wrapping around when rounding, by signaling -- an overflow when the quotient is too large. if Qu = Uns32'Last then - pragma Assert (abs Big_Q = Big_2xx32); - Lemma_Not_In_Range_Big2xx32; Raise_Error; end if; @@ -523,31 +143,20 @@ is end if; end if; - pragma Assert (In_Int32_Range (Big_Q)); - pragma Assert (Big (Qu) = abs Big_Q); - pragma Assert (Big (Ru) = abs Big_R); - Prove_Sign_R; - -- Set final signs (RM 4.5.5(27-30)) -- Case of dividend (X * Y) sign positive if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then - Prove_Positive_Dividend; - R := To_Pos_Int (Ru); Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); -- Case of dividend (X * Y) sign negative else - Prove_Negative_Dividend; - R := To_Neg_Int (Ru); Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); end if; - - Prove_Signs; end Scaled_Divide32; ---------------- @@ -559,6 +168,7 @@ is (if A = 2**31 then Int32'First else -To_Int (A)); -- Note that we can't just use the expression of the Else, because it -- overflows for A = 2**31. + begin if R <= 0 then return R; diff --git a/gcc/ada/libgnat/s-arit32.ads b/gcc/ada/libgnat/s-arit32.ads index a8abbdc..856dd59 100644 --- a/gcc/ada/libgnat/s-arit32.ads +++ b/gcc/ada/libgnat/s-arit32.ads @@ -33,79 +33,19 @@ -- signed integer values in cases where either overflow checking is -- required, or intermediate results are longer than 32 bits. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with Interfaces; -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; package System.Arith_32 with Pure, SPARK_Mode is - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; use type Interfaces.Integer_32; subtype Int32 is Interfaces.Integer_32; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Signed_Conversion is new - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions - (Int => Int32); - - function Big (Arg : Int32) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int32_Range (Arg : Big_Integer) return Boolean is - (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range - (Arg, Big (Int32'First), Big (Int32'Last))) - with Ghost; - - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Int32'(0)) - or else Y = Big (Int32'(0)) - or else (X < Big (Int32'(0))) = (Y < Big (Int32'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer is - (if abs R > (abs Y - Big (Int32'(1))) / Big (Int32'(2)) then - (if Same_Sign (X, Y) then Q + Big (Int32'(1)) - else Q - Big (Int32'(1))) - else - Q) - with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y; - procedure Scaled_Divide32 (X, Y, Z : Int32; Q, R : out Int32; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Int32_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient -- in ``Q`` and the remainder in ``R``. -- diff --git a/gcc/ada/libgnat/s-arit64.adb b/gcc/ada/libgnat/s-arit64.adb index 331f328..4e0336f 100644 --- a/gcc/ada/libgnat/s-arit64.adb +++ b/gcc/ada/libgnat/s-arit64.adb @@ -28,14 +28,12 @@ -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -pragma Assertion_Policy (Ghost => Ignore); with System.Arith_Double; package body System.Arith_64 with SPARK_Mode is - subtype Uns64 is Interfaces.Unsigned_64; subtype Uns32 is Interfaces.Unsigned_32; @@ -52,9 +50,6 @@ is function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64 renames Impl.Multiply_With_Ovflo_Check; - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer - renames Impl.Round_Quotient; - procedure Scaled_Divide64 (X, Y, Z : Int64; Q, R : out Int64; diff --git a/gcc/ada/libgnat/s-arit64.ads b/gcc/ada/libgnat/s-arit64.ads index 2ddd15c..6e12789 100644 --- a/gcc/ada/libgnat/s-arit64.ads +++ b/gcc/ada/libgnat/s-arit64.ads @@ -36,49 +36,14 @@ pragma Restrictions (No_Elaboration_Code); -- Allow direct call from gigi generated code --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; with Interfaces; package System.Arith_64 with Pure, SPARK_Mode is - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; - use type Interfaces.Integer_64; - subtype Int64 is Interfaces.Integer_64; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Signed_Conversion is new - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Signed_Conversions - (Int => Int64); - - function Big (Arg : Int64) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int64_Range (Arg : Big_Integer) return Boolean is - (Ada.Numerics.Big_Numbers.Big_Integers_Ghost.In_Range - (Arg, Big (Int64'First), Big (Int64'Last))) - with Ghost; - - function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64 - with - Pre => In_Int64_Range (Big (X) + Big (Y)), - Post => Add_With_Ovflo_Check64'Result = X + Y; + function Add_With_Ovflo_Check64 (X, Y : Int64) return Int64; -- Raises Constraint_Error if sum of operands overflows 64 bits, -- otherwise returns the 64-bit signed integer sum. -- @@ -93,10 +58,7 @@ is -- the exception *Constraint_Error* is raised; otherwise the result is -- correct. - function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64 - with - Pre => In_Int64_Range (Big (X) - Big (Y)), - Post => Subtract_With_Ovflo_Check64'Result = X - Y; + function Subtract_With_Ovflo_Check64 (X, Y : Int64) return Int64; -- Raises Constraint_Error if difference of operands overflows 64 -- bits, otherwise returns the 64-bit signed integer difference. -- @@ -105,10 +67,7 @@ is -- a sign of the result is compared with the sign of ``X`` to check for -- overflow. - function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64 - with - Pre => In_Int64_Range (Big (X) * Big (Y)), - Post => Multiply_With_Ovflo_Check64'Result = X * Y; + function Multiply_With_Ovflo_Check64 (X, Y : Int64) return Int64; pragma Export (C, Multiply_With_Ovflo_Check64, "__gnat_mulv64"); -- Raises Constraint_Error if product of operands overflows 64 -- bits, otherwise returns the 64-bit signed integer product. @@ -119,40 +78,10 @@ is -- signed value is returned. Overflow check is performed by looking at -- higher digits. - function Same_Sign (X, Y : Big_Integer) return Boolean is - (X = Big (Int64'(0)) - or else Y = Big (Int64'(0)) - or else (X < Big (Int64'(0))) = (Y < Big (Int64'(0)))) - with Ghost; - - function Round_Quotient (X, Y, Q, R : Big_Integer) return Big_Integer with - Ghost, - Pre => Y /= 0 and then Q = X / Y and then R = X rem Y, - Post => Round_Quotient'Result = - (if abs R > (abs Y - Big (Int64'(1))) / Big (Int64'(2)) then - (if Same_Sign (X, Y) then Q + Big (Int64'(1)) - else Q - Big (Int64'(1))) - else - Q); - procedure Scaled_Divide64 (X, Y, Z : Int64; Q, R : out Int64; - Round : Boolean) - with - Pre => Z /= 0 - and then In_Int64_Range - (if Round then Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), - Big (X) * Big (Y) rem Big (Z)) - else Big (X) * Big (Y) / Big (Z)), - Post => Big (R) = Big (X) * Big (Y) rem Big (Z) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X) * Big (Y), Big (Z), - Big (X) * Big (Y) / Big (Z), Big (R)) - else - Big (Q) = Big (X) * Big (Y) / Big (Z)); + Round : Boolean); -- Performs the division of (``X`` * ``Y``) / ``Z``, storing the quotient -- in ``Q`` and the remainder in ``R``. -- @@ -189,22 +118,7 @@ is procedure Double_Divide64 (X, Y, Z : Int64; Q, R : out Int64; - Round : Boolean) - with - Pre => Y /= 0 - and then Z /= 0 - and then In_Int64_Range - (if Round then Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), - Big (X) rem (Big (Y) * Big (Z))) - else Big (X) / (Big (Y) * Big (Z))), - Post => Big (R) = Big (X) rem (Big (Y) * Big (Z)) - and then - (if Round then - Big (Q) = Round_Quotient (Big (X), Big (Y) * Big (Z), - Big (X) / (Big (Y) * Big (Z)), Big (R)) - else - Big (Q) = Big (X) / (Big (Y) * Big (Z))); + Round : Boolean); -- Performs the division ``X`` / (``Y`` * ``Z``), storing the quotient in -- ``Q`` and the remainder in ``R``. Constraint_Error is raised if ``Y`` or -- ``Z`` is zero, or if the quotient does not fit in 64-bits. diff --git a/gcc/ada/libgnat/s-casuti.adb b/gcc/ada/libgnat/s-casuti.adb index 58c358c..887cbbf 100644 --- a/gcc/ada/libgnat/s-casuti.adb +++ b/gcc/ada/libgnat/s-casuti.adb @@ -29,14 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body System.Case_Util with SPARK_Mode is @@ -44,30 +36,6 @@ is -- To_Lower -- -------------- - function To_Lower (A : Character) return Character is - A_Val : constant Natural := Character'Pos (A); - - begin - if A in 'A' .. 'Z' - or else A_Val in 16#C0# .. 16#D6# - or else A_Val in 16#D8# .. 16#DE# - then - return Character'Val (A_Val + 16#20#); - else - return A; - end if; - end To_Lower; - - procedure To_Lower (A : in out String) is - begin - for J in A'Range loop - A (J) := To_Lower (A (J)); - - pragma Loop_Invariant - (for all K in A'First .. J => A (K) = To_Lower (A'Loop_Entry (K))); - end loop; - end To_Lower; - function To_Lower (A : String) return String is Result : String := A; begin @@ -79,30 +47,6 @@ is -- To_Mixed -- -------------- - procedure To_Mixed (A : in out String) is - Ucase : Boolean := True; - - begin - for J in A'Range loop - if Ucase then - A (J) := To_Upper (A (J)); - else - A (J) := To_Lower (A (J)); - end if; - - pragma Loop_Invariant - (for all K in A'First .. J => - (if K = A'First - or else A'Loop_Entry (K - 1) = '_' - then - A (K) = To_Upper (A'Loop_Entry (K)) - else - A (K) = To_Lower (A'Loop_Entry (K)))); - - Ucase := A (J) = '_'; - end loop; - end To_Mixed; - function To_Mixed (A : String) return String is Result : String := A; begin @@ -114,30 +58,6 @@ is -- To_Upper -- -------------- - function To_Upper (A : Character) return Character is - A_Val : constant Natural := Character'Pos (A); - - begin - if A in 'a' .. 'z' - or else A_Val in 16#E0# .. 16#F6# - or else A_Val in 16#F8# .. 16#FE# - then - return Character'Val (A_Val - 16#20#); - else - return A; - end if; - end To_Upper; - - procedure To_Upper (A : in out String) is - begin - for J in A'Range loop - A (J) := To_Upper (A (J)); - - pragma Loop_Invariant - (for all K in A'First .. J => A (K) = To_Upper (A'Loop_Entry (K))); - end loop; - end To_Upper; - function To_Upper (A : String) return String is Result : String := A; begin diff --git a/gcc/ada/libgnat/s-casuti.ads b/gcc/ada/libgnat/s-casuti.ads index fbdec17..967abe0 100644 --- a/gcc/ada/libgnat/s-casuti.ads +++ b/gcc/ada/libgnat/s-casuti.ads @@ -40,34 +40,30 @@ -- contract cases should not be executed at runtime as well, in order not to -- slow down the execution of these functions. +-- The portion of this package that does not require use of the secondary +-- stack (so all the subprograms except functions that return String) +-- has been moved into a sibling package, Case_Util_NSS. See comments there. +-- Clients who don't care about avoiding secondary stack usage can +-- continue to use this package and are unaffected by this reorganization. + pragma Assertion_Policy (Pre => Ignore, Post => Ignore, Contract_Cases => Ignore, Ghost => Ignore); +with System.Case_Util_NSS; + package System.Case_Util with Pure, SPARK_Mode is -- Note: all the following functions handle the full Latin-1 set function To_Upper (A : Character) return Character - with - Post => (declare - A_Val : constant Natural := Character'Pos (A); - begin - (if A in 'a' .. 'z' - or else A_Val in 16#E0# .. 16#F6# - or else A_Val in 16#F8# .. 16#FE# - then - To_Upper'Result = Character'Val (A_Val - 16#20#) - else - To_Upper'Result = A)); + renames Case_Util_NSS.To_Upper; -- Converts A to upper case if it is a lower case letter, otherwise -- returns the input argument unchanged. - procedure To_Upper (A : in out String) - with - Post => (for all J in A'Range => A (J) = To_Upper (A'Old (J))); + procedure To_Upper (A : in out String) renames Case_Util_NSS.To_Upper; function To_Upper (A : String) return String with @@ -78,23 +74,12 @@ is -- Folds all characters of string A to upper case function To_Lower (A : Character) return Character - with - Post => (declare - A_Val : constant Natural := Character'Pos (A); - begin - (if A in 'A' .. 'Z' - or else A_Val in 16#C0# .. 16#D6# - or else A_Val in 16#D8# .. 16#DE# - then - To_Lower'Result = Character'Val (A_Val + 16#20#) - else - To_Lower'Result = A)); + renames Case_Util_NSS.To_Lower; -- Converts A to lower case if it is an upper case letter, otherwise -- returns the input argument unchanged. procedure To_Lower (A : in out String) - with - Post => (for all J in A'Range => A (J) = To_Lower (A'Old (J))); + renames Case_Util_NSS.To_Lower; function To_Lower (A : String) return String with @@ -105,15 +90,7 @@ is -- Folds all characters of string A to lower case procedure To_Mixed (A : in out String) - with - Post => - (for all J in A'Range => - (if J = A'First - or else A'Old (J - 1) = '_' - then - A (J) = To_Upper (A'Old (J)) - else - A (J) = To_Lower (A'Old (J)))); + renames Case_Util_NSS.To_Mixed; function To_Mixed (A : String) return String with diff --git a/gcc/ada/libgnat/s-valspe.adb b/gcc/ada/libgnat/s-cautns.adb index b47e818..3e2d996 100644 --- a/gcc/ada/libgnat/s-valspe.adb +++ b/gcc/ada/libgnat/s-cautns.adb @@ -1,12 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNAT COMPILER COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- --- S Y S T E M . V A L _ S P E C -- +-- S Y S T E M . C A S E _ U T I L _ N S S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2023-2025, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2025, AdaCore -- -- -- -- 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- -- @@ -37,51 +37,91 @@ pragma Assertion_Policy (Ghost => Ignore, Loop_Invariant => Ignore, Assert => Ignore); -package body System.Val_Spec +package body System.Case_Util_NSS with SPARK_Mode is + -------------- + -- To_Lower -- + -------------- - --------------------------- - -- First_Non_Space_Ghost -- - --------------------------- + function To_Lower (A : Character) return Character is + A_Val : constant Natural := Character'Pos (A); - function First_Non_Space_Ghost - (S : String; - From, To : Integer) return Positive - is begin - for J in From .. To loop - if S (J) /= ' ' then - return J; - end if; + if A in 'A' .. 'Z' + or else A_Val in 16#C0# .. 16#D6# + or else A_Val in 16#D8# .. 16#DE# + then + return Character'Val (A_Val + 16#20#); + else + return A; + end if; + end To_Lower; + + procedure To_Lower (A : in out String) is + begin + for J in A'Range loop + A (J) := To_Lower (A (J)); - pragma Loop_Invariant (for all K in From .. J => S (K) = ' '); + pragma Loop_Invariant + (for all K in A'First .. J => A (K) = To_Lower (A'Loop_Entry (K))); end loop; + end To_Lower; - raise Program_Error; - end First_Non_Space_Ghost; + -------------- + -- To_Mixed -- + -------------- - ----------------------- - -- Last_Number_Ghost -- - ----------------------- + procedure To_Mixed (A : in out String) is + Ucase : Boolean := True; - function Last_Number_Ghost (Str : String) return Positive is begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "occurs in ghost code, not executable"); - - for J in Str'Range loop - if Str (J) not in '0' .. '9' | '_' then - return J - 1; + for J in A'Range loop + if Ucase then + A (J) := To_Upper (A (J)); + else + A (J) := To_Lower (A (J)); end if; pragma Loop_Invariant - (for all K in Str'First .. J => Str (K) in '0' .. '9' | '_'); + (for all K in A'First .. J => + (if K = A'First + or else A'Loop_Entry (K - 1) = '_' + then + A (K) = To_Upper (A'Loop_Entry (K)) + else + A (K) = To_Lower (A'Loop_Entry (K)))); + + Ucase := A (J) = '_'; end loop; + end To_Mixed; + + -------------- + -- To_Upper -- + -------------- - return Str'Last; + function To_Upper (A : Character) return Character is + A_Val : constant Natural := Character'Pos (A); - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); - end Last_Number_Ghost; + begin + if A in 'a' .. 'z' + or else A_Val in 16#E0# .. 16#F6# + or else A_Val in 16#F8# .. 16#FE# + then + return Character'Val (A_Val - 16#20#); + else + return A; + end if; + end To_Upper; + + procedure To_Upper (A : in out String) is + begin + for J in A'Range loop + A (J) := To_Upper (A (J)); + + pragma Loop_Invariant + (for all K in A'First .. J => A (K) = To_Upper (A'Loop_Entry (K))); + end loop; + end To_Upper; -end System.Val_Spec; +end System.Case_Util_NSS; diff --git a/gcc/ada/libgnat/s-cautns.ads b/gcc/ada/libgnat/s-cautns.ads new file mode 100644 index 0000000..5c9c67b --- /dev/null +++ b/gcc/ada/libgnat/s-cautns.ads @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . C A S E _ U T I L _ N S S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2025, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The No_Secondary_Stack portion of System.Case_Util. Some of the functions +-- provided in System.Case_Util make use of the secondary stack, and some +-- do not. Lumping them all together makes even the non-secondary-stack +-- portion of the package unusable in cases where references to +-- secondary-stack-related code must be avoided (for example, if linking with +-- a reduced version of the runtimes where that code is missing). That's a +-- problem in some cases, so Case_Util is split into two parts. The first +-- part (named Case_Util_NSS) is a subset of the original version which +-- does not use the secondary stack; the second part presents the same +-- complete interface to users as before, but avoids code duplication by +-- renaming entities out of the first part. +-- +-- See comments in s-casuti.ads for further explanations (e.g., of +-- the Assertion_Policy specified here). + +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore); + +package System.Case_Util_NSS + with Pure, SPARK_Mode +is + -- Note: all the following functions handle the full Latin-1 set + + function To_Upper (A : Character) return Character + with + Post => (declare + A_Val : constant Natural := Character'Pos (A); + begin + (if A in 'a' .. 'z' + or else A_Val in 16#E0# .. 16#F6# + or else A_Val in 16#F8# .. 16#FE# + then + To_Upper'Result = Character'Val (A_Val - 16#20#) + else + To_Upper'Result = A)); + -- Converts A to upper case if it is a lower case letter, otherwise + -- returns the input argument unchanged. + + procedure To_Upper (A : in out String) + with + Post => (for all J in A'Range => A (J) = To_Upper (A'Old (J))); + + function To_Lower (A : Character) return Character + with + Post => (declare + A_Val : constant Natural := Character'Pos (A); + begin + (if A in 'A' .. 'Z' + or else A_Val in 16#C0# .. 16#D6# + or else A_Val in 16#D8# .. 16#DE# + then + To_Lower'Result = Character'Val (A_Val + 16#20#) + else + To_Lower'Result = A)); + -- Converts A to lower case if it is an upper case letter, otherwise + -- returns the input argument unchanged. + + procedure To_Lower (A : in out String) + with + Post => (for all J in A'Range => A (J) = To_Lower (A'Old (J))); + + procedure To_Mixed (A : in out String) + with + Post => + (for all J in A'Range => + (if J = A'First + or else A'Old (J - 1) = '_' + then + A (J) = To_Upper (A'Old (J)) + else + A (J) = To_Lower (A'Old (J)))); + +end System.Case_Util_NSS; diff --git a/gcc/ada/libgnat/s-dorepr.adb b/gcc/ada/libgnat/s-dorepr.adb index ddc7c1d..1d9604a 100644 --- a/gcc/ada/libgnat/s-dorepr.adb +++ b/gcc/ada/libgnat/s-dorepr.adb @@ -134,7 +134,7 @@ package body Product is Ahi, Alo, Bhi, Blo, E : Num; begin - if Is_Infinity (P) or else Is_Zero (P) then + if Is_Infinity_Or_NaN (P) or else Is_Zero (P) then return (P, 0.0); else @@ -157,7 +157,7 @@ package body Product is Hi, Lo, E : Num; begin - if Is_Infinity (Q) or else Is_Zero (Q) then + if Is_Infinity_Or_NaN (Q) or else Is_Zero (Q) then return (Q, 0.0); else diff --git a/gcc/ada/libgnat/s-dorepr__fma.adb b/gcc/ada/libgnat/s-dorepr__fma.adb index 0d3dc53..45a9223 100644 --- a/gcc/ada/libgnat/s-dorepr__fma.adb +++ b/gcc/ada/libgnat/s-dorepr__fma.adb @@ -78,7 +78,7 @@ package body Product is E : Num; begin - if Is_Infinity (P) or else Is_Zero (P) then + if Is_Infinity_Or_NaN (P) or else Is_Zero (P) then return (P, 0.0); else diff --git a/gcc/ada/libgnat/s-dourea.adb b/gcc/ada/libgnat/s-dourea.adb index a37f2eb..68d4d9a 100644 --- a/gcc/ada/libgnat/s-dourea.adb +++ b/gcc/ada/libgnat/s-dourea.adb @@ -34,12 +34,12 @@ package body System.Double_Real is function Is_NaN (N : Num) return Boolean is (N /= N); -- Return True if N is a NaN - function Is_Infinity (N : Num) return Boolean is (Is_NaN (N - N)); - -- Return True if N is an infinity. Used to avoid propagating meaningless - -- errors when the result of a product is an infinity. + function Is_Infinity_Or_NaN (N : Num) return Boolean is (Is_NaN (N - N)); + -- Return True if N is either an infinity or NaN. Used to avoid propagating + -- meaningless errors when the result of a product is an infinity or NaN. function Is_Zero (N : Num) return Boolean is (N = -N); - -- Return True if N is a Zero. Used to preserve the sign when the result of + -- Return True if N is a zero. Used to preserve the sign when the result of -- a product is a zero. package Product is @@ -151,7 +151,7 @@ package body System.Double_Real is P : constant Double_T := Two_Prod (A.Hi, B); begin - if Is_Infinity (P.Hi) or else Is_Zero (P.Hi) then + if Is_Infinity_Or_NaN (P.Hi) or else Is_Zero (P.Hi) then return (P.Hi, 0.0); else return Quick_Two_Sum (P.Hi, P.Lo + A.Lo * B); @@ -162,7 +162,7 @@ package body System.Double_Real is P : constant Double_T := Two_Prod (A.Hi, B.Hi); begin - if Is_Infinity (P.Hi) or else Is_Zero (P.Hi) then + if Is_Infinity_Or_NaN (P.Hi) or else Is_Zero (P.Hi) then return (P.Hi, 0.0); else return Quick_Two_Sum (P.Hi, P.Lo + A.Hi * B.Lo + A.Lo * B.Hi); @@ -178,7 +178,7 @@ package body System.Double_Real is P, R : Double_T; begin - if Is_Infinity (B) or else Is_Zero (B) then + if Is_Infinity_Or_NaN (B) or else Is_Zero (B) then return (A.Hi / B, 0.0); end if; pragma Annotate (CodePeer, Intentional, "test always false", @@ -202,7 +202,7 @@ package body System.Double_Real is R, S : Double_T; begin - if Is_Infinity (B.Hi) or else Is_Zero (B.Hi) then + if Is_Infinity_Or_NaN (B.Hi) or else Is_Zero (B.Hi) then return (A.Hi / B.Hi, 0.0); end if; pragma Annotate (CodePeer, Intentional, "test always false", @@ -228,7 +228,7 @@ package body System.Double_Real is Q : constant Double_T := Two_Sqr (A.Hi); begin - if Is_Infinity (Q.Hi) or else Is_Zero (Q.Hi) then + if Is_Infinity_Or_NaN (Q.Hi) or else Is_Zero (Q.Hi) then return (Q.Hi, 0.0); else return Quick_Two_Sum (Q.Hi, Q.Lo + 2.0 * A.Hi * A.Lo + A.Lo * A.Lo); diff --git a/gcc/ada/libgnat/s-exnint.ads b/gcc/ada/libgnat/s-exnint.ads index 3a11f2c..fa46217 100644 --- a/gcc/ada/libgnat/s-exnint.ads +++ b/gcc/ada/libgnat/s-exnint.ads @@ -31,17 +31,6 @@ -- This package implements Integer exponentiation (checks off) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Exponn; package System.Exn_Int diff --git a/gcc/ada/libgnat/s-exnlli.ads b/gcc/ada/libgnat/s-exnlli.ads index ba67b76..63c4b88 100644 --- a/gcc/ada/libgnat/s-exnlli.ads +++ b/gcc/ada/libgnat/s-exnlli.ads @@ -31,17 +31,6 @@ -- This package implements Long_Long_Integer exponentiation (checks off) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Exponn; package System.Exn_LLI diff --git a/gcc/ada/libgnat/s-exnllli.ads b/gcc/ada/libgnat/s-exnllli.ads index 5ff963c..e94efe0 100644 --- a/gcc/ada/libgnat/s-exnllli.ads +++ b/gcc/ada/libgnat/s-exnllli.ads @@ -31,23 +31,11 @@ -- Long_Long_Long_Integer exponentiation (checks off) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Exponn; package System.Exn_LLLI with SPARK_Mode is - package Exponn_Integer is new Exponn (Long_Long_Long_Integer); function Exn_Long_Long_Long_Integer diff --git a/gcc/ada/libgnat/s-expint.ads b/gcc/ada/libgnat/s-expint.ads index a69c8d6..d349330 100644 --- a/gcc/ada/libgnat/s-expint.ads +++ b/gcc/ada/libgnat/s-expint.ads @@ -31,23 +31,11 @@ -- This package implements Integer exponentiation (checks on) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Expont; package System.Exp_Int with SPARK_Mode is - package Expont_Integer is new Expont (Integer); function Exp_Integer (Left : Integer; Right : Natural) return Integer diff --git a/gcc/ada/libgnat/s-explli.ads b/gcc/ada/libgnat/s-explli.ads index 9ea38de..af3da9c 100644 --- a/gcc/ada/libgnat/s-explli.ads +++ b/gcc/ada/libgnat/s-explli.ads @@ -31,23 +31,11 @@ -- This package implements Long_Long_Integer exponentiation --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Expont; package System.Exp_LLI with SPARK_Mode is - package Expont_Integer is new Expont (Long_Long_Integer); function Exp_Long_Long_Integer diff --git a/gcc/ada/libgnat/s-expllli.ads b/gcc/ada/libgnat/s-expllli.ads index 273c33c..ed100b9 100644 --- a/gcc/ada/libgnat/s-expllli.ads +++ b/gcc/ada/libgnat/s-expllli.ads @@ -31,23 +31,11 @@ -- Long_Long_Long_Integer exponentiation (checks on) --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Expont; package System.Exp_LLLI with SPARK_Mode is - package Expont_Integer is new Expont (Long_Long_Long_Integer); function Exp_Long_Long_Long_Integer diff --git a/gcc/ada/libgnat/s-explllu.ads b/gcc/ada/libgnat/s-explllu.ads index a0b5d47..88aa9af 100644 --- a/gcc/ada/libgnat/s-explllu.ads +++ b/gcc/ada/libgnat/s-explllu.ads @@ -34,24 +34,12 @@ -- The result is always full width, the caller must do a masking operation if -- the modulus is less than 2 ** Long_Long_Long_Unsigned'Size. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Exponu; with System.Unsigned_Types; package System.Exp_LLLU with SPARK_Mode is - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; function Exp_Long_Long_Long_Unsigned is diff --git a/gcc/ada/libgnat/s-expllu.ads b/gcc/ada/libgnat/s-expllu.ads index 98fc851..3e2b2a7 100644 --- a/gcc/ada/libgnat/s-expllu.ads +++ b/gcc/ada/libgnat/s-expllu.ads @@ -34,24 +34,12 @@ -- is always full width, the caller must do a masking operation if the -- modulus is less than 2 ** (Long_Long_Unsigned'Size). --- Note: preconditions in this unit are meant for analysis only, not for --- run-time checking, so that the expected exceptions are raised. This is --- enforced by setting the corresponding assertion policy to Ignore. --- Postconditions and contract cases should not be executed at run-time as --- well, in order not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Exponu; with System.Unsigned_Types; package System.Exp_LLU with SPARK_Mode is - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; function Exp_Long_Long_Unsigned is new Exponu (Long_Long_Unsigned); diff --git a/gcc/ada/libgnat/s-expmod.adb b/gcc/ada/libgnat/s-expmod.adb index 28c07a1..16d6b5f 100644 --- a/gcc/ada/libgnat/s-expmod.adb +++ b/gcc/ada/libgnat/s-expmod.adb @@ -29,203 +29,11 @@ -- -- ------------------------------------------------------------------------------ --- Preconditions, postconditions, ghost code, loop invariants and assertions --- in this unit are meant for analysis only, not for run-time checking, as it --- would be too costly otherwise. This is enforced by setting the assertion --- policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - package body System.Exp_Mod with SPARK_Mode is use System.Unsigned_Types; - -- Local lemmas - - procedure Lemma_Add_Mod (X, Y : Big_Natural; B : Big_Positive) - with - Ghost, - Post => (X + Y) mod B = ((X mod B) + (Y mod B)) mod B; - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) - with - Ghost, - Post => - (if Exp rem 2 = 0 then - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) - else - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A); - - procedure Lemma_Exp_Mod (A : Big_Natural; Exp : Natural; B : Big_Positive) - with - Ghost, - Subprogram_Variant => (Decreases => Exp), - Post => ((A mod B) ** Exp) mod B = (A ** Exp) mod B; - - procedure Lemma_Mod_Ident (A : Big_Natural; B : Big_Positive) - with - Ghost, - Pre => A < B, - Post => A mod B = A; - - procedure Lemma_Mod_Mod (A : Big_Integer; B : Big_Positive) - with - Ghost, - Post => A mod B mod B = A mod B; - - procedure Lemma_Mult_Div (X : Big_Natural; Y : Big_Positive) - with - Ghost, - Post => X * Y / Y = X; - - procedure Lemma_Mult_Mod (X, Y : Big_Natural; B : Big_Positive) - with - Ghost, - -- The following subprogram variant can be added as soon as supported - -- Subprogram_Variant => (Decreases => Y), - Post => (X * Y) mod B = ((X mod B) * (Y mod B)) mod B; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Mod_Ident (A : Big_Natural; B : Big_Positive) is null; - procedure Lemma_Mod_Mod (A : Big_Integer; B : Big_Positive) is null; - procedure Lemma_Mult_Div (X : Big_Natural; Y : Big_Positive) is null; - - ------------------- - -- Lemma_Add_Mod -- - ------------------- - - procedure Lemma_Add_Mod (X, Y : Big_Natural; B : Big_Positive) is - - procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) with - Pre => F /= 0, - Post => (Q * F + R) mod F = R mod F, - Subprogram_Variant => (Decreases => Q); - - ------------------------- - -- Lemma_Euclidean_Mod -- - ------------------------- - - procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) is - begin - if Q > 0 then - Lemma_Euclidean_Mod (Q - 1, F, R); - end if; - end Lemma_Euclidean_Mod; - - -- Local variables - - Left : constant Big_Natural := (X + Y) mod B; - Right : constant Big_Natural := ((X mod B) + (Y mod B)) mod B; - XQuot : constant Big_Natural := X / B; - YQuot : constant Big_Natural := Y / B; - AQuot : constant Big_Natural := (X mod B + Y mod B) / B; - begin - if Y /= 0 and B > 1 then - pragma Assert (X = XQuot * B + X mod B); - pragma Assert (Y = YQuot * B + Y mod B); - pragma Assert - (Left = ((XQuot + YQuot) * B + X mod B + Y mod B) mod B); - pragma Assert (X mod B + Y mod B = AQuot * B + Right); - pragma Assert (Left = ((XQuot + YQuot + AQuot) * B + Right) mod B); - Lemma_Euclidean_Mod (XQuot + YQuot + AQuot, B, Right); - pragma Assert (Left = (Right mod B)); - pragma Assert (Left = Right); - end if; - end Lemma_Add_Mod; - - ---------------------- - -- Lemma_Exp_Expand -- - ---------------------- - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with - Pre => Natural'Last - Exp_2 >= Exp_1, - Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2); - - ---------------------------- - -- Lemma_Exp_Distribution -- - ---------------------------- - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null; - - begin - if Exp rem 2 = 0 then - pragma Assert (Exp = Exp / 2 + Exp / 2); - else - pragma Assert (Exp = Exp / 2 + Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, 1); - end if; - end Lemma_Exp_Expand; - - ------------------- - -- Lemma_Exp_Mod -- - ------------------- - - procedure Lemma_Exp_Mod (A : Big_Natural; Exp : Natural; B : Big_Positive) - is - begin - if Exp /= 0 then - declare - Left : constant Big_Integer := ((A mod B) ** Exp) mod B; - Right : constant Big_Integer := (A ** Exp) mod B; - begin - Lemma_Mult_Mod (A mod B, (A mod B) ** (Exp - 1), B); - Lemma_Mod_Mod (A, B); - Lemma_Exp_Mod (A, Exp - 1, B); - Lemma_Mult_Mod (A, A ** (Exp - 1), B); - pragma Assert - ((A mod B) * (A mod B) ** (Exp - 1) = (A mod B) ** Exp); - pragma Assert (A * A ** (Exp - 1) = A ** Exp); - pragma Assert (Left = Right); - end; - end if; - end Lemma_Exp_Mod; - - -------------------- - -- Lemma_Mult_Mod -- - -------------------- - - procedure Lemma_Mult_Mod (X, Y : Big_Natural; B : Big_Positive) is - Left : constant Big_Natural := (X * Y) mod B; - Right : constant Big_Natural := ((X mod B) * (Y mod B)) mod B; - begin - if Y /= 0 and B > 1 then - Lemma_Add_Mod (X * (Y - 1), X, B); - Lemma_Mult_Mod (X, Y - 1, B); - Lemma_Mod_Mod (X, B); - Lemma_Add_Mod ((X mod B) * ((Y - 1) mod B), X mod B, B); - Lemma_Add_Mod (Y - 1, 1, B); - pragma Assert (((Y - 1) mod B + 1) mod B = Y mod B); - if (Y - 1) mod B + 1 < B then - Lemma_Mod_Ident ((Y - 1) mod B + 1, B); - Lemma_Mod_Mod ((X mod B) * (Y mod B), B); - pragma Assert (Left = Right); - else - pragma Assert (Y mod B = 0); - pragma Assert (Y / B * B = Y); - pragma Assert ((X * Y) mod B = (X * Y) - (X * Y) / B * B); - pragma Assert - ((X * Y) mod B = (X * Y) - (X * (Y / B) * B) / B * B); - Lemma_Mult_Div (X * (Y / B), B); - pragma Assert (Left = 0); - pragma Assert (Left = Right); - end if; - end if; - end Lemma_Mult_Mod; - ----------------- -- Exp_Modular -- ----------------- @@ -241,35 +49,7 @@ is function Mult (X, Y : Unsigned) return Unsigned is (Unsigned (Long_Long_Unsigned (X) * Long_Long_Unsigned (Y) - mod Long_Long_Unsigned (Modulus))) - with - Pre => Modulus /= 0; - -- Modular multiplication. Note that we can't take advantage of the - -- compiler's circuit, because the modulus is not known statically. - - -- Local ghost variables, functions and lemmas - - M : constant Big_Positive := Big (Modulus) with Ghost; - - function Equal_Modulo (X, Y : Big_Integer) return Boolean is - (X mod M = Y mod M) - with - Ghost, - Pre => Modulus /= 0; - - procedure Lemma_Mult (X, Y : Unsigned) - with - Ghost, - Post => Big (Mult (X, Y)) = (Big (X) * Big (Y)) mod M - and then Big (Mult (X, Y)) < M; - - procedure Lemma_Mult (X, Y : Unsigned) is - begin - pragma Assert (Big (Mult (X, Y)) = (Big (X) * Big (Y)) mod M); - end Lemma_Mult; - - Rest : Big_Integer with Ghost; - -- Ghost variable to hold Factor**Exp between Exp and Factor updates + mod Long_Long_Unsigned (Modulus))); begin pragma Assert (Modulus /= 1); @@ -284,72 +64,18 @@ is if Exp /= 0 then loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Result < Modulus); - pragma Loop_Invariant (Equal_Modulo - (Big (Result) * Big (Factor) ** Exp, Big (Left) ** Right)); - pragma Loop_Variant (Decreases => Exp); - if Exp rem 2 /= 0 then - pragma Assert - (Big (Factor) ** Exp - = Big (Factor) * Big (Factor) ** (Exp - 1)); - pragma Assert (Equal_Modulo - ((Big (Result) * Big (Factor)) * Big (Factor) ** (Exp - 1), - Big (Left) ** Right)); - pragma Assert (Big (Factor) >= 0); - Lemma_Mult_Mod (Big (Result) * Big (Factor), - Big (Factor) ** (Exp - 1), - Big (Modulus)); - Lemma_Mult (Result, Factor); - Result := Mult (Result, Factor); - - Lemma_Mod_Ident (Big (Result), Big (Modulus)); - Lemma_Mod_Mod (Big (Factor) ** (Exp - 1), Big (Modulus)); - Lemma_Mult_Mod (Big (Result), - Big (Factor) ** (Exp - 1), - Big (Modulus)); - pragma Assert (Equal_Modulo - (Big (Result) * Big (Factor) ** (Exp - 1), - Big (Left) ** Right)); - Lemma_Exp_Expand (Big (Factor), Exp - 1); - pragma Assert (Exp / 2 = (Exp - 1) / 2); end if; - Lemma_Exp_Expand (Big (Factor), Exp); - Exp := Exp / 2; exit when Exp = 0; - Rest := Big (Factor) ** Exp; - pragma Assert (Equal_Modulo - (Big (Result) * (Rest * Rest), Big (Left) ** Right)); - Lemma_Exp_Mod (Big (Factor) * Big (Factor), Exp, Big (Modulus)); - pragma Assert - ((Big (Factor) * Big (Factor)) ** Exp = Rest * Rest); - pragma Assert (Equal_Modulo - ((Big (Factor) * Big (Factor)) ** Exp, - Rest * Rest)); - Lemma_Mult (Factor, Factor); - Factor := Mult (Factor, Factor); - - Lemma_Mod_Mod (Rest * Rest, Big (Modulus)); - Lemma_Mod_Ident (Big (Result), Big (Modulus)); - Lemma_Mult_Mod (Big (Result), Rest * Rest, Big (Modulus)); - pragma Assert (Big (Factor) >= 0); - Lemma_Mult_Mod (Big (Result), Big (Factor) ** Exp, - Big (Modulus)); - pragma Assert (Equal_Modulo - (Big (Result) * Big (Factor) ** Exp, Big (Left) ** Right)); end loop; - - pragma Assert (Big (Result) = Big (Left) ** Right mod Big (Modulus)); end if; return Result; - end Exp_Modular; end System.Exp_Mod; diff --git a/gcc/ada/libgnat/s-expmod.ads b/gcc/ada/libgnat/s-expmod.ads index 47ba39e..509ffa4 100644 --- a/gcc/ada/libgnat/s-expmod.ads +++ b/gcc/ada/libgnat/s-expmod.ads @@ -36,19 +36,6 @@ -- Note that 1 is a binary modulus (2**0), so the compiler should not (and -- will not) call this function with Modulus equal to 1. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - with System.Unsigned_Types; package System.Exp_Mod @@ -57,30 +44,10 @@ is use type System.Unsigned_Types.Unsigned; subtype Unsigned is System.Unsigned_Types.Unsigned; - use type Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer; - subtype Big_Integer is - Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Big_Integer - with Ghost; - - package Unsigned_Conversion is - new Ada.Numerics.Big_Numbers.Big_Integers_Ghost.Unsigned_Conversions - (Int => Unsigned); - - function Big (Arg : Unsigned) return Big_Integer is - (Unsigned_Conversion.To_Big_Integer (Arg)) - with Ghost; - - subtype Power_Of_2 is Unsigned with - Dynamic_Predicate => - Power_Of_2 /= 0 and then (Power_Of_2 and (Power_Of_2 - 1)) = 0; - function Exp_Modular (Left : Unsigned; Modulus : Unsigned; - Right : Natural) return Unsigned - with - Pre => Modulus /= 0 and then Modulus not in Power_Of_2, - Post => Big (Exp_Modular'Result) = Big (Left) ** Right mod Big (Modulus); + Right : Natural) return Unsigned; -- Return the power of ``Left`` by ``Right` modulo ``Modulus``. -- -- This function is implemented using the standard logarithmic approach: diff --git a/gcc/ada/libgnat/s-exponn.adb b/gcc/ada/libgnat/s-exponn.adb index ff79f5a..2aeb199 100644 --- a/gcc/ada/libgnat/s-exponn.adb +++ b/gcc/ada/libgnat/s-exponn.adb @@ -32,65 +32,6 @@ package body System.Exponn with SPARK_Mode is - - -- Preconditions, postconditions, ghost code, loop invariants and - -- assertions in this unit are meant for analysis only, not for run-time - -- checking, as it would be too costly otherwise. This is enforced by - -- setting the assertion policy to Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - -- Local lemmas - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => - (if Exp rem 2 = 0 then - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) - else - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A); - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) - with - Ghost, - Pre => In_Int_Range (A ** Exp * A ** Exp), - Post => In_Int_Range (A * A); - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => A ** Exp /= 0; - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0 - and then Exp rem 2 = 0, - Post => A ** Exp > 0; - - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Y /= 0 - and then not (X = -Big (Int'First) and Y = -1) - and then X * Y = Z - and then In_Int_Range (Z), - Post => In_Int_Range (X); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) is null; - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) is null; - ----------- -- Expon -- ----------- @@ -104,13 +45,7 @@ is Factor : Int := Left; Exp : Natural := Right; - Rest : Big_Integer with Ghost; - -- Ghost variable to hold Factor**Exp between Exp and Factor updates - begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "early returns for performance"); - -- We use the standard logarithmic approach, Exp gets shifted right -- testing successive low order bits and Factor is the value of the -- base raised to the next power of 2. @@ -122,117 +57,31 @@ is -- simpler, so we do it. if Right = 0 then - return 1; + Result := 1; elsif Left = 0 then - return 0; - end if; - - loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Factor /= 0); - pragma Loop_Invariant - (Big (Result) * Big (Factor) ** Exp = Big (Left) ** Right); - pragma Loop_Variant (Decreases => Exp); + Result := 0; + else + loop + if Exp rem 2 /= 0 then + declare + pragma Suppress (Overflow_Check); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; - if Exp rem 2 /= 0 then declare pragma Suppress (Overflow_Check); begin - pragma Assert - (Big (Factor) ** Exp - = Big (Factor) * Big (Factor) ** (Exp - 1)); - Lemma_Exp_Positive (Big (Factor), Exp - 1); - Lemma_Mult_In_Range (Big (Result) * Big (Factor), - Big (Factor) ** (Exp - 1), - Big (Left) ** Right); - - Result := Result * Factor; + Factor := Factor * Factor; end; - end if; - - Lemma_Exp_Expand (Big (Factor), Exp); - - Exp := Exp / 2; - exit when Exp = 0; - - Rest := Big (Factor) ** Exp; - pragma Assert - (Big (Result) * (Rest * Rest) = Big (Left) ** Right); - - declare - pragma Suppress (Overflow_Check); - begin - Lemma_Mult_In_Range (Rest * Rest, - Big (Result), - Big (Left) ** Right); - Lemma_Exp_In_Range (Big (Factor), Exp); - - Factor := Factor * Factor; - end; - - pragma Assert (Big (Factor) ** Exp = Rest * Rest); - end loop; - - pragma Assert (Big (Result) = Big (Left) ** Right); + end loop; + end if; return Result; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end Expon; - ---------------------- - -- Lemma_Exp_Expand -- - ---------------------- - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with - Pre => A /= 0 and then Natural'Last - Exp_2 >= Exp_1, - Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2); - - ---------------------------- - -- Lemma_Exp_Distribution -- - ---------------------------- - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null; - - begin - if Exp rem 2 = 0 then - pragma Assert (Exp = Exp / 2 + Exp / 2); - else - pragma Assert (Exp = Exp / 2 + Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, 1); - end if; - end Lemma_Exp_Expand; - - ------------------------ - -- Lemma_Exp_In_Range -- - ------------------------ - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) is - begin - if A /= 0 and Exp /= 1 then - pragma Assert (A ** Exp = A * A ** (Exp - 1)); - Lemma_Mult_In_Range - (A * A, A ** (Exp - 1) * A ** (Exp - 1), A ** Exp * A ** Exp); - end if; - end Lemma_Exp_In_Range; - - ------------------------ - -- Lemma_Exp_Positive -- - ------------------------ - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) is - begin - if Exp = 0 then - pragma Assert (A ** Exp = 1); - else - pragma Assert (Exp = 2 * (Exp / 2)); - pragma Assert (A ** Exp = A ** (Exp / 2) * A ** (Exp / 2)); - pragma Assert (A ** Exp = (A ** (Exp / 2)) ** 2); - Lemma_Exp_Not_Zero (A, Exp / 2); - end if; - end Lemma_Exp_Positive; - end System.Exponn; diff --git a/gcc/ada/libgnat/s-exponn.ads b/gcc/ada/libgnat/s-exponn.ads index 16bd393..94da5d2 100644 --- a/gcc/ada/libgnat/s-exponn.ads +++ b/gcc/ada/libgnat/s-exponn.ads @@ -32,44 +32,13 @@ -- This package provides functions for signed integer exponentiation. This -- is the version of the package with checks disabled. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic - type Int is range <>; package System.Exponn with Pure, SPARK_Mode is - -- Preconditions in this unit are meant for analysis only, not for run-time - -- checking, so that the expected exceptions are raised. This is enforced - -- by setting the corresponding assertion policy to Ignore. Postconditions - -- and contract cases should not be executed at runtime as well, in order - -- not to slow down the execution of these functions. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - use type BI_Ghost.Big_Integer; - - package Signed_Conversion is new BI_Ghost.Signed_Conversions (Int => Int); - - function Big (Arg : Int) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int_Range (Arg : Big_Integer) return Boolean is - (BI_Ghost.In_Range (Arg, Big (Int'First), Big (Int'Last))) - with Ghost; - - function Expon (Left : Int; Right : Natural) return Int - with - Pre => In_Int_Range (Big (Left) ** Right), - Post => Expon'Result = Left ** Right; + function Expon (Left : Int; Right : Natural) return Int; -- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned -- and if ``Right`` is 0 then 1 is returned. In all other cases the result -- is set to 1 and then computed in a loop as follows: diff --git a/gcc/ada/libgnat/s-expont.adb b/gcc/ada/libgnat/s-expont.adb index 39476a9..368dd0b 100644 --- a/gcc/ada/libgnat/s-expont.adb +++ b/gcc/ada/libgnat/s-expont.adb @@ -32,65 +32,6 @@ package body System.Expont with SPARK_Mode is - - -- Preconditions, postconditions, ghost code, loop invariants and - -- assertions in this unit are meant for analysis only, not for run-time - -- checking, as it would be too costly otherwise. This is enforced by - -- setting the assertion policy to Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - -- Local lemmas - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => - (if Exp rem 2 = 0 then - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) - else - A ** Exp = A ** (Exp / 2) * A ** (Exp / 2) * A); - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) - with - Ghost, - Pre => In_Int_Range (A ** Exp * A ** Exp), - Post => In_Int_Range (A * A); - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0, - Post => A ** Exp /= 0; - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) - with - Ghost, - Pre => A /= 0 - and then Exp rem 2 = 0, - Post => A ** Exp > 0; - - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) - with - Ghost, - Pre => Y /= 0 - and then not (X = -Big (Int'First) and Y = -1) - and then X * Y = Z - and then In_Int_Range (Z), - Post => In_Int_Range (X); - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Exp_Not_Zero (A : Big_Integer; Exp : Natural) is null; - procedure Lemma_Mult_In_Range (X, Y, Z : Big_Integer) is null; - ----------- -- Expon -- ----------- @@ -104,13 +45,7 @@ is Factor : Int := Left; Exp : Natural := Right; - Rest : Big_Integer with Ghost; - -- Ghost variable to hold Factor**Exp between Exp and Factor updates - begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "early returns for performance"); - -- We use the standard logarithmic approach, Exp gets shifted right -- testing successive low order bits and Factor is the value of the -- base raised to the next power of 2. @@ -122,117 +57,31 @@ is -- simpler, so we do it. if Right = 0 then - return 1; + Result := 1; elsif Left = 0 then - return 0; - end if; - - loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Factor /= 0); - pragma Loop_Invariant - (Big (Result) * Big (Factor) ** Exp = Big (Left) ** Right); - pragma Loop_Variant (Decreases => Exp); + Result := 0; + else + loop + if Exp rem 2 /= 0 then + declare + pragma Unsuppress (Overflow_Check); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; - if Exp rem 2 /= 0 then declare pragma Unsuppress (Overflow_Check); begin - pragma Assert - (Big (Factor) ** Exp - = Big (Factor) * Big (Factor) ** (Exp - 1)); - Lemma_Exp_Positive (Big (Factor), Exp - 1); - Lemma_Mult_In_Range (Big (Result) * Big (Factor), - Big (Factor) ** (Exp - 1), - Big (Left) ** Right); - - Result := Result * Factor; + Factor := Factor * Factor; end; - end if; - - Lemma_Exp_Expand (Big (Factor), Exp); - - Exp := Exp / 2; - exit when Exp = 0; - - Rest := Big (Factor) ** Exp; - pragma Assert - (Big (Result) * (Rest * Rest) = Big (Left) ** Right); - - declare - pragma Unsuppress (Overflow_Check); - begin - Lemma_Mult_In_Range (Rest * Rest, - Big (Result), - Big (Left) ** Right); - Lemma_Exp_In_Range (Big (Factor), Exp); - - Factor := Factor * Factor; - end; - - pragma Assert (Big (Factor) ** Exp = Rest * Rest); - end loop; - - pragma Assert (Big (Result) = Big (Left) ** Right); + end loop; + end if; return Result; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); end Expon; - ---------------------- - -- Lemma_Exp_Expand -- - ---------------------- - - procedure Lemma_Exp_Expand (A : Big_Integer; Exp : Natural) is - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) with - Pre => A /= 0 and then Natural'Last - Exp_2 >= Exp_1, - Post => A ** (Exp_1 + Exp_2) = A ** (Exp_1) * A ** (Exp_2); - - ---------------------------- - -- Lemma_Exp_Distribution -- - ---------------------------- - - procedure Lemma_Exp_Distribution (Exp_1, Exp_2 : Natural) is null; - - begin - if Exp rem 2 = 0 then - pragma Assert (Exp = Exp / 2 + Exp / 2); - else - pragma Assert (Exp = Exp / 2 + Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, Exp / 2 + 1); - Lemma_Exp_Distribution (Exp / 2, 1); - end if; - end Lemma_Exp_Expand; - - ------------------------ - -- Lemma_Exp_In_Range -- - ------------------------ - - procedure Lemma_Exp_In_Range (A : Big_Integer; Exp : Positive) is - begin - if A /= 0 and Exp /= 1 then - pragma Assert (A ** Exp = A * A ** (Exp - 1)); - Lemma_Mult_In_Range - (A * A, A ** (Exp - 1) * A ** (Exp - 1), A ** Exp * A ** Exp); - end if; - end Lemma_Exp_In_Range; - - ------------------------ - -- Lemma_Exp_Positive -- - ------------------------ - - procedure Lemma_Exp_Positive (A : Big_Integer; Exp : Natural) is - begin - if Exp = 0 then - pragma Assert (A ** Exp = 1); - else - pragma Assert (Exp = 2 * (Exp / 2)); - pragma Assert (A ** Exp = A ** (Exp / 2) * A ** (Exp / 2)); - pragma Assert (A ** Exp = (A ** (Exp / 2)) ** 2); - Lemma_Exp_Not_Zero (A, Exp / 2); - end if; - end Lemma_Exp_Positive; - end System.Expont; diff --git a/gcc/ada/libgnat/s-expont.ads b/gcc/ada/libgnat/s-expont.ads index 880e054..2cf6dc0 100644 --- a/gcc/ada/libgnat/s-expont.ads +++ b/gcc/ada/libgnat/s-expont.ads @@ -32,44 +32,13 @@ -- This package provides functions for signed integer exponentiation. This -- is the version of the package with checks enabled. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic - type Int is range <>; package System.Expont with Pure, SPARK_Mode is - -- Preconditions in this unit are meant for analysis only, not for run-time - -- checking, so that the expected exceptions are raised. This is enforced - -- by setting the corresponding assertion policy to Ignore. Postconditions - -- and contract cases should not be executed at runtime as well, in order - -- not to slow down the execution of these functions. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - use type BI_Ghost.Big_Integer; - - package Signed_Conversion is new BI_Ghost.Signed_Conversions (Int => Int); - - function Big (Arg : Int) return Big_Integer is - (Signed_Conversion.To_Big_Integer (Arg)) - with Ghost; - - function In_Int_Range (Arg : Big_Integer) return Boolean is - (BI_Ghost.In_Range (Arg, Big (Int'First), Big (Int'Last))) - with Ghost; - - function Expon (Left : Int; Right : Natural) return Int - with - Pre => In_Int_Range (Big (Left) ** Right), - Post => Expon'Result = Left ** Right; + function Expon (Left : Int; Right : Natural) return Int; -- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned -- and if ``Right`` is 0 then 1 is returned. In all other cases the result -- is set to 1 and then computed in a loop as follows: diff --git a/gcc/ada/libgnat/s-exponu.adb b/gcc/ada/libgnat/s-exponu.adb index abb1930..0c52833 100644 --- a/gcc/ada/libgnat/s-exponu.adb +++ b/gcc/ada/libgnat/s-exponu.adb @@ -29,20 +29,7 @@ -- -- ------------------------------------------------------------------------------ -function System.Exponu (Left : Int; Right : Natural) return Int - with SPARK_Mode -is - -- Preconditions, postconditions, ghost code, loop invariants and - -- assertions in this unit are meant for analysis only, not for run-time - -- checking, as it would be too costly otherwise. This is enforced by - -- setting the assertion policy to Ignore. - - pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - +function System.Exponu (Left : Int; Right : Natural) return Int is -- Note that negative exponents get a constraint error because the -- subtype of the Right argument (the exponent) is Natural. @@ -61,16 +48,7 @@ begin if Exp /= 0 then loop - pragma Loop_Invariant (Exp > 0); - pragma Loop_Invariant (Result * Factor ** Exp = Left ** Right); - pragma Loop_Variant (Decreases => Exp); - if Exp rem 2 /= 0 then - pragma Assert - (Result * (Factor * Factor ** (Exp - 1)) = Left ** Right); - pragma Assert - ((Result * Factor) * Factor ** (Exp - 1) = Left ** Right); - Result := Result * Factor; end if; diff --git a/gcc/ada/libgnat/s-exponu.ads b/gcc/ada/libgnat/s-exponu.ads index cfa6d78..7cc2f9c 100644 --- a/gcc/ada/libgnat/s-exponu.ads +++ b/gcc/ada/libgnat/s-exponu.ads @@ -31,25 +31,10 @@ -- This function implements unsigned integer exponentiation --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - generic - type Int is mod <>; -function System.Exponu (Left : Int; Right : Natural) return Int -with - SPARK_Mode, - Post => System.Exponu'Result = Left ** Right; +function System.Exponu (Left : Int; Right : Natural) return Int; -- Calculate ``Left`` ** ``Right``. If ``Left`` is 0 then 0 is returned -- and if ``Right`` is 0 then 1 is returned. In all other cases the result -- is set to 1 and then computed in a loop as follows: diff --git a/gcc/ada/libgnat/s-expuns.ads b/gcc/ada/libgnat/s-expuns.ads index 98ad607..d1dcc25 100644 --- a/gcc/ada/libgnat/s-expuns.ads +++ b/gcc/ada/libgnat/s-expuns.ads @@ -35,24 +35,12 @@ -- The result is always full width, the caller must do a masking operation -- the modulus is less than 2 ** (Unsigned'Size). --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced --- by setting the corresponding assertion policy to Ignore. Postconditions --- and contract cases should not be executed at runtime as well, in order --- not to slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Exponu; with System.Unsigned_Types; package System.Exp_Uns with SPARK_Mode is - subtype Unsigned is Unsigned_Types.Unsigned; function Exp_Unsigned is new Exponu (Unsigned); diff --git a/gcc/ada/libgnat/s-imaged.adb b/gcc/ada/libgnat/s-imaged.adb index 34c15b0..638e37b 100644 --- a/gcc/ada/libgnat/s-imaged.adb +++ b/gcc/ada/libgnat/s-imaged.adb @@ -31,33 +31,10 @@ with System.Image_I; with System.Img_Util; use System.Img_Util; -with System.Value_I_Spec; -with System.Value_U_Spec; package body System.Image_D is - -- Contracts, ghost code, loop invariants and assertions in this unit are - -- meant for analysis only, not for run-time checking, as it would be too - -- costly otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Assert => Ignore, - Assert_And_Cut => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Pre => Ignore, - Post => Ignore, - Subprogram_Variant => Ignore); - - package Uns_Spec is new System.Value_U_Spec (Uns); - package Int_Spec is new System.Value_I_Spec (Int, Uns, Uns_Spec); - - package Image_I is new System.Image_I - (Int => Int, - Uns => Uns, - U_Spec => Uns_Spec, - I_Spec => Int_Spec); + package Image_I is new System.Image_I (Int); procedure Set_Image_Integer (V : Int; @@ -76,7 +53,6 @@ package body System.Image_D is Scale : Integer) is pragma Assert (S'First = 1); - begin -- Add space at start for non-negative numbers diff --git a/gcc/ada/libgnat/s-imaged.ads b/gcc/ada/libgnat/s-imaged.ads index 1b83a67..48d4b00 100644 --- a/gcc/ada/libgnat/s-imaged.ads +++ b/gcc/ada/libgnat/s-imaged.ads @@ -34,10 +34,7 @@ -- types. generic - type Int is range <>; - type Uns is mod <>; - package System.Image_D is procedure Image_Decimal diff --git a/gcc/ada/libgnat/s-imagef.adb b/gcc/ada/libgnat/s-imagef.adb index 00b4ac5..c84f424 100644 --- a/gcc/ada/libgnat/s-imagef.adb +++ b/gcc/ada/libgnat/s-imagef.adb @@ -31,25 +31,9 @@ with System.Image_I; with System.Img_Util; use System.Img_Util; -with System.Value_I_Spec; -with System.Value_U_Spec; package body System.Image_F is - -- Contracts, ghost code, loop invariants and assertions in this unit are - -- meant for analysis only, not for run-time checking, as it would be too - -- costly otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Assert => Ignore, - Assert_And_Cut => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Loop_Invariant => Ignore, - Pre => Ignore, - Post => Ignore, - Subprogram_Variant => Ignore); - Maxdigs : constant Natural := Int'Width - 2; -- Maximum number of decimal digits that can be represented in an Int. -- The "-2" accounts for the sign and one extra digit, since we need the @@ -70,14 +54,7 @@ package body System.Image_F is -- if the small is larger than 1, and smaller than 2**(Int'Size - 1) / 10 -- if the small is smaller than 1. - package Uns_Spec is new System.Value_U_Spec (Uns); - package Int_Spec is new System.Value_I_Spec (Int, Uns, Uns_Spec); - - package Image_I is new System.Image_I - (Int => Int, - Uns => Uns, - U_Spec => Uns_Spec, - I_Spec => Int_Spec); + package Image_I is new System.Image_I (Int); procedure Set_Image_Integer (V : Int; @@ -233,7 +210,6 @@ package body System.Image_F is Aft0 : Natural) is pragma Assert (S'First = 1); - begin -- Add space at start for non-negative numbers diff --git a/gcc/ada/libgnat/s-imagef.ads b/gcc/ada/libgnat/s-imagef.ads index fea63c6..f73eed8 100644 --- a/gcc/ada/libgnat/s-imagef.ads +++ b/gcc/ada/libgnat/s-imagef.ads @@ -34,9 +34,7 @@ -- point types whose Small is the ratio of two Int values. generic - type Int is range <>; - type Uns is mod <>; with procedure Scaled_Divide (X, Y, Z : Int; diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb index e6aaf83..0f2211b 100644 --- a/gcc/ada/libgnat/s-imagei.adb +++ b/gcc/ada/libgnat/s-imagei.adb @@ -29,106 +29,18 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - -with System.Val_Spec; - package body System.Image_I is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Pre => Ignore, - Post => Ignore, - Subprogram_Variant => Ignore); - subtype Non_Positive is Int range Int'First .. 0; - function Uns_Of_Non_Positive (T : Non_Positive) return Uns is - (if T = Int'First then Uns (Int'Last) + 1 else Uns (-T)); - procedure Set_Digits (T : Non_Positive; S : in out String; - P : in out Natural) - with - Pre => P < Integer'Last - and then S'Last < Integer'Last - and then S'First <= P + 1 - and then S'First <= S'Last - and then P <= S'Last - Unsigned_Width_Ghost + 1, - Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) - and then P in P'Old + 1 .. S'Last - and then UP.Only_Decimal_Ghost (S, From => P'Old + 1, To => P) - and then UP.Scan_Based_Number_Ghost (S, From => P'Old + 1, To => P) - = UP.Wrap_Option (Uns_Of_Non_Positive (T)); + P : in out Natural); -- Set digits of absolute value of T, which is zero or negative. We work -- with the negative of the value so that the largest negative number is -- not a special case. - package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns); - - function Big (Arg : Uns) return Big_Integer renames - Unsigned_Conversion.To_Big_Integer; - - function From_Big (Arg : Big_Integer) return Uns renames - Unsigned_Conversion.From_Big_Integer; - - Big_10 : constant Big_Integer := Big (10) with Ghost; - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Non_Zero (X : Uns) - with - Ghost, - Pre => X /= 0, - Post => Big (X) /= 0; - - procedure Lemma_Div_Commutation (X, Y : Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Non_Zero (X : Uns) is null; - procedure Lemma_Div_Commutation (X, Y : Uns) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - ------------------- -- Image_Integer -- ------------------- @@ -139,44 +51,6 @@ package body System.Image_I is P : out Natural) is pragma Assert (S'First = 1); - - procedure Prove_Value_Integer - with - Ghost, - Pre => S'First = 1 - and then S'Last < Integer'Last - and then P in 2 .. S'Last - and then S (1) in ' ' | '-' - and then (S (1) = '-') = (V < 0) - and then UP.Only_Decimal_Ghost (S, From => 2, To => P) - and then UP.Scan_Based_Number_Ghost (S, From => 2, To => P) - = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V)), - Post => not System.Val_Spec.Only_Space_Ghost (S, 1, P) - and then IP.Is_Integer_Ghost (S (1 .. P)) - and then IP.Is_Value_Integer_Ghost (S (1 .. P), V); - -- Ghost lemma to prove the value of Value_Integer from the value of - -- Scan_Based_Number_Ghost and the sign on a decimal string. - - ------------------------- - -- Prove_Value_Integer -- - ------------------------- - - procedure Prove_Value_Integer is - Str : constant String := S (1 .. P); - begin - pragma Assert (Str'First = 1); - pragma Assert (Str (2) /= ' '); - pragma Assert - (UP.Only_Decimal_Ghost (Str, From => 2, To => P)); - UP.Prove_Scan_Based_Number_Ghost_Eq (S, Str, From => 2, To => P); - pragma Assert - (UP.Scan_Based_Number_Ghost (Str, From => 2, To => P) - = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V))); - IP.Prove_Scan_Only_Decimal_Ghost (Str, V); - end Prove_Value_Integer; - - -- Start of processing for Image_Integer - begin if V >= 0 then pragma Annotate (CodePeer, False_Positive, "test always false", @@ -190,18 +64,7 @@ package body System.Image_I is pragma Assert (P < S'Last - 1); end if; - declare - P_Prev : constant Integer := P with Ghost; - Offset : constant Positive := (if V >= 0 then 1 else 2) with Ghost; - begin - Set_Image_Integer (V, S, P); - - pragma Assert (P_Prev + Offset = 2); - end; - pragma Assert (if V >= 0 then S (1) = ' '); - pragma Assert (S (1) in ' ' | '-'); - - Prove_Value_Integer; + Set_Image_Integer (V, S, P); end Image_Integer; ---------------- @@ -215,136 +78,6 @@ package body System.Image_I is is Nb_Digits : Natural := 0; Value : Non_Positive := T; - - -- Local ghost variables - - Pow : Big_Positive := 1 with Ghost; - S_Init : constant String := S with Ghost; - Uns_T : constant Uns := Uns_Of_Non_Positive (T) with Ghost; - Uns_Value : Uns := Uns_Of_Non_Positive (Value) with Ghost; - Prev_Value : Uns with Ghost; - Prev_S : String := S with Ghost; - - -- Local ghost lemmas - - procedure Prove_Character_Val (RU : Uns; RI : Non_Positive) - with - Ghost, - Post => RU rem 10 in 0 .. 9 - and then -(RI rem 10) in 0 .. 9 - and then Character'Val (48 + RU rem 10) in '0' .. '9' - and then Character'Val (48 - RI rem 10) in '0' .. '9'; - -- Ghost lemma to prove the value of a character corresponding to the - -- next figure. - - procedure Prove_Euclidian (Val, Quot, Rest : Uns) - with - Ghost, - Pre => Quot = Val / 10 - and then Rest = Val rem 10, - Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest; - -- Ghost lemma to prove the relation between the quotient/remainder of - -- division by 10 and the initial value. - - procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) - with - Ghost, - Pre => RU in 0 .. 9 - and then RI in 0 .. 9, - Post => UP.Hexa_To_Unsigned_Ghost - (Character'Val (48 + RU)) = RU - and then UP.Hexa_To_Unsigned_Ghost - (Character'Val (48 + RI)) = Uns (RI); - -- Ghost lemma to prove that Hexa_To_Unsigned_Ghost returns the source - -- figure when applied to the corresponding character. - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - with - Ghost, - Pre => - S'First = Prev_S'First and then S'Last = Prev_S'Last - and then S'Last < Natural'Last and then - Max in S'Range and then P in S'First .. Max and then - (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9') - and then (for all I in P + 1 .. Max => Prev_S (I) = S (I)) - and then S (P) in '0' .. '9' - and then V <= Uns'Last / 10 - and then Uns'Last - UP.Hexa_To_Unsigned_Ghost (S (P)) - >= 10 * V - and then Prev_V = - V * 10 + UP.Hexa_To_Unsigned_Ghost (S (P)) - and then - (if P = Max then Prev_V = Res - else UP.Scan_Based_Number_Ghost - (Str => Prev_S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V) = UP.Wrap_Option (Res)), - Post => - (for all I in P .. Max => S (I) in '0' .. '9') - and then UP.Scan_Based_Number_Ghost - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V) = UP.Wrap_Option (Res); - -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved - -- through an iteration of the loop. - - procedure Prove_Uns_Of_Non_Positive_Value - with - Ghost, - Pre => Uns_Value = Uns_Of_Non_Positive (Value), - Post => Uns_Value / 10 = Uns_Of_Non_Positive (Value / 10) - and then Uns_Value rem 10 = Uns_Of_Non_Positive (Value rem 10); - -- Ghost lemma to prove that the relation between Value and its unsigned - -- version is preserved. - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Character_Val (RU : Uns; RI : Non_Positive) is null; - procedure Prove_Euclidian (Val, Quot, Rest : Uns) is null; - procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) is null; - procedure Prove_Uns_Of_Non_Positive_Value is null; - - --------------------- - -- Prove_Scan_Iter -- - --------------------- - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - is - pragma Unreferenced (Res); - begin - UP.Lemma_Scan_Based_Number_Ghost_Step - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V); - if P < Max then - UP.Prove_Scan_Based_Number_Ghost_Eq - (Prev_S, S, P + 1, Max, 10, Prev_V); - else - UP.Lemma_Scan_Based_Number_Ghost_Base - (Str => S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V); - end if; - end Prove_Scan_Iter; - - -- Start of processing for Set_Digits - begin pragma Assert (P >= S'First - 1 and P < S'Last); -- No check is done since, as documented in the Set_Image_Integer @@ -354,90 +87,20 @@ package body System.Image_I is -- First we compute the number of characters needed for representing -- the number. loop - Lemma_Div_Commutation (Uns_Of_Non_Positive (Value), 10); - Lemma_Div_Twice (Big (Uns_Of_Non_Positive (T)), - Big_10 ** Nb_Digits, Big_10); - Prove_Uns_Of_Non_Positive_Value; - Value := Value / 10; Nb_Digits := Nb_Digits + 1; - Uns_Value := Uns_Value / 10; - Pow := Pow * 10; - - pragma Loop_Invariant (Uns_Value = Uns_Of_Non_Positive (Value)); - pragma Loop_Invariant (Nb_Digits in 1 .. Unsigned_Width_Ghost - 1); - pragma Loop_Invariant (Pow = Big_10 ** Nb_Digits); - pragma Loop_Invariant (Big (Uns_Value) = Big (Uns_T) / Pow); - pragma Loop_Variant (Increases => Value); - exit when Value = 0; - - Lemma_Non_Zero (Uns_Value); - pragma Assert (Pow <= Big (Uns'Last)); end loop; Value := T; - Uns_Value := Uns_Of_Non_Positive (T); - Pow := 1; - - pragma Assert (Uns_Value = From_Big (Big (Uns_T) / Big_10 ** 0)); -- We now populate digits from the end of the string to the beginning for J in reverse 1 .. Nb_Digits loop - Lemma_Div_Commutation (Uns_Value, 10); - Lemma_Div_Twice (Big (Uns_T), Big_10 ** (Nb_Digits - J), Big_10); - Prove_Character_Val (Uns_Value, Value); - Prove_Hexa_To_Unsigned_Ghost (Uns_Value rem 10, -(Value rem 10)); - Prove_Uns_Of_Non_Positive_Value; - - Prev_Value := Uns_Value; - Prev_S := S; - Pow := Pow * 10; - Uns_Value := Uns_Value / 10; - S (P + J) := Character'Val (48 - (Value rem 10)); Value := Value / 10; - - Prove_Euclidian - (Val => Prev_Value, - Quot => Uns_Value, - Rest => UP.Hexa_To_Unsigned_Ghost (S (P + J))); - - Prove_Scan_Iter - (S, Prev_S, Uns_Value, Prev_Value, Uns_T, P + J, P + Nb_Digits); - - pragma Loop_Invariant (Uns_Value = Uns_Of_Non_Positive (Value)); - pragma Loop_Invariant (Uns_Value <= Uns'Last / 10); - pragma Loop_Invariant - (for all K in S'First .. P => S (K) = S_Init (K)); - pragma Loop_Invariant - (UP.Only_Decimal_Ghost (S, P + J, P + Nb_Digits)); - pragma Loop_Invariant - (for all K in P + J .. P + Nb_Digits => S (K) in '0' .. '9'); - pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1)); - pragma Loop_Invariant (Big (Uns_Value) = Big (Uns_T) / Pow); - pragma Loop_Invariant - (UP.Scan_Based_Number_Ghost - (Str => S, - From => P + J, - To => P + Nb_Digits, - Base => 10, - Acc => Uns_Value) - = UP.Wrap_Option (Uns_T)); end loop; - pragma Assert (Big (Uns_Value) = Big (Uns_T) / Big_10 ** (Nb_Digits)); - pragma Assert (Uns_Value = 0); - pragma Assert - (UP.Scan_Based_Number_Ghost - (Str => S, - From => P + 1, - To => P + Nb_Digits, - Base => 10, - Acc => Uns_Value) - = UP.Wrap_Option (Uns_T)); - P := P + Nb_Digits; end Set_Digits; @@ -448,12 +111,10 @@ package body System.Image_I is procedure Set_Image_Integer (V : Int; S : in out String; - P : in out Natural) - is + P : in out Natural) is begin if V >= 0 then Set_Digits (-V, S, P); - else pragma Assert (P >= S'First - 1 and P < S'Last); -- No check is done since, as documented in the specification, diff --git a/gcc/ada/libgnat/s-imagei.ads b/gcc/ada/libgnat/s-imagei.ads index e500f74..8d3b939 100644 --- a/gcc/ada/libgnat/s-imagei.ads +++ b/gcc/ada/libgnat/s-imagei.ads @@ -33,48 +33,14 @@ -- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer -- types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_I_Spec; -with System.Value_U_Spec; - generic type Int is range <>; - type Uns is mod <>; - - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - with package I_Spec is new System.Value_I_Spec - (Int => Int, Uns => Uns, U_Spec => U_Spec) with Ghost; - package System.Image_I is - package IP renames I_Spec; - package UP renames U_Spec; - use type UP.Uns_Option; - - Unsigned_Width_Ghost : constant Natural := U_Spec.Max_Log10 + 2 with Ghost; procedure Image_Integer (V : Int; S : in out String; - P : out Natural) - with - Pre => S'First = 1 - and then S'Last < Integer'Last - and then S'Last >= Unsigned_Width_Ghost, - Post => P in S'Range - and then IP.Is_Value_Integer_Ghost (S (1 .. P), V); + P : out Natural); -- Computes Int'Image (V) and stores the result in S (1 .. P) -- setting the resulting value of P. The caller guarantees that S -- is long enough to hold the result, and that S'First is 1. @@ -82,31 +48,7 @@ package System.Image_I is procedure Set_Image_Integer (V : Int; S : in out String; - P : in out Natural) - with - Pre => P < Integer'Last - and then S'Last < Integer'Last - and then S'First <= P + 1 - and then S'First <= S'Last - and then - (if V >= 0 then - P <= S'Last - Unsigned_Width_Ghost + 1 - else - P <= S'Last - Unsigned_Width_Ghost), - Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) - and then - (declare - Minus : constant Boolean := S (P'Old + 1) = '-'; - Offset : constant Positive := (if V >= 0 then 1 else 2); - Abs_V : constant Uns := IP.Abs_Uns_Of_Int (V); - begin - Minus = (V < 0) - and then P in P'Old + Offset .. S'Last - and then UP.Only_Decimal_Ghost - (S, From => P'Old + Offset, To => P) - and then UP.Scan_Based_Number_Ghost - (S, From => P'Old + Offset, To => P) - = UP.Wrap_Option (Abs_V)); + P : in out Natural); -- Stores the image of V in S starting at S (P + 1), P is updated to point -- to the last character stored. The value stored is identical to the value -- of Int'Image (V) except that no leading space is stored when V is diff --git a/gcc/ada/libgnat/s-imageu.adb b/gcc/ada/libgnat/s-imageu.adb index 820156b..a6cdfed 100644 --- a/gcc/ada/libgnat/s-imageu.adb +++ b/gcc/ada/libgnat/s-imageu.adb @@ -29,79 +29,8 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -with System.Val_Spec; - package body System.Image_U is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - - package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns); - - function Big (Arg : Uns) return Big_Integer renames - Unsigned_Conversion.To_Big_Integer; - - function From_Big (Arg : Big_Integer) return Uns renames - Unsigned_Conversion.From_Big_Integer; - - Big_10 : constant Big_Integer := Big (10) with Ghost; - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Non_Zero (X : Uns) - with - Ghost, - Pre => X /= 0, - Post => Big (X) /= 0; - - procedure Lemma_Div_Commutation (X, Y : Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Non_Zero (X : Uns) is null; - procedure Lemma_Div_Commutation (X, Y : Uns) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - -------------------- -- Image_Unsigned -- -------------------- @@ -112,50 +41,10 @@ package body System.Image_U is P : out Natural) is pragma Assert (S'First = 1); - - procedure Prove_Value_Unsigned - with - Ghost, - Pre => S'First = 1 - and then S'Last < Integer'Last - and then P in 2 .. S'Last - and then S (1) = ' ' - and then U_Spec.Only_Decimal_Ghost (S, From => 2, To => P) - and then U_Spec.Scan_Based_Number_Ghost (S, From => 2, To => P) - = U_Spec.Wrap_Option (V), - Post => not System.Val_Spec.Only_Space_Ghost (S, 1, P) - and then U_Spec.Is_Unsigned_Ghost (S (1 .. P)) - and then U_Spec.Is_Value_Unsigned_Ghost (S (1 .. P), V); - -- Ghost lemma to prove the value of Value_Unsigned from the value of - -- Scan_Based_Number_Ghost on a decimal string. - - -------------------------- - -- Prove_Value_Unsigned -- - -------------------------- - - procedure Prove_Value_Unsigned is - Str : constant String := S (1 .. P); - begin - pragma Assert (Str'First = 1); - pragma Assert (S (2) /= ' '); - pragma Assert - (U_Spec.Only_Decimal_Ghost (Str, From => 2, To => P)); - U_Spec.Prove_Scan_Based_Number_Ghost_Eq - (S, Str, From => 2, To => P); - pragma Assert - (U_Spec.Scan_Based_Number_Ghost (Str, From => 2, To => P) - = U_Spec.Wrap_Option (V)); - U_Spec.Prove_Scan_Only_Decimal_Ghost (Str, V); - end Prove_Value_Unsigned; - - -- Start of processing for Image_Unsigned - begin S (1) := ' '; P := 1; Set_Image_Unsigned (V, S, P); - - Prove_Value_Unsigned; end Image_Unsigned; ------------------------ @@ -169,118 +58,6 @@ package body System.Image_U is is Nb_Digits : Natural := 0; Value : Uns := V; - - -- Local ghost variables - - Pow : Big_Positive := 1 with Ghost; - S_Init : constant String := S with Ghost; - Prev_Value : Uns with Ghost; - Prev_S : String := S with Ghost; - - -- Local ghost lemmas - - procedure Prove_Character_Val (R : Uns) - with - Ghost, - Post => R rem 10 in 0 .. 9 - and then Character'Val (48 + R rem 10) in '0' .. '9'; - -- Ghost lemma to prove the value of a character corresponding to the - -- next figure. - - procedure Prove_Euclidian (Val, Quot, Rest : Uns) - with - Ghost, - Pre => Quot = Val / 10 - and then Rest = Val rem 10, - Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest; - -- Ghost lemma to prove the relation between the quotient/remainder of - -- division by 10 and the initial value. - - procedure Prove_Hexa_To_Unsigned_Ghost (R : Uns) - with - Ghost, - Pre => R in 0 .. 9, - Post => U_Spec.Hexa_To_Unsigned_Ghost (Character'Val (48 + R)) = R; - -- Ghost lemma to prove that Hexa_To_Unsigned_Ghost returns the source - -- figure when applied to the corresponding character. - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - with - Ghost, - Pre => - S'First = Prev_S'First and then S'Last = Prev_S'Last - and then S'Last < Natural'Last and then - Max in S'Range and then P in S'First .. Max and then - (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9') - and then (for all I in P + 1 .. Max => Prev_S (I) = S (I)) - and then S (P) in '0' .. '9' - and then V <= Uns'Last / 10 - and then Uns'Last - U_Spec.Hexa_To_Unsigned_Ghost (S (P)) - >= 10 * V - and then Prev_V = - V * 10 + U_Spec.Hexa_To_Unsigned_Ghost (S (P)) - and then - (if P = Max then Prev_V = Res - else U_Spec.Scan_Based_Number_Ghost - (Str => Prev_S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V) = U_Spec.Wrap_Option (Res)), - Post => - (for all I in P .. Max => S (I) in '0' .. '9') - and then U_Spec.Scan_Based_Number_Ghost - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V) = U_Spec.Wrap_Option (Res); - -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved - -- through an iteration of the loop. - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Prove_Character_Val (R : Uns) is null; - procedure Prove_Euclidian (Val, Quot, Rest : Uns) is null; - procedure Prove_Hexa_To_Unsigned_Ghost (R : Uns) is null; - - --------------------- - -- Prove_Scan_Iter -- - --------------------- - - procedure Prove_Scan_Iter - (S, Prev_S : String; - V, Prev_V, Res : Uns; - P, Max : Natural) - is - pragma Unreferenced (Res); - begin - U_Spec.Lemma_Scan_Based_Number_Ghost_Step - (Str => S, - From => P, - To => Max, - Base => 10, - Acc => V); - if P < Max then - U_Spec.Prove_Scan_Based_Number_Ghost_Eq - (Prev_S, S, P + 1, Max, 10, Prev_V); - else - U_Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str => S, - From => P + 1, - To => Max, - Base => 10, - Acc => Prev_V); - end if; - end Prove_Scan_Iter; - - -- Start of processing for Set_Image_Unsigned - begin pragma Assert (P >= S'First - 1 and then P < S'Last and then P < Natural'Last); @@ -290,70 +67,19 @@ package body System.Image_U is -- First we compute the number of characters needed for representing -- the number. loop - Lemma_Div_Commutation (Value, 10); - Lemma_Div_Twice (Big (V), Big_10 ** Nb_Digits, Big_10); - Value := Value / 10; Nb_Digits := Nb_Digits + 1; - Pow := Pow * 10; - - pragma Loop_Invariant (Nb_Digits in 1 .. Unsigned_Width_Ghost - 1); - pragma Loop_Invariant (Pow = Big_10 ** Nb_Digits); - pragma Loop_Invariant (Big (Value) = Big (V) / Pow); - pragma Loop_Variant (Decreases => Value); exit when Value = 0; - - Lemma_Non_Zero (Value); - pragma Assert (Pow <= Big (Uns'Last)); end loop; - pragma Assert (Big (V) / (Big_10 ** Nb_Digits) = 0); Value := V; - Pow := 1; - - pragma Assert (Value = From_Big (Big (V) / Big_10 ** 0)); -- We now populate digits from the end of the string to the beginning for J in reverse 1 .. Nb_Digits loop - Lemma_Div_Commutation (Value, 10); - Lemma_Div_Twice (Big (V), Big_10 ** (Nb_Digits - J), Big_10); - Prove_Character_Val (Value); - Prove_Hexa_To_Unsigned_Ghost (Value rem 10); - - Prev_Value := Value; - Prev_S := S; - Pow := Pow * 10; S (P + J) := Character'Val (48 + (Value rem 10)); Value := Value / 10; - - Prove_Euclidian - (Val => Prev_Value, - Quot => Value, - Rest => U_Spec.Hexa_To_Unsigned_Ghost (S (P + J))); - - Prove_Scan_Iter - (S, Prev_S, Value, Prev_Value, V, P + J, P + Nb_Digits); - - pragma Loop_Invariant (Value <= Uns'Last / 10); - pragma Loop_Invariant - (for all K in S'First .. P => S (K) = S_Init (K)); - pragma Loop_Invariant - (U_Spec.Only_Decimal_Ghost - (S, From => P + J, To => P + Nb_Digits)); - pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1)); - pragma Loop_Invariant (Big (Value) = Big (V) / Pow); - pragma Loop_Invariant - (U_Spec.Scan_Based_Number_Ghost - (Str => S, - From => P + J, - To => P + Nb_Digits, - Base => 10, - Acc => Value) - = U_Spec.Wrap_Option (V)); end loop; - pragma Assert (Big (Value) = Big (V) / (Big_10 ** Nb_Digits)); - pragma Assert (Value = 0); P := P + Nb_Digits; end Set_Image_Unsigned; diff --git a/gcc/ada/libgnat/s-imageu.ads b/gcc/ada/libgnat/s-imageu.ads index 720de40..8640a5b 100644 --- a/gcc/ada/libgnat/s-imageu.ads +++ b/gcc/ada/libgnat/s-imageu.ads @@ -33,44 +33,15 @@ -- and ``Ada.Text_IO.Modular_IO`` conversions routines for modular integer -- types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_U_Spec; - generic - type Uns is mod <>; - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - package System.Image_U is - use all type U_Spec.Uns_Option; - - Unsigned_Width_Ghost : constant Natural := U_Spec.Max_Log10 + 2 with Ghost; procedure Image_Unsigned (V : Uns; S : in out String; - P : out Natural) - with - Pre => S'First = 1 - and then S'Last < Integer'Last - and then S'Last >= Unsigned_Width_Ghost, - Post => P in S'Range - and then U_Spec.Is_Value_Unsigned_Ghost (S (1 .. P), V); - pragma Inline (Image_Unsigned); + P : out Natural) with Inline; -- Computes Uns'Image (V) and stores the result in S (1 .. P) setting -- the resulting value of P. The caller guarantees that S is long enough to -- hold the result, and that S'First is 1. @@ -78,19 +49,7 @@ package System.Image_U is procedure Set_Image_Unsigned (V : Uns; S : in out String; - P : in out Natural) - with - Pre => P < Integer'Last - and then S'Last < Integer'Last - and then S'First <= P + 1 - and then S'First <= S'Last - and then P <= S'Last - Unsigned_Width_Ghost + 1, - Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) - and then P in P'Old + 1 .. S'Last - and then U_Spec.Only_Decimal_Ghost (S, From => P'Old + 1, To => P) - and then U_Spec.Scan_Based_Number_Ghost - (S, From => P'Old + 1, To => P) - = U_Spec.Wrap_Option (V); + P : in out Natural); -- Stores the image of V in S starting at S (P + 1), P is updated to point -- to the last character stored. The value stored is identical to the value -- of Uns'Image (V) except that no leading space is stored. The caller diff --git a/gcc/ada/libgnat/s-imde128.ads b/gcc/ada/libgnat/s-imde128.ads index f353f57..03485b9 100644 --- a/gcc/ada/libgnat/s-imde128.ads +++ b/gcc/ada/libgnat/s-imde128.ads @@ -39,9 +39,8 @@ with System.Image_D; package System.Img_Decimal_128 is subtype Int128 is Interfaces.Integer_128; - subtype Uns128 is Interfaces.Unsigned_128; - package Impl is new Image_D (Int128, Uns128); + package Impl is new Image_D (Int128); procedure Image_Decimal128 (V : Int128; diff --git a/gcc/ada/libgnat/s-imde32.ads b/gcc/ada/libgnat/s-imde32.ads index 442f343..40fd5e9 100644 --- a/gcc/ada/libgnat/s-imde32.ads +++ b/gcc/ada/libgnat/s-imde32.ads @@ -39,9 +39,8 @@ with System.Image_D; package System.Img_Decimal_32 is subtype Int32 is Interfaces.Integer_32; - subtype Uns32 is Interfaces.Unsigned_32; - package Impl is new Image_D (Int32, Uns32); + package Impl is new Image_D (Int32); procedure Image_Decimal32 (V : Int32; diff --git a/gcc/ada/libgnat/s-imde64.ads b/gcc/ada/libgnat/s-imde64.ads index a69e02f..5264c43 100644 --- a/gcc/ada/libgnat/s-imde64.ads +++ b/gcc/ada/libgnat/s-imde64.ads @@ -39,9 +39,8 @@ with System.Image_D; package System.Img_Decimal_64 is subtype Int64 is Interfaces.Integer_64; - subtype Uns64 is Interfaces.Unsigned_64; - package Impl is new Image_D (Int64, Uns64); + package Impl is new Image_D (Int64); procedure Image_Decimal64 (V : Int64; diff --git a/gcc/ada/libgnat/s-imfi128.ads b/gcc/ada/libgnat/s-imfi128.ads index 9bb383a..23cd059 100644 --- a/gcc/ada/libgnat/s-imfi128.ads +++ b/gcc/ada/libgnat/s-imfi128.ads @@ -39,9 +39,8 @@ with System.Image_F; package System.Img_Fixed_128 is subtype Int128 is Interfaces.Integer_128; - subtype Uns128 is Interfaces.Unsigned_128; - package Impl is new Image_F (Int128, Uns128, Arith_128.Scaled_Divide128); + package Impl is new Image_F (Int128, Arith_128.Scaled_Divide128); procedure Image_Fixed128 (V : Int128; diff --git a/gcc/ada/libgnat/s-imfi32.ads b/gcc/ada/libgnat/s-imfi32.ads index f66b0fa..ba46e8d 100644 --- a/gcc/ada/libgnat/s-imfi32.ads +++ b/gcc/ada/libgnat/s-imfi32.ads @@ -39,9 +39,8 @@ with System.Image_F; package System.Img_Fixed_32 is subtype Int32 is Interfaces.Integer_32; - subtype Uns32 is Interfaces.Unsigned_32; - package Impl is new Image_F (Int32, Uns32, Arith_32.Scaled_Divide32); + package Impl is new Image_F (Int32, Arith_32.Scaled_Divide32); procedure Image_Fixed32 (V : Int32; diff --git a/gcc/ada/libgnat/s-imfi64.ads b/gcc/ada/libgnat/s-imfi64.ads index ecb70ad..c7f7aa1 100644 --- a/gcc/ada/libgnat/s-imfi64.ads +++ b/gcc/ada/libgnat/s-imfi64.ads @@ -39,9 +39,8 @@ with System.Image_F; package System.Img_Fixed_64 is subtype Int64 is Interfaces.Integer_64; - subtype Uns64 is Interfaces.Unsigned_64; - package Impl is new Image_F (Int64, Uns64, Arith_64.Scaled_Divide64); + package Impl is new Image_F (Int64, Arith_64.Scaled_Divide64); procedure Image_Fixed64 (V : Int64; diff --git a/gcc/ada/libgnat/s-imgboo.adb b/gcc/ada/libgnat/s-imgboo.adb index 436818c..c4d85bf 100644 --- a/gcc/ada/libgnat/s-imgboo.adb +++ b/gcc/ada/libgnat/s-imgboo.adb @@ -29,32 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body System.Img_Bool with SPARK_Mode is - - -- Local lemmas - - procedure Lemma_Is_First_Non_Space_Ghost (S : String; R : Positive) with - Ghost, - Pre => R in S'Range and then S (R) /= ' ' - and then System.Val_Spec.Only_Space_Ghost (S, S'First, R - 1), - Post => System.Val_Spec.First_Non_Space_Ghost (S, S'First, S'Last) = R; - - ------------------------------------ - -- Lemma_Is_First_Non_Space_Ghost -- - ------------------------------------ - - procedure Lemma_Is_First_Non_Space_Ghost (S : String; R : Positive) is null; - ------------------- -- Image_Boolean -- ------------------- @@ -69,11 +46,9 @@ is if V then S (1 .. 4) := "TRUE"; P := 4; - Lemma_Is_First_Non_Space_Ghost (S, 1); else S (1 .. 5) := "FALSE"; P := 5; - Lemma_Is_First_Non_Space_Ghost (S, 1); end if; end Image_Boolean; diff --git a/gcc/ada/libgnat/s-imgboo.ads b/gcc/ada/libgnat/s-imgboo.ads index 9d8b1f7..af19c2e 100644 --- a/gcc/ada/libgnat/s-imgboo.ads +++ b/gcc/ada/libgnat/s-imgboo.ads @@ -34,32 +34,13 @@ -- This package provides support for ``Image`` attribute on ``Boolean``. The -- compiler performs direct calls to this unit to implement the attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with System.Val_Spec; - package System.Img_Bool with SPARK_Mode, Preelaborate is - procedure Image_Boolean (V : Boolean; S : in out String; - P : out Natural) - with - Pre => S'First = 1 - and then (if V then S'Length >= 4 else S'Length >= 5), - Post => (if V then P = 4 else P = 5) - and then System.Val_Spec.Is_Boolean_Image_Ghost (S (1 .. P), V); + P : out Natural); -- Computes Boolean'Image (``V``) and stores the result in -- ``S`` (1 .. ``P``) setting the resulting value of ``P``. The caller -- guarantees that ``S`` is long enough to hold the result, and that diff --git a/gcc/ada/libgnat/s-imgint.ads b/gcc/ada/libgnat/s-imgint.ads index 1ccf173..55df149 100644 --- a/gcc/ada/libgnat/s-imgint.ads +++ b/gcc/ada/libgnat/s-imgint.ads @@ -33,33 +33,12 @@ -- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer -- types up to Size ``Integer'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_I; -with System.Unsigned_Types; -with System.Vs_Int; -with System.Vs_Uns; package System.Img_Int with SPARK_Mode is - subtype Unsigned is Unsigned_Types.Unsigned; - - package Impl is new Image_I - (Int => Integer, - Uns => Unsigned, - U_Spec => System.Vs_Uns.Spec, - I_Spec => System.Vs_Int.Spec); + package Impl is new Image_I (Integer); procedure Image_Integer (V : Integer; diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads index 32be4dc..28fd563 100644 --- a/gcc/ada/libgnat/s-imglli.ads +++ b/gcc/ada/libgnat/s-imglli.ads @@ -33,33 +33,12 @@ -- and ``Ada.Text_IO.Integer_IO`` conversions routines for signed integer -- types larger than Size ``Integer'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_I; -with System.Unsigned_Types; -with System.Vs_LLI; -with System.Vs_LLU; package System.Img_LLI with SPARK_Mode is - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - - package Impl is new Image_I - (Int => Long_Long_Integer, - Uns => Long_Long_Unsigned, - U_Spec => System.Vs_LLU.Spec, - I_Spec => System.Vs_LLI.Spec); + package Impl is new Image_I (Long_Long_Integer); procedure Image_Long_Long_Integer (V : Long_Long_Integer; diff --git a/gcc/ada/libgnat/s-imgllli.ads b/gcc/ada/libgnat/s-imgllli.ads index 47c75b0..cecbdff 100644 --- a/gcc/ada/libgnat/s-imgllli.ads +++ b/gcc/ada/libgnat/s-imgllli.ads @@ -33,33 +33,12 @@ -- signed integer types larger than Long_Long_Integer, and also for conversion -- operations required in Text_IO.Integer_IO for such types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_I; -with System.Unsigned_Types; -with System.Vs_LLLI; -with System.Vs_LLLU; package System.Img_LLLI with SPARK_Mode is - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - - package Impl is new Image_I - (Int => Long_Long_Long_Integer, - Uns => Long_Long_Long_Unsigned, - U_Spec => System.Vs_LLLU.Spec, - I_Spec => System.Vs_LLLI.Spec); + package Impl is new Image_I (Long_Long_Long_Integer); procedure Image_Long_Long_Long_Integer (V : Long_Long_Long_Integer; diff --git a/gcc/ada/libgnat/s-imglllu.ads b/gcc/ada/libgnat/s-imglllu.ads index 0dbe1f21c..e581d37 100644 --- a/gcc/ada/libgnat/s-imglllu.ads +++ b/gcc/ada/libgnat/s-imglllu.ads @@ -33,30 +33,15 @@ -- modular integer types larger than Long_Long_Unsigned, and also for -- conversion operations required in Text_IO.Modular_IO for such types. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_U; with System.Unsigned_Types; -with System.Vs_LLLU; package System.Img_LLLU with SPARK_Mode is subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - package Impl is new Image_U - (Uns => Long_Long_Long_Unsigned, - U_Spec => System.Vs_LLLU.Spec); + package Impl is new Image_U (Uns => Long_Long_Long_Unsigned); procedure Image_Long_Long_Long_Unsigned (V : Long_Long_Long_Unsigned; diff --git a/gcc/ada/libgnat/s-imgllu.ads b/gcc/ada/libgnat/s-imgllu.ads index 82d372d..729e6e8 100644 --- a/gcc/ada/libgnat/s-imgllu.ads +++ b/gcc/ada/libgnat/s-imgllu.ads @@ -33,30 +33,15 @@ -- and ``Ada.Text_IO.Modular_IO`` conversions routines for unsigned (modular) -- integer types larger than Size ``Unsigned'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_U; with System.Unsigned_Types; -with System.Vs_LLU; package System.Img_LLU with SPARK_Mode is subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - package Impl is new Image_U - (Uns => Long_Long_Unsigned, - U_Spec => System.Vs_LLU.Spec); + package Impl is new Image_U (Uns => Long_Long_Unsigned); procedure Image_Long_Long_Unsigned (V : Long_Long_Unsigned; diff --git a/gcc/ada/libgnat/s-imguns.ads b/gcc/ada/libgnat/s-imguns.ads index 142591a..dbab67e 100644 --- a/gcc/ada/libgnat/s-imguns.ads +++ b/gcc/ada/libgnat/s-imguns.ads @@ -33,30 +33,15 @@ -- and ``Ada.Text_IO.Modular_IO`` conversions routines for modular integer -- types up to size ``Unsigned'Size``. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Image_U; with System.Unsigned_Types; -with System.Vs_Uns; package System.Img_Uns with SPARK_Mode is subtype Unsigned is Unsigned_Types.Unsigned; - package Impl is new Image_U - (Uns => Unsigned, - U_Spec => System.Vs_Uns.Spec); + package Impl is new Image_U (Uns => Unsigned); procedure Image_Unsigned (V : Unsigned; diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb index 2749658..9d78b86 100644 --- a/gcc/ada/libgnat/s-secsta.adb +++ b/gcc/ada/libgnat/s-secsta.adb @@ -633,6 +633,15 @@ package body System.Secondary_Stack is if Over_Aligning then Padding := Alignment; + + -- Typically the padding would be + -- Alignment - (Addr mod Alignment) + -- however Addr in this case is not known yet. It depends on the + -- type of the secondary stack (Dynamic/Static). The allocation + -- routine for the respective type of stack requires to know the + -- allocation size before the address is known. To ensure a + -- sufficient allocation size to fit the padding, the padding is + -- calculated conservatively. end if; -- Round the requested size (plus the needed padding in case of diff --git a/gcc/ada/libgnat/s-secsta__cheri.adb b/gcc/ada/libgnat/s-secsta__cheri.adb index a24b50e..9a65ed28 100644 --- a/gcc/ada/libgnat/s-secsta__cheri.adb +++ b/gcc/ada/libgnat/s-secsta__cheri.adb @@ -662,6 +662,15 @@ package body System.Secondary_Stack is if Over_Aligning then Over_Align_Padding := Alignment; + + -- Typically the padding would be + -- Alignment - (Addr mod Alignment) + -- however Addr in this case is not known yet. It depends on the + -- type of the secondary stack (Dynamic/Static). The allocation + -- routine for the respective type of stack requires to know the + -- allocation size before the address is known. To ensure a + -- sufficient allocation size to fit the padding, the padding is + -- calculated conservatively. end if; -- It should not be possible to request an allocation of negative diff --git a/gcc/ada/libgnat/s-spark.ads b/gcc/ada/libgnat/s-spark.ads deleted file mode 100644 index c46409f..0000000 --- a/gcc/ada/libgnat/s-spark.ads +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S P A R K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the top level unit of the SPARK package. Its children --- contain helper functions to aid proofs. - -package System.SPARK with - SPARK_Mode, - Pure -is -end System.SPARK; diff --git a/gcc/ada/libgnat/s-spcuop.adb b/gcc/ada/libgnat/s-spcuop.adb deleted file mode 100644 index 74422ea..0000000 --- a/gcc/ada/libgnat/s-spcuop.adb +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S P A R K . C U T _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2022-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.SPARK.Cut_Operations with - SPARK_Mode => Off -is - - function By (Consequence, Premise : Boolean) return Boolean is - (Premise and then Consequence); - - function So (Premise, Consequence : Boolean) return Boolean is - (Premise and then Consequence); - -end System.SPARK.Cut_Operations; diff --git a/gcc/ada/libgnat/s-spcuop.ads b/gcc/ada/libgnat/s-spcuop.ads deleted file mode 100644 index 04a94a5..0000000 --- a/gcc/ada/libgnat/s-spcuop.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S P A R K . C U T _ O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides connectors used to manually help the proof of --- assertions by introducing intermediate steps. They can only be used inside --- pragmas Assert or Assert_And_Cut. - -package System.SPARK.Cut_Operations with - SPARK_Mode, - Pure, - Always_Terminates -is - - function By (Consequence, Premise : Boolean) return Boolean with - Ghost, - Global => null; - -- If A and B are two boolean expressions, proving By (A, B) requires - -- proving B, the premise, and then A assuming B, the side-condition. When - -- By (A, B) is assumed on the other hand, we only assume A. B is used - -- for the proof, but is not visible afterward. - - function So (Premise, Consequence : Boolean) return Boolean with - Ghost, - Global => null; - -- If A and B are two boolean expressions, proving So (A, B) requires - -- proving A, the premise, and then B assuming A, the side-condition. When - -- So (A, B) is assumed both A and B are assumed to be true. - -end System.SPARK.Cut_Operations; diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb index 45af884..1b4b807 100644 --- a/gcc/ada/libgnat/s-trasym__dwarf.adb +++ b/gcc/ada/libgnat/s-trasym__dwarf.adb @@ -41,6 +41,7 @@ with System.Soft_Links; with System.CRTL; with System.Dwarf_Lines; with System.Exception_Traces; +with System.OS_Lib; with System.Standard_Library; with System.Traceback_Entries; with System.Strings; @@ -413,6 +414,23 @@ package body System.Traceback.Symbolic is return; end if; + -- On some platforms, we use dladdr and the dli_fname field to get the + -- pathname, but that pathname might be relative and not point to the + -- right thing in our context. That happens when the executable is + -- dynamically linked and was started through execvp; dli_fname only + -- contains the executable name passed to execvp in that case. + -- + -- Because of this, we might be about to open a file that's in fact not + -- a shared object but something completely unrelated. It's hard to + -- detect this in general, but we perform a sanity check that + -- Module_Name does not designate a directory; if it does, it's + -- definitely not a shared object. + + if System.OS_Lib.Is_Directory (Module_Name) then + Success := False; + return; + end if; + Open (Module_Name, Module.C, Success); -- If a module can't be opened just return now, we just cannot give more diff --git a/gcc/ada/libgnat/s-vafi128.ads b/gcc/ada/libgnat/s-vafi128.ads index 7518c6c..d75857a 100644 --- a/gcc/ada/libgnat/s-vafi128.ads +++ b/gcc/ada/libgnat/s-vafi128.ads @@ -29,9 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This package contains routines for scanning values for ordinary fixed point --- types up to 128-bit small and mantissa, for use in Text_IO.Decimal_IO, and --- the Value attribute for such decimal types. +-- This package contains the routines for supporting the Value attribute for +-- ordinary fixed point types up to 128-bit small and mantissa, and also for +-- conversion operations required in Text_IO.Fixed_IO for such types. with Interfaces; with System.Arith_128; diff --git a/gcc/ada/libgnat/s-vafi32.ads b/gcc/ada/libgnat/s-vafi32.ads index e3ad5c2..7ed22c6 100644 --- a/gcc/ada/libgnat/s-vafi32.ads +++ b/gcc/ada/libgnat/s-vafi32.ads @@ -29,9 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This package contains routines for scanning values for decimal fixed point --- types up to 32-bit small and mantissa, for use in Text_IO.Decimal_IO, and --- the Value attribute for such decimal types. +-- This package contains the routines for supporting the Value attribute for +-- ordinary fixed point types up to 32-bit small and mantissa, and also for +-- conversion operations required in Text_IO.Fixed_IO for such types. with Interfaces; with System.Arith_32; diff --git a/gcc/ada/libgnat/s-vafi64.ads b/gcc/ada/libgnat/s-vafi64.ads index 4d86939..43197bb 100644 --- a/gcc/ada/libgnat/s-vafi64.ads +++ b/gcc/ada/libgnat/s-vafi64.ads @@ -29,9 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This package contains routines for scanning values for decimal fixed point --- types up to 64-bit small and mantissa, for use in Text_IO.Decimal_IO, and --- the Value attribute for such decimal types. +-- This package contains the routines for supporting the Value attribute for +-- ordinary fixed point types up to 64-bit small and mantissa, and also for +-- conversion operations required in Text_IO.Fixed_IO for such types. with Interfaces; with System.Arith_64; diff --git a/gcc/ada/libgnat/s-vaispe.adb b/gcc/ada/libgnat/s-vaispe.adb deleted file mode 100644 index 0b09f75..0000000 --- a/gcc/ada/libgnat/s-vaispe.adb +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ I _ S P E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2022-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -package body System.Value_I_Spec is - - ----------------------------------- - -- Prove_Scan_Only_Decimal_Ghost -- - ----------------------------------- - - procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) is - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - pragma Assert (Str (Str'First + 1) /= ' '); - pragma Assert - (if Val < 0 then Non_Blank = Str'First - else - Str (Str'First) = ' ' - and then Non_Blank = Str'First + 1); - Minus : constant Boolean := Str (Non_Blank) = '-'; - Fst_Num : constant Positive := - (if Minus then Non_Blank + 1 else Non_Blank); - pragma Assert (Fst_Num = Str'First + 1); - Uval : constant Uns := Abs_Uns_Of_Int (Val); - - procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns) - with - Pre => Minus = (Val < 0) - and then Uval = Abs_Uns_Of_Int (Val), - Post => Uns_Is_Valid_Int (Minus, Uval) - and then Is_Int_Of_Uns (Minus, Uval, Val); - -- Local proof of the unicity of the signed representation - - procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns) is null; - - -- Start of processing for Prove_Scan_Only_Decimal_Ghost - - begin - Prove_Conversion_Is_Identity (Val, Uval); - pragma Assert - (U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); - pragma Assert - (U_Spec.Scan_Split_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); - U_Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, 10); - pragma Assert - (U_Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); - pragma Assert (Only_Space_Ghost - (Str, U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Str'Last), Str'Last)); - pragma Assert (Is_Integer_Ghost (Str)); - pragma Assert (Is_Value_Integer_Ghost (Str, Val)); - end Prove_Scan_Only_Decimal_Ghost; - -end System.Value_I_Spec; diff --git a/gcc/ada/libgnat/s-vaispe.ads b/gcc/ada/libgnat/s-vaispe.ads deleted file mode 100644 index 2e729aa..0000000 --- a/gcc/ada/libgnat/s-vaispe.ads +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ I _ S P E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of a set of Ghost code packages used to proof the --- implementations of the Image and Value attributes. It provides the --- specification entities using for the formal verification of the routines --- for scanning signed integer values. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_U_Spec; -with System.Val_Spec; use System.Val_Spec; - -generic - - type Int is range <>; - - type Uns is mod <>; - - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - -package System.Value_I_Spec with - Ghost, - SPARK_Mode, - Always_Terminates -is - pragma Preelaborate; - use all type U_Spec.Uns_Option; - - function Uns_Is_Valid_Int (Minus : Boolean; Uval : Uns) return Boolean is - (if Minus then Uval <= Uns (Int'Last) + 1 - else Uval <= Uns (Int'Last)) - with Post => True; - -- Return True if Uval (or -Uval when Minus is True) is a valid number of - -- type Int. - - function Is_Int_Of_Uns - (Minus : Boolean; - Uval : Uns; - Val : Int) - return Boolean - is - (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First - elsif Minus then Val = -(Int (Uval)) - else Val = Int (Uval)) - with - Pre => Uns_Is_Valid_Int (Minus, Uval), - Post => True; - -- Return True if Uval (or -Uval when Minus is True) is equal to Val - - function Abs_Uns_Of_Int (Val : Int) return Uns is - (if Val = Int'First then Uns (Int'Last) + 1 - elsif Val < 0 then Uns (-Val) - else Uns (Val)); - -- Return the unsigned absolute value of Val - - function Slide_To_1 (Str : String) return String - with - Post => - Only_Space_Ghost (Str, Str'First, Str'Last) = - (for all J in Str'First .. Str'Last => - Slide_To_1'Result (J - Str'First + 1) = ' '); - -- Slides Str so that it starts at 1 - - function Slide_If_Necessary (Str : String) return String is - (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str); - -- If Str'Last = Positive'Last then slides Str so that it starts at 1 - - function Is_Integer_Ghost (Str : String) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); - begin - U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) - and then U_Spec.Raw_Unsigned_No_Overflow_Ghost - (Str, Fst_Num, Str'Last) - and then - Uns_Is_Valid_Int - (Minus => Str (Non_Blank) = '-', - Uval => U_Spec.Scan_Raw_Unsigned_Ghost - (Str, Fst_Num, Str'Last)) - and then Only_Space_Ghost - (Str, U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Str'Last), Str'Last)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last, - Post => True; - -- Ghost function that determines if Str has the correct format for a - -- signed number, consisting in some blank characters, an optional - -- sign, a raw unsigned number which does not overflow and then some - -- more blank characters. - - function Is_Value_Integer_Ghost (Str : String; Val : Int) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); - Uval : constant Uns := - U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last); - begin - Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', - Uval => Uval, - Val => Val)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last - and then Is_Integer_Ghost (Str), - Post => True; - -- Ghost function that returns True if Val is the value corresponding to - -- the signed number represented by Str. - - procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) - with - Ghost, - Pre => Str'Last /= Positive'Last - and then Str'Length >= 2 - and then Str (Str'First) in ' ' | '-' - and then (Str (Str'First) = '-') = (Val < 0) - and then U_Spec.Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) - and then U_Spec.Scan_Based_Number_Ghost - (Str, Str'First + 1, Str'Last) - = U_Spec.Wrap_Option (Abs_Uns_Of_Int (Val)), - Post => Is_Integer_Ghost (Slide_If_Necessary (Str)) - and then Is_Value_Integer_Ghost (Str, Val); - -- Ghost lemma used in the proof of 'Image implementation, to prove that - -- the result of Value_Integer on a decimal string is the same as the - -- signing the result of Scan_Based_Number_Ghost. - -private - - ---------------- - -- Slide_To_1 -- - ---------------- - - function Slide_To_1 (Str : String) return String is - (declare - Res : constant String (1 .. Str'Length) := Str; - begin - Res); - -end System.Value_I_Spec; diff --git a/gcc/ada/libgnat/s-valboo.adb b/gcc/ada/libgnat/s-valboo.adb index 8db3316..93d6fb2 100644 --- a/gcc/ada/libgnat/s-valboo.adb +++ b/gcc/ada/libgnat/s-valboo.adb @@ -29,14 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - with System.Val_Util; use System.Val_Util; package body System.Val_Bool @@ -55,9 +47,6 @@ is begin Normalize_String (S, F, L, To_Upper_Case => True); - pragma Assert (F = System.Val_Spec.First_Non_Space_Ghost - (S, Str'First, Str'Last)); - if S (F .. L) = "TRUE" then return True; diff --git a/gcc/ada/libgnat/s-valboo.ads b/gcc/ada/libgnat/s-valboo.ads index fdd8a3f..b2fd558 100644 --- a/gcc/ada/libgnat/s-valboo.ads +++ b/gcc/ada/libgnat/s-valboo.ads @@ -29,32 +29,12 @@ -- -- ------------------------------------------------------------------------------ --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with System.Val_Spec; - package System.Val_Bool with SPARK_Mode is pragma Preelaborate; - function Value_Boolean (Str : String) return Boolean - with - Pre => System.Val_Spec.Is_Boolean_Image_Ghost (Str, True) - or else System.Val_Spec.Is_Boolean_Image_Ghost (Str, False), - Post => - Value_Boolean'Result = - (Str (System.Val_Spec.First_Non_Space_Ghost - (Str, Str'First, Str'Last)) in 't' | 'T'); + function Value_Boolean (Str : String) return Boolean; -- Computes Boolean'Value (Str) end System.Val_Bool; diff --git a/gcc/ada/libgnat/s-valint.ads b/gcc/ada/libgnat/s-valint.ads index 6045cd6..164bbfe 100644 --- a/gcc/ada/libgnat/s-valint.ads +++ b/gcc/ada/libgnat/s-valint.ads @@ -32,23 +32,9 @@ -- This package contains routines for scanning signed Integer values for use -- in Text_IO.Integer_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Val_Uns; with System.Value_I; -with System.Vs_Int; -with System.Vs_Uns; package System.Val_Int with SPARK_Mode is pragma Preelaborate; @@ -58,9 +44,7 @@ package System.Val_Int with SPARK_Mode is package Impl is new Value_I (Int => Integer, Uns => Unsigned, - Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned, - U_Spec => System.Vs_Uns.Spec, - Spec => System.Vs_Int.Spec); + Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned); procedure Scan_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-vallli.ads b/gcc/ada/libgnat/s-vallli.ads index 7672cc5..a3b48e3 100644 --- a/gcc/ada/libgnat/s-vallli.ads +++ b/gcc/ada/libgnat/s-vallli.ads @@ -32,23 +32,9 @@ -- This package contains routines for scanning signed Long_Long_Integer -- values for use in Text_IO.Integer_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Val_LLU; with System.Value_I; -with System.Vs_LLI; -with System.Vs_LLU; package System.Val_LLI with SPARK_Mode is pragma Preelaborate; @@ -58,9 +44,7 @@ package System.Val_LLI with SPARK_Mode is package Impl is new Value_I (Int => Long_Long_Integer, Uns => Long_Long_Unsigned, - Scan_Raw_Unsigned => Val_LLU.Scan_Raw_Long_Long_Unsigned, - U_Spec => System.Vs_LLU.Spec, - Spec => System.Vs_LLI.Spec); + Scan_Raw_Unsigned => Val_LLU.Scan_Raw_Long_Long_Unsigned); procedure Scan_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-valllli.ads b/gcc/ada/libgnat/s-valllli.ads index e2cae26..719d4f4 100644 --- a/gcc/ada/libgnat/s-valllli.ads +++ b/gcc/ada/libgnat/s-valllli.ads @@ -32,23 +32,9 @@ -- This package contains routines for scanning signed Long_Long_Long_Integer -- values for use in Text_IO.Integer_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Val_LLLU; with System.Value_I; -with System.Vs_LLLI; -with System.Vs_LLLU; package System.Val_LLLI with SPARK_Mode is pragma Preelaborate; @@ -58,9 +44,7 @@ package System.Val_LLLI with SPARK_Mode is package Impl is new Value_I (Int => Long_Long_Long_Integer, Uns => Long_Long_Long_Unsigned, - Scan_Raw_Unsigned => Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned, - U_Spec => System.Vs_LLLU.Spec, - Spec => System.Vs_LLLI.Spec); + Scan_Raw_Unsigned => Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned); procedure Scan_Long_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-vallllu.ads b/gcc/ada/libgnat/s-vallllu.ads index 8e57e51..50a061b 100644 --- a/gcc/ada/libgnat/s-vallllu.ads +++ b/gcc/ada/libgnat/s-vallllu.ads @@ -32,28 +32,15 @@ -- This package contains routines for scanning modular Long_Long_Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Value_U; -with System.Vs_LLLU; package System.Val_LLLU with SPARK_Mode is pragma Preelaborate; subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - package Impl is new Value_U (Long_Long_Long_Unsigned, System.Vs_LLLU.Spec); + package Impl is new Value_U (Long_Long_Long_Unsigned); procedure Scan_Raw_Long_Long_Long_Unsigned (Str : String; diff --git a/gcc/ada/libgnat/s-valllu.ads b/gcc/ada/libgnat/s-valllu.ads index a7e37fc..eeb9a25 100644 --- a/gcc/ada/libgnat/s-valllu.ads +++ b/gcc/ada/libgnat/s-valllu.ads @@ -32,28 +32,15 @@ -- This package contains routines for scanning modular Long_Long_Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Value_U; -with System.Vs_LLU; package System.Val_LLU with SPARK_Mode is pragma Preelaborate; subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - package Impl is new Value_U (Long_Long_Unsigned, System.Vs_LLU.Spec); + package Impl is new Value_U (Long_Long_Unsigned); procedure Scan_Raw_Long_Long_Unsigned (Str : String; diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb index aff694d..aaa82d4 100644 --- a/gcc/ada/libgnat/s-valrea.adb +++ b/gcc/ada/libgnat/s-valrea.adb @@ -49,7 +49,8 @@ package body System.Val_Real is Precision_Limit : constant Uns := 2**Num'Machine_Mantissa - 1; -- See below for the rationale - package Impl is new Value_R (Uns, 2, Precision_Limit, Round => False); + package Impl is new Value_R (Uns, 2, Precision_Limit); + -- We do not use the Extra digits for floating-point types subtype Base_T is Unsigned range 2 .. 16; @@ -90,7 +91,7 @@ package body System.Val_Real is when others => raise Program_Error); -- Return the exponent of a power of 2 - function Integer_to_Real + function Integer_To_Real (Str : String; Val : Impl.Value_Array; Base : Unsigned; @@ -105,10 +106,10 @@ package body System.Val_Real is -- Return Num'Scaling (5.0**Exp, -S) as a double number where Exp > Maxexp --------------------- - -- Integer_to_Real -- + -- Integer_To_Real -- --------------------- - function Integer_to_Real + function Integer_To_Real (Str : String; Val : Impl.Value_Array; Base : Unsigned; @@ -213,7 +214,7 @@ package body System.Val_Real is -- Compute the final value by applying the scaling, if any - if (Val (1) = 0 and then Val (2) = 0) or else S = 0 then + if Val (1) = 0 or else S = 0 then R_Val := Double_Real.To_Single (D_Val); else @@ -313,7 +314,7 @@ package body System.Val_Real is exception when Constraint_Error => Bad_Value (Str); - end Integer_to_Real; + end Integer_To_Real; ------------------- -- Large_Powfive -- @@ -456,7 +457,7 @@ package body System.Val_Real is begin Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scale, Extra, Minus); - return Integer_to_Real (Str, Val, Base, Scale, Minus); + return Integer_To_Real (Str, Val, Base, Scale, Minus); end Scan_Real; ---------------- @@ -473,7 +474,7 @@ package body System.Val_Real is begin Val := Impl.Value_Raw_Real (Str, Base, Scale, Extra, Minus); - return Integer_to_Real (Str, Val, Base, Scale, Minus); + return Integer_To_Real (Str, Val, Base, Scale, Minus); end Value_Real; end System.Val_Real; diff --git a/gcc/ada/libgnat/s-valspe.ads b/gcc/ada/libgnat/s-valspe.ads deleted file mode 100644 index fbd3ba5..0000000 --- a/gcc/ada/libgnat/s-valspe.ads +++ /dev/null @@ -1,246 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ S P E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of a set of Ghost code packages used to proof the --- implementations of the Image and Value attributes. It provides some common --- specification functions used by the s-valxxx files. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -package System.Val_Spec with - SPARK_Mode, - Pure, - Ghost -is - function Only_Space_Ghost (S : String; From, To : Integer) return Boolean is - (for all J in From .. To => S (J) = ' ') - with - Pre => From > To or else (From >= S'First and then To <= S'Last), - Post => True; - -- Ghost function that returns True if S has only space characters from - -- index From to index To. - - function First_Non_Space_Ghost - (S : String; - From, To : Integer) return Positive - with - Pre => From in S'Range - and then To in S'Range - and then not Only_Space_Ghost (S, From, To), - Post => First_Non_Space_Ghost'Result in From .. To - and then S (First_Non_Space_Ghost'Result) /= ' ' - and then Only_Space_Ghost - (S, From, First_Non_Space_Ghost'Result - 1); - -- Ghost function that returns the index of the first non-space character - -- in S, which necessarily exists given the precondition on S. - - function Is_Boolean_Image_Ghost - (Str : String; - Val : Boolean) return Boolean - is - (not Only_Space_Ghost (Str, Str'First, Str'Last) - and then - (declare - F : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - begin - (Val - and then F <= Str'Last - 3 - and then Str (F) in 't' | 'T' - and then Str (F + 1) in 'r' | 'R' - and then Str (F + 2) in 'u' | 'U' - and then Str (F + 3) in 'e' | 'E' - and then - (if F + 3 < Str'Last then - Only_Space_Ghost (Str, F + 4, Str'Last))) - or else - (not Val - and then F <= Str'Last - 4 - and then Str (F) in 'f' | 'F' - and then Str (F + 1) in 'a' | 'A' - and then Str (F + 2) in 'l' | 'L' - and then Str (F + 3) in 's' | 'S' - and then Str (F + 4) in 'e' | 'E' - and then - (if F + 4 < Str'Last then - Only_Space_Ghost (Str, F + 5, Str'Last))))) - with - Ghost; - -- Ghost function that returns True iff Str is the image of boolean Val, - -- that is "true" or "false" in any capitalization, possibly surounded by - -- space characters. - - function Only_Number_Ghost (Str : String; From, To : Integer) return Boolean - is - (for all J in From .. To => Str (J) in '0' .. '9' | '_') - with - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only number characters from - -- index From to index To. - - function Last_Number_Ghost (Str : String) return Positive - with - Pre => Str /= "" and then Str (Str'First) in '0' .. '9', - Post => Last_Number_Ghost'Result in Str'Range - and then (if Last_Number_Ghost'Result < Str'Last then - Str (Last_Number_Ghost'Result + 1) not in '0' .. '9' | '_') - and then Only_Number_Ghost (Str, Str'First, Last_Number_Ghost'Result); - -- Ghost function that returns the index of the last character in S that - -- is either a figure or underscore, which necessarily exists given the - -- precondition on Str. - - function Is_Natural_Format_Ghost (Str : String) return Boolean is - (Str /= "" - and then Str (Str'First) in '0' .. '9' - and then - (declare - L : constant Positive := Last_Number_Ghost (Str); - begin - Str (L) in '0' .. '9' - and then (for all J in Str'First .. L => - (if Str (J) = '_' then Str (J + 1) /= '_')))); - -- Ghost function that determines if Str has the correct format for a - -- natural number, consisting in a sequence of figures possibly separated - -- by single underscores. It may be followed by other characters. - - function Starts_As_Exponent_Format_Ghost - (Str : String; - Real : Boolean := False) return Boolean - is - (Str'Length > 1 - and then Str (Str'First) in 'E' | 'e' - and then - (declare - Plus_Sign : constant Boolean := Str (Str'First + 1) = '+'; - Minus_Sign : constant Boolean := Str (Str'First + 1) = '-'; - Sign : constant Boolean := Plus_Sign or Minus_Sign; - begin - (if Minus_Sign then Real) - and then (if Sign then Str'Length > 2) - and then - (declare - Start : constant Natural := - (if Sign then Str'First + 2 else Str'First + 1); - begin - Str (Start) in '0' .. '9'))); - -- Ghost function that determines if Str is recognized as something which - -- might be an exponent, ie. it starts with an 'e', capitalized or not, - -- followed by an optional sign which can only be '-' if we are working on - -- real numbers (Real is True), and then a digit in decimal notation. - - function Is_Opt_Exponent_Format_Ghost - (Str : String; - Real : Boolean := False) return Boolean - is - (not Starts_As_Exponent_Format_Ghost (Str, Real) - or else - (declare - Start : constant Natural := - (if Str (Str'First + 1) in '+' | '-' then Str'First + 2 - else Str'First + 1); - begin Is_Natural_Format_Ghost (Str (Start .. Str'Last)))); - -- Ghost function that determines if Str has the correct format for an - -- optional exponent, that is, either it does not start as an exponent, or - -- it is in a correct format for a natural number. - - function Scan_Natural_Ghost - (Str : String; - P : Natural; - Acc : Natural) - return Natural - with - Subprogram_Variant => (Increases => P), - Pre => Str /= "" and then Str (Str'First) in '0' .. '9' - and then Str'Last < Natural'Last - and then P in Str'First .. Last_Number_Ghost (Str) + 1; - -- Ghost function that recursively computes the natural number in Str, up - -- to the first number greater or equal to Natural'Last / 10, assuming Acc - -- has been scanned already and scanning continues at index P. - - function Scan_Exponent_Ghost - (Str : String; - Real : Boolean := False) - return Integer - is - (declare - Plus_Sign : constant Boolean := Str (Str'First + 1) = '+'; - Minus_Sign : constant Boolean := Str (Str'First + 1) = '-'; - Sign : constant Boolean := Plus_Sign or Minus_Sign; - Start : constant Natural := - (if Sign then Str'First + 2 else Str'First + 1); - Value : constant Natural := - Scan_Natural_Ghost (Str (Start .. Str'Last), Start, 0); - begin - (if Minus_Sign then -Value else Value)) - with - Pre => Str'Last < Natural'Last - and then Starts_As_Exponent_Format_Ghost (Str, Real), - Post => (if not Real then Scan_Exponent_Ghost'Result >= 0); - -- Ghost function that scans an exponent - -private - - ------------------------ - -- Scan_Natural_Ghost -- - ------------------------ - - function Scan_Natural_Ghost - (Str : String; - P : Natural; - Acc : Natural) - return Natural - is - (if P > Str'Last - or else Str (P) not in '0' .. '9' | '_' - or else Acc >= Integer'Last / 10 - then - Acc - elsif Str (P) = '_' then - Scan_Natural_Ghost (Str, P + 1, Acc) - else - (declare - Shift_Acc : constant Natural := - Acc * 10 + - (Integer'(Character'Pos (Str (P))) - - Integer'(Character'Pos ('0'))); - begin - Scan_Natural_Ghost (Str, P + 1, Shift_Acc))); - -end System.Val_Spec; diff --git a/gcc/ada/libgnat/s-valued.adb b/gcc/ada/libgnat/s-valued.adb index dfef9a88..4f2e102 100644 --- a/gcc/ada/libgnat/s-valued.adb +++ b/gcc/ada/libgnat/s-valued.adb @@ -38,14 +38,16 @@ package body System.Value_D is pragma Assert (Int'Size <= Uns'Size); -- We need an unsigned type large enough to represent the mantissa - package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => False); - -- We do not use the Extra digit for decimal fixed-point types + package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1)); + -- We do not use the Extra digits for decimal fixed-point types, except to + -- effectively ensure that overflow is detected near the boundaries. function Integer_to_Decimal (Str : String; Val : Uns; Base : Unsigned; ScaleB : Integer; + Extra2 : Unsigned; Minus : Boolean; Scale : Integer) return Int; -- Convert the real value from integer to decimal representation @@ -59,6 +61,7 @@ package body System.Value_D is Val : Uns; Base : Unsigned; ScaleB : Integer; + Extra2 : Unsigned; Minus : Boolean; Scale : Integer) return Int is @@ -72,7 +75,7 @@ package body System.Value_D is -- updated to contain the remaining power in the computation. Note that -- Factor is expected to be positive in this context. - function Unsigned_To_Signed (Val : Uns) return Int; + function To_Signed (Val : Uns) return Int; -- Convert an integer value from unsigned to signed representation ----------------- @@ -99,11 +102,11 @@ package body System.Value_D is return Result; end Safe_Expont; - ------------------------ - -- Unsigned_To_Signed -- - ------------------------ + --------------- + -- To_Signed -- + --------------- - function Unsigned_To_Signed (Val : Uns) return Int is + function To_Signed (Val : Uns) return Int is begin -- Deal with overflow cases, and also with largest negative number @@ -124,34 +127,51 @@ package body System.Value_D is else return Int (Val); end if; - end Unsigned_To_Signed; + end To_Signed; + + -- Local variables + + V : Uns := Val; + S : Integer := ScaleB; + E : Unsigned := Extra2 / Base; begin + -- The implementation of Value_R uses fully symmetric arithmetics + -- but here we cannot handle 2**(Int'Size - 1) if Minus is not set. + + if V = 2**(Int'Size - 1) and then not Minus then + E := Unsigned (V rem Uns (Base)); + V := V / Uns (Base); + S := S + 1; + end if; + -- If the base of the value is 10 or its scaling factor is zero, then -- add the scales (they are defined in the opposite sense) and apply -- the result to the value, checking for overflow in the process. - if Base = 10 or else ScaleB = 0 then - declare - S : Integer := ScaleB + Scale; - V : Uns := Val; - + if Base = 10 or else S = 0 then begin + S := S + Scale; + while S < 0 loop + if V = 0 then + exit; + end if; V := V / 10; S := S + 1; end loop; while S > 0 loop - if V <= Uns'Last / 10 then - V := V * 10; + if V <= (Uns'Last - Uns (E)) / 10 then + V := V * 10 + Uns (E); S := S - 1; + E := 0; else Bad_Value (Str); end if; end loop; - return Unsigned_To_Signed (V); + return To_Signed (V); end; -- If the base of the value is not 10, use a scaled divide operation @@ -159,10 +179,7 @@ package body System.Value_D is else declare - B : constant Int := Int (Base); - S : constant Integer := ScaleB; - - V : Uns := Val; + B : constant Int := Int (Base); Y, Z, Q, R : Int; @@ -178,7 +195,10 @@ package body System.Value_D is Z := Safe_Expont (B, LS, 10 ** Integer'Max (0, -Scale)); for J in 1 .. LS loop - V := V / Uns (B); + if V = 0 then + exit; + end if; + V := V / Uns (Base); end loop; end; @@ -193,8 +213,9 @@ package body System.Value_D is Z := 10 ** Integer'Max (0, -Scale); for J in 1 .. LS loop - if V <= Uns'Last / Uns (B) then - V := V * Uns (B); + if V <= (Uns'Last - Uns (E)) / Uns (Base) then + V := V * Uns (Base) + Uns (E); + E := 0; else Bad_Value (Str); end if; @@ -207,9 +228,9 @@ package body System.Value_D is raise Program_Error; end if; - -- Perform a scale divide operation with rounding to match 'Image + -- Perform a scaled divide operation with rounding to match 'Image - Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q, R, Round => True); + Scaled_Divide (To_Signed (V), Y, Z, Q, R, Round => True); return Q; end; @@ -229,16 +250,17 @@ package body System.Value_D is Max : Integer; Scale : Integer) return Int is - Base : Unsigned; - Scl : Impl.Scale_Array; - Extra : Unsigned; - Minus : Boolean; - Val : Impl.Value_Array; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra2 : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus); + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra2, Minus); - return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale); + return + Integer_to_Decimal (Str, Val (1), Base, Scl (1), Extra2, Minus, Scale); end Scan_Decimal; ------------------- @@ -246,16 +268,17 @@ package body System.Value_D is ------------------- function Value_Decimal (Str : String; Scale : Integer) return Int is - Base : Unsigned; - Scl : Impl.Scale_Array; - Extra : Unsigned; - Minus : Boolean; - Val : Impl.Value_Array; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra2 : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus); + Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra2, Minus); - return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale); + return + Integer_to_Decimal (Str, Val (1), Base, Scl (1), Extra2, Minus, Scale); end Value_Decimal; end System.Value_D; diff --git a/gcc/ada/libgnat/s-valuef.adb b/gcc/ada/libgnat/s-valuef.adb index 9930740..1743749 100644 --- a/gcc/ada/libgnat/s-valuef.adb +++ b/gcc/ada/libgnat/s-valuef.adb @@ -46,15 +46,15 @@ package body System.Value_F is pragma Assert (Int'Size <= Uns'Size); -- We need an unsigned type large enough to represent the mantissa - package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => True); - -- We use the Extra digit for ordinary fixed-point types + package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1)); + -- We use the Extra digits for ordinary fixed-point types function Integer_To_Fixed (Str : String; Val : Uns; Base : Unsigned; ScaleB : Integer; - Extra : Unsigned; + Extra2 : Unsigned; Minus : Boolean; Num : Int; Den : Int) return Int; @@ -79,23 +79,25 @@ package body System.Value_F is -- Of course N1 = N2 + 1 holds, which means both that Val may not contain -- enough significant bits to represent all the values of the type and that - -- 1 extra decimal digit contains the information for the missing bits. + -- 1 extra decimal digit contains the information for the missing bits. But + -- in practice we need 2 extra decimal digits to avoid multiple roundings. -- Therefore the actual computation to be performed is - -- V = (Val * Base + Extra) * (Base ** (ScaleB - 1)) / (Num / Den) + -- V = (Val * Base ** 2 + Extra2) * (Base ** (ScaleB - 2)) / (Num / Den) - -- using two steps of scaled divide if Extra is positive and ScaleB too + -- using two steps of scaled divide if Extra2 is positive and ScaleB too - -- (1) Val * (Den * (Base ** ScaleB)) = Q1 * Num + R1 + -- (1a) Val * (Den * (Base ** ScaleB)) = Q1 * Num + R1 - -- (2) Extra * (Den * (Base ** ScaleB)) = Q2 * -Base + R2 + -- (2a) Extra2 * (Den * (Base ** ScaleB)) = Q2 * Base ** 2 + R2 - -- which yields after dividing (1) by Num and (2) by Num * Base and summing + -- which yields after dividing (1a) by Num and (2a) by Num * (Base ** 2) + -- and summing - -- V = Q1 + (R1 - Q2) / Num + R2 / (Num * Base) + -- V = Q1 + (Q2 + R1) / Num + R2 / (Num * (Base ** 2)) - -- but we get rid of the third term by using a rounding divide for (2). + -- but we get rid of the third term by using a rounding divide for (2a). -- This works only if Den * (Base ** ScaleB) does not overflow for inputs -- corresponding to 'Image. Let S = Num / Den, B = Base and N the scale in @@ -113,17 +115,17 @@ package body System.Value_F is -- which means that the product does not overflow if Num <= 2**(M-1) / B. - -- On the other hand, if Extra is positive and ScaleB negative, the above + -- On the other hand, if Extra2 is positive and ScaleB negative, the above -- two steps are -- (1b) Val * Den = Q1 * (Num * (Base ** -ScaleB)) + R1 - -- (2b) Extra * Den = Q2 * -Base + R2 + -- (2b) Extra2 * Den = Q2 * Base ** 2 + R2 -- which yields after dividing (1b) by Num * (Base ** -ScaleB) and (2b) by - -- Num * (Base ** (1 - ScaleB)) and summing + -- Num * (Base ** (2 - ScaleB)) and summing - -- V = Q1 + (R1 - Q2) / (Num * (Base ** -ScaleB)) + R2 / ... + -- V = Q1 + (Q2 + R1) / (Num * (Base ** -ScaleB)) + R2 / (Num * (...)) -- but we get rid of the third term by using a rounding divide for (2b). @@ -143,19 +145,22 @@ package body System.Value_F is Val : Uns; Base : Unsigned; ScaleB : Integer; - Extra : Unsigned; + Extra2 : Unsigned; Minus : Boolean; Num : Int; Den : Int) return Int is pragma Assert (Base in 2 .. 16); - pragma Assert (Extra < Base); - -- Accept only one extra digit after those used for Val + pragma Assert (Extra2 < Base ** 2); + -- Accept only two extra digits after those used for Val pragma Assert (Num < 0 and then Den < 0); -- Accept only negative numbers to allow -2**(Int'Size - 1) + pragma Unsuppress (Overflow_Check); + -- Use overflow check to catch bad values + function Safe_Expont (Base : Int; Exp : in out Natural; @@ -166,7 +171,7 @@ package body System.Value_F is -- updated to contain the remaining power in the computation. Note that -- Factor is expected to be negative in this context. - function Unsigned_To_Signed (Val : Uns) return Int; + function To_Signed (Val : Uns) return Int; -- Convert an integer value from unsigned to signed representation ----------------- @@ -193,11 +198,11 @@ package body System.Value_F is return Result; end Safe_Expont; - ------------------------ - -- Unsigned_To_Signed -- - ------------------------ + --------------- + -- To_Signed -- + --------------- - function Unsigned_To_Signed (Val : Uns) return Int is + function To_Signed (Val : Uns) return Int is begin -- Deal with overflow cases, and also with largest negative number @@ -218,60 +223,74 @@ package body System.Value_F is else return Int (Val); end if; - end Unsigned_To_Signed; + end To_Signed; -- Local variables B : constant Int := Int (Base); - V : Uns := Val; - E : Uns := Uns (Extra); + V : Uns := Val; + S : Integer := ScaleB; + E : Unsigned := Extra2; Y, Z, Q1, R1, Q2, R2 : Int; begin + -- The implementation of Value_R uses fully symmetric arithmetics + -- but here we cannot handle 2**(Int'Size - 1) if Minus is not set. + + if V = 2**(Int'Size - 1) and then not Minus then + E := Unsigned (V rem Uns (Base)) * Base + E / Base; + V := V / Uns (Base); + S := S + 1; + end if; + -- We will use a scaled divide operation for which we must control the -- magnitude of operands so that an overflow exception is not unduly -- raised during the computation. The only real concern is the exponent. - -- If ScaleB is too negative, then drop trailing digits, but preserve - -- the last dropped digit. + -- If S is too negative, then drop trailing digits, but preserve the + -- last two dropped digits, until V saturates to 0. - if ScaleB < 0 then + if S < 0 then declare - LS : Integer := -ScaleB; + LS : Integer := -S; begin Y := Den; Z := Safe_Expont (B, LS, Num); for J in 1 .. LS loop - E := V rem Uns (B); - V := V / Uns (B); + if V = 0 then + E := 0; + exit; + end if; + E := Unsigned (V rem Uns (Base)) * Base + E / Base; + V := V / Uns (Base); end loop; end; - -- If ScaleB is too positive, then scale V up, which may then overflow + -- If S is too positive, then scale V up, which may then overflow - elsif ScaleB > 0 then + elsif S > 0 then declare - LS : Integer := ScaleB; + LS : Integer := S; begin Y := Safe_Expont (B, LS, Den); Z := Num; for J in 1 .. LS loop - if V <= (Uns'Last - E) / Uns (B) then - V := V * Uns (B) + E; - E := 0; + if V <= (Uns'Last - Uns (E / Base)) / Uns (Base) then + V := V * Uns (Base) + Uns (E / Base); + E := (E rem Base) * Base; else Bad_Value (Str); end if; end loop; end; - -- If ScaleB is zero, then proceed directly + -- If S is zero, then proceed directly else Y := Den; @@ -284,8 +303,8 @@ package body System.Value_F is -- sign of the first operand and the sign of the remainder the opposite. if E > 0 then - Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q1, R1, Round => False); - Scaled_Divide (Unsigned_To_Signed (E), Y, -B, Q2, R2, Round => True); + Scaled_Divide (To_Signed (V), Y, Z, Q1, R1, Round => False); + Scaled_Divide (To_Signed (Uns (E)), Y, -B**2, Q2, R2, Round => True); -- Avoid an overflow during the subtraction. Note that Q2 is smaller -- than Y and R1 smaller than Z in magnitude, so it is safe to take @@ -312,7 +331,7 @@ package body System.Value_F is return Q1 + Q2; else - Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q1, R1, Round => True); + Scaled_Divide (To_Signed (V), Y, Z, Q1, R1, Round => True); return Q1; end if; @@ -332,17 +351,17 @@ package body System.Value_F is Num : Int; Den : Int) return Int is - Base : Unsigned; - Scl : Impl.Scale_Array; - Extra : Unsigned; - Minus : Boolean; - Val : Impl.Value_Array; + Bas : Unsigned; + Scl : Impl.Scale_Array; + Extra2 : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus); + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Bas, Scl, Extra2, Minus); return - Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den); + Integer_To_Fixed (Str, Val (1), Bas, Scl (1), Extra2, Minus, Num, Den); end Scan_Fixed; ----------------- @@ -354,17 +373,17 @@ package body System.Value_F is Num : Int; Den : Int) return Int is - Base : Unsigned; - Scl : Impl.Scale_Array; - Extra : Unsigned; - Minus : Boolean; - Val : Impl.Value_Array; + Bas : Unsigned; + Scl : Impl.Scale_Array; + Extra2 : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus); + Val := Impl.Value_Raw_Real (Str, Bas, Scl, Extra2, Minus); return - Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den); + Integer_To_Fixed (Str, Val (1), Bas, Scl (1), Extra2, Minus, Num, Den); end Value_Fixed; end System.Value_F; diff --git a/gcc/ada/libgnat/s-valuei.adb b/gcc/ada/libgnat/s-valuei.adb index 2c4fe09..53790a0 100644 --- a/gcc/ada/libgnat/s-valuei.adb +++ b/gcc/ada/libgnat/s-valuei.adb @@ -33,16 +33,6 @@ with System.Val_Util; use System.Val_Util; package body System.Value_I is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - ------------------ -- Scan_Integer -- ------------------ @@ -53,25 +43,6 @@ package body System.Value_I is Max : Integer; Res : out Int) is - procedure Prove_Is_Int_Of_Uns - (Minus : Boolean; - Uval : Uns; - Val : Int) - with Ghost, - Pre => Spec.Uns_Is_Valid_Int (Minus, Uval) - and then - (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First - elsif Minus then Val = -(Int (Uval)) - else Val = Int (Uval)), - Post => Spec.Is_Int_Of_Uns (Minus, Uval, Val); - -- Unfold the definition of Is_Int_Of_Uns - - procedure Prove_Is_Int_Of_Uns - (Minus : Boolean; - Uval : Uns; - Val : Int) - is null; - Uval : Uns; -- Unsigned result @@ -81,15 +52,6 @@ package body System.Value_I is Unused_Start : Positive; -- Saves location of first non-blank (not used in this case) - Non_Blank : constant Positive := - First_Non_Space_Ghost (Str, Ptr.all, Max) - with Ghost; - - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank) - with Ghost; - begin Scan_Sign (Str, Ptr, Max, Minus, Unused_Start); @@ -99,8 +61,6 @@ package body System.Value_I is end if; Scan_Raw_Unsigned (Str, Ptr, Max, Uval); - pragma Assert - (Uval = U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max)); -- Deal with overflow cases, and also with largest negative number @@ -121,11 +81,6 @@ package body System.Value_I is else Res := Int (Uval); end if; - - Prove_Is_Int_Of_Uns - (Minus => Str (Non_Blank) = '-', - Uval => Uval, - Val => Res); end Scan_Integer; ------------------- @@ -141,15 +96,7 @@ package body System.Value_I is if Str'Last = Positive'Last then declare subtype NT is String (1 .. Str'Length); - procedure Prove_Is_Integer_Ghost with - Ghost, - Pre => Str'Length < Natural'Last - and then not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Spec.Is_Integer_Ghost (Spec.Slide_To_1 (Str)), - Post => Spec.Is_Integer_Ghost (NT (Str)); - procedure Prove_Is_Integer_Ghost is null; begin - Prove_Is_Integer_Ghost; return Value_Integer (NT (Str)); end; @@ -159,31 +106,14 @@ package body System.Value_I is declare V : Int; P : aliased Integer := Str'First; - - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last) - with Ghost; - - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank) - with Ghost; begin - declare P_Acc : constant not null access Integer := P'Access; begin Scan_Integer (Str, P_Acc, Str'Last, V); end; - pragma Assert - (P = U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Str'Last)); - Scan_Trailing_Blanks (Str, P); - - pragma Assert - (Spec.Is_Value_Integer_Ghost (Spec.Slide_If_Necessary (Str), V)); return V; end; end if; diff --git a/gcc/ada/libgnat/s-valuei.ads b/gcc/ada/libgnat/s-valuei.ads index 531eae1..08619c8 100644 --- a/gcc/ada/libgnat/s-valuei.ads +++ b/gcc/ada/libgnat/s-valuei.ads @@ -32,16 +32,6 @@ -- This package contains routines for scanning signed integer values for use -- in Text_IO.Integer_IO, and the Value attribute. -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Val_Spec; use System.Val_Spec; -with System.Value_I_Spec; -with System.Value_U_Spec; - generic type Int is range <>; @@ -54,13 +44,6 @@ generic Max : Integer; Res : out Uns); - -- Additional parameters for ghost subprograms used inside contracts - - with package U_Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - with package Spec is new System.Value_I_Spec - (Int => Int, Uns => Uns, U_Spec => U_Spec) - with Ghost; - package System.Value_I is pragma Preelaborate; @@ -68,43 +51,7 @@ package System.Value_I is (Str : String; Ptr : not null access Integer; Max : Integer; - Res : out Int) - with - Pre => Str'Last /= Positive'Last - -- Ptr.all .. Max is either an empty range, or a valid range in Str - and then (Ptr.all > Max - or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then not Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Ptr.all, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank); - begin - U_Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max)) - and then U_Spec.Raw_Unsigned_No_Overflow_Ghost - (Str, Fst_Num, Max) - and then Spec.Uns_Is_Valid_Int - (Minus => Str (Non_Blank) = '-', - Uval => U_Spec.Scan_Raw_Unsigned_Ghost - (Str, Fst_Num, Max))), - Post => - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Ptr.all'Old, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 - else Non_Blank); - Uval : constant Uns := - U_Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max); - begin - Spec.Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', - Uval => Uval, - Val => Res) - and then Ptr.all = U_Spec.Raw_Unsigned_Last_Ghost - (Str, Fst_Num, Max)); + Res : out Int); -- This procedure scans the string starting at Str (Ptr.all) for a valid -- integer according to the syntax described in (RM 3.5(43)). The substring -- scanned extends no further than Str (Max). There are three cases for the @@ -130,14 +77,7 @@ package System.Value_I is -- special case of an all-blank string, and Ptr is unchanged, and hence -- is greater than Max as required in this case. - function Value_Integer (Str : String) return Int - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Length /= Positive'Last - and then Spec.Is_Integer_Ghost (Spec.Slide_If_Necessary (Str)), - Post => Spec.Is_Value_Integer_Ghost - (Spec.Slide_If_Necessary (Str), Value_Integer'Result), - Subprogram_Variant => (Decreases => Str'First); + function Value_Integer (Str : String) return Int; -- Used in computing X'Value (Str) where X is a signed integer type whose -- base range does not exceed the base range of Integer. Str is the string -- argument of the attribute. Constraint_Error is raised if the string is diff --git a/gcc/ada/libgnat/s-valuen.ads b/gcc/ada/libgnat/s-valuen.ads index 047ded6..a57ee55 100644 --- a/gcc/ada/libgnat/s-valuen.ads +++ b/gcc/ada/libgnat/s-valuen.ads @@ -30,8 +30,8 @@ ------------------------------------------------------------------------------ -- This package is used to compute the Value attribute for enumeration types --- other than those in packages Standard and System. See unit Exp_Imgv for --- details of the format of constructed image tables. +-- other than those in package Standard. See unit Exp_Imgv for details of the +-- format of constructed image tables. generic diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb index 6f557e9..961dda4 100644 --- a/gcc/ada/libgnat/s-valuer.adb +++ b/gcc/ada/libgnat/s-valuer.adb @@ -42,14 +42,6 @@ package body System.Value_R is function As_Digit (C : Character) return Char_As_Digit; -- Given a character return the digit it represents - procedure Round_Extra - (Digit : Char_As_Digit; - Base : Unsigned; - Value : in out Uns; - Scale : in out Integer; - Extra : in out Char_As_Digit); - -- Round the triplet (Value, Scale, Extra) according to Digit in Base - procedure Scan_Decimal_Digits (Str : String; Index : in out Integer; @@ -59,7 +51,7 @@ package body System.Value_R is Value : in out Value_Array; Scale : in out Scale_Array; N : in out Positive; - Extra : in out Char_As_Digit; + Extra2 : in out Unsigned; Base_Violation : in out Boolean); -- Scan the decimal part of a real (i.e. after decimal separator) -- @@ -68,7 +60,8 @@ package body System.Value_R is -- -- For each digit parsed, Value = Value * Base + Digit and Scale is -- decremented by 1. If precision limit is reached, remaining digits are - -- still parsed but ignored, except for the first which is stored in Extra. + -- still parsed but ignored, except for the first two of them which are + -- stored in Extra2. -- -- Base_Violation is set to True if a digit found is not part of the Base -- @@ -83,7 +76,8 @@ package body System.Value_R is Value : out Value_Array; Scale : out Scale_Array; N : out Positive; - Extra : out Char_As_Digit; + Extra2 : out Unsigned; + Extra2_Filled : out Boolean; Base_Violation : in out Boolean); -- Scan the integral part of a real (i.e. before decimal separator) -- @@ -93,7 +87,7 @@ package body System.Value_R is -- For each digit parsed, either Value := Value * Base + Digit or Scale -- is incremented by 1 if precision limit is reached, in which case the -- remaining digits are still parsed but ignored, except for the first - -- which is stored in Extra. + -- two of them which are stored in Extra2 if Extra2_Filled is True. -- -- Base_Violation is set to True if a digit found is not part of the Base -- @@ -119,47 +113,6 @@ package body System.Value_R is end case; end As_Digit; - ----------------- - -- Round_Extra -- - ----------------- - - procedure Round_Extra - (Digit : Char_As_Digit; - Base : Unsigned; - Value : in out Uns; - Scale : in out Integer; - Extra : in out Char_As_Digit) - is - pragma Assert (Base in 2 .. 16); - - B : constant Uns := Uns (Base); - - begin - if Digit >= Base / 2 then - - -- If Extra is maximum, round Value - - if Extra = Base - 1 then - - -- If Value is maximum, scale it up - - if Value = Precision_Limit then - Extra := Char_As_Digit (Value mod B); - Value := Value / B; - Scale := Scale + 1; - Round_Extra (Digit, Base, Value, Scale, Extra); - - else - Extra := 0; - Value := Value + 1; - end if; - - else - Extra := Extra + 1; - end if; - end if; - end Round_Extra; - ------------------------- -- Scan_Decimal_Digits -- ------------------------- @@ -173,7 +126,7 @@ package body System.Value_R is Value : in out Value_Array; Scale : in out Scale_Array; N : in out Positive; - Extra : in out Char_As_Digit; + Extra2 : in out Unsigned; Base_Violation : in out Boolean) is @@ -192,8 +145,7 @@ package body System.Value_R is -- to Precision_Limit. Precision_Limit_Just_Reached : Boolean; - -- Set to True if Precision_Limit_Reached was just set to True, but only - -- used when Round is True. + -- Set to True if Precision_Limit_Reached was just set to True Digit : Char_As_Digit; -- The current digit @@ -205,17 +157,16 @@ package body System.Value_R is -- Number of trailing zeros at a given point begin - -- If initial Scale is not 0 then it means that Precision_Limit was + -- If initial Scale is not 0, then this means that Precision_Limit was -- reached during scanning of the integral part. if Scale (Data_Index'Last) > 0 then Precision_Limit_Reached := True; + Precision_Limit_Just_Reached := True; + else - Extra := 0; + Extra2 := 0; Precision_Limit_Reached := False; - end if; - - if Round then Precision_Limit_Just_Reached := False; end if; @@ -229,28 +180,27 @@ package body System.Value_R is Digit := As_Digit (Str (Index)); loop - -- Check if base is correct. If the base is not specified, the digit - -- E or e cannot be considered as a base violation as it can be used - -- for exponentiation. + -- If the base is not explicitly specified, 'e' or 'E' marks the + -- beginning of the exponent part. + + if not Base_Specified and then Digit = E_Digit then + return; + end if; + + -- Check that Digit is a valid digit with respect to Base if Digit >= Base then - if Base_Specified then - Base_Violation := True; - elsif Digit = E_Digit then - return; - else - Base_Violation := True; - end if; + Base_Violation := True; end if; -- If precision limit has been reached, just ignore any remaining -- digits for the computation of Value and Scale, but store the - -- first in Extra and use the second to round Extra. The scanning - -- should continue only to assess the validity of the string. + -- first two digits in Extra2. The scanning should continue only + -- to assess the validity of the string. if Precision_Limit_Reached then - if Round and then Precision_Limit_Just_Reached then - Round_Extra (Digit, Base, Value (N), Scale (N), Extra); + if Precision_Limit_Just_Reached then + Extra2 := Extra2 + Digit; Precision_Limit_Just_Reached := False; end if; @@ -273,11 +223,8 @@ package body System.Value_R is Scale (N) := Scale (N - 1) - 1; else - Extra := 0; + Extra2 := (if J = Trailing_Zeros then Digit else 0); Precision_Limit_Reached := True; - if Round and then J = Trailing_Zeros then - Round_Extra (Digit, Base, Value (N), Scale (N), Extra); - end if; exit; end if; @@ -316,11 +263,9 @@ package body System.Value_R is Scale (N) := Scale (N - 1) - 1; else - Extra := Digit; + Extra2 := Digit * Base; Precision_Limit_Reached := True; - if Round then - Precision_Limit_Just_Reached := True; - end if; + Precision_Limit_Just_Reached := True; end if; end if; end if; @@ -339,10 +284,12 @@ package body System.Value_R is -- Underscore is only allowed if followed by a digit - if Digit = Underscore and Index + 1 <= Max then + if Digit = Underscore and then Index + 1 <= Max then Digit := As_Digit (Str (Index + 1)); - if Digit in Valid_Digit then + if Digit in Valid_Digit and then + (Digit /= E_Digit or else Base > E_Digit) + then Index := Index + 1; else return; @@ -370,7 +317,8 @@ package body System.Value_R is Value : out Value_Array; Scale : out Scale_Array; N : out Positive; - Extra : out Char_As_Digit; + Extra2 : out Unsigned; + Extra2_Filled : out Boolean; Base_Violation : in out Boolean) is pragma Assert (Base in 2 .. 16); @@ -386,8 +334,7 @@ package body System.Value_R is -- to Precision_Limit. Precision_Limit_Just_Reached : Boolean; - -- Set to True if Precision_Limit_Reached was just set to True, but only - -- used when Round is True. + -- Set to True if Precision_Limit_Reached was just set to True Digit : Char_As_Digit; -- The current digit @@ -396,18 +343,16 @@ package body System.Value_R is -- Temporary begin - -- Initialize N, Value, Scale and Extra + -- Initialize N, Value, Scale, Extra2 and Extra2_Filled N := 1; Value := (others => 0); Scale := (others => 0); - Extra := 0; + Extra2 := 0; + Extra2_Filled := False; Precision_Limit_Reached := False; - - if Round then - Precision_Limit_Just_Reached := False; - end if; + Precision_Limit_Just_Reached := False; pragma Assert (Max <= Str'Last); @@ -417,30 +362,30 @@ package body System.Value_R is Digit := As_Digit (Str (Index)); loop - -- Check if base is correct. If the base is not specified, the digit - -- E or e cannot be considered as a base violation as it can be used - -- for exponentiation. + -- If the base is not explicitly specified, 'e' or 'E' marks the + -- beginning of the exponent part. + + if not Base_Specified and then Digit = E_Digit then + return; + end if; + + -- Check that Digit is a valid digit with respect to Base if Digit >= Base then - if Base_Specified then - Base_Violation := True; - elsif Digit = E_Digit then - return; - else - Base_Violation := True; - end if; + Base_Violation := True; end if; -- If precision limit has been reached, just ignore any remaining -- digits for the computation of Value and Scale, but store the - -- first in Extra and use the second to round Extra. The scanning - -- should continue only to assess the validity of the string. + -- first two digits in Extra2. The scanning should continue only + -- to assess the validity of the string. if Precision_Limit_Reached then Scale (N) := Scale (N) + 1; - if Round and then Precision_Limit_Just_Reached then - Round_Extra (Digit, Base, Value (N), Scale (N), Extra); + if Precision_Limit_Just_Reached then + Extra2 := Extra2 + Digit; + Extra2_Filled := True; Precision_Limit_Just_Reached := False; end if; @@ -465,11 +410,9 @@ package body System.Value_R is Value (N) := Uns (Digit); else - Extra := Digit; + Extra2 := Digit * Base; Precision_Limit_Reached := True; - if Round then - Precision_Limit_Just_Reached := True; - end if; + Precision_Limit_Just_Reached := True; Scale (N) := Scale (N) + 1; end if; end if; @@ -494,9 +437,11 @@ package body System.Value_R is -- Next character is not a digit. In that case stop scanning -- unless the next chracter is an underscore followed by a digit. - if Digit = Underscore and Index + 1 <= Max then + if Digit = Underscore and then Index + 1 <= Max then Digit := As_Digit (Str (Index + 1)); - if Digit in Valid_Digit then + if Digit in Valid_Digit and then + (Digit /= E_Digit or else Base > E_Digit) + then Index := Index + 1; else return; @@ -513,13 +458,13 @@ package body System.Value_R is ------------------- function Scan_Raw_Real - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Base : out Unsigned; - Scale : out Scale_Array; - Extra : out Unsigned; - Minus : out Boolean) return Value_Array + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Base : out Unsigned; + Scale : out Scale_Array; + Extra2 : out Unsigned; + Minus : out Boolean) return Value_Array is pragma Assert (Max <= Str'Last); @@ -534,6 +479,9 @@ package body System.Value_R is -- If True some digits where not in the base. The real is still scanned -- till the end even if an error will be raised. + Extra2_Filled : Boolean; + -- True if Extra2 has been filled + N : Positive; -- Index number of the current part @@ -578,12 +526,12 @@ package body System.Value_R is if Str (Index) in '0' .. '9' then After_Point := False; - -- If this is a digit it can indicates either the float decimal - -- part or the base to use. + -- If this is a digit it can indicate either the integral part or the + -- base to use. Scan_Integral_Digits (Str, Index, Max, Base, False, Value, Scale, N, - Char_As_Digit (Extra), Base_Violation); + Extra2, Extra2_Filled, Base_Violation); -- A dot is allowed only if followed by a digit (RM 3.5(39.8)) @@ -596,13 +544,15 @@ package body System.Value_R is N := 1; Value := (others => 0); Scale := (others => 0); - Extra := 0; + Extra2 := 0; + Extra2_Filled := False; else Bad_Value (Str); end if; - -- Check if the first number encountered is a base + -- Check if the first number encountered is a base. ':' is allowed in + -- place of '#' in virtue of RM J.2 (3). pragma Assert (Index >= Str'First); @@ -611,7 +561,13 @@ package body System.Value_R is then Base_Char := Str (Index); - if N = 1 and then Value (1) in 2 .. 16 then + -- Functionally, "(Parts = 1 or else N = 1)" in the condition of the + -- following if statement could replaced by the simpler "N = 1". The + -- reason we use a more complicated expression is to accommodate + -- machine-code-based coverage tools: the simple version makes it + -- impossible to fully cover generic instances of System.Value_R with + -- Parts = 1. + if (Parts = 1 or else N = 1) and then Value (1) in 2 .. 16 then Base := Unsigned (Value (1)); else Base_Violation := True; @@ -630,16 +586,16 @@ package body System.Value_R is end if; end if; - -- Scan the integral part if still necessary + -- Scan the integral part if there was a base and no point right after if Base_Char /= ASCII.NUL and then not After_Point then - if Index > Max or else As_Digit (Str (Index)) not in Valid_Digit then + if As_Digit (Str (Index)) not in Valid_Digit then Bad_Value (Str); end if; Scan_Integral_Digits (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale, - N, Char_As_Digit (Extra), Base_Violation); + N, Extra2, Extra2_Filled, Base_Violation); end if; -- Do we have a dot? @@ -664,9 +620,22 @@ package body System.Value_R is if After_Point then pragma Assert (Index <= Max); - Scan_Decimal_Digits - (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale, - N, Char_As_Digit (Extra), Base_Violation); + -- If Extra2 has been filled, we are done with it + + if Extra2_Filled then + declare + Dummy : Unsigned := 0; + begin + Scan_Decimal_Digits + (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale, + N, Dummy, Base_Violation); + end; + + else + Scan_Decimal_Digits + (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale, + N, Extra2, Base_Violation); + end if; end if; -- If an explicit base was specified ensure that the delimiter is found @@ -714,11 +683,11 @@ package body System.Value_R is -------------------- function Value_Raw_Real - (Str : String; - Base : out Unsigned; - Scale : out Scale_Array; - Extra : out Unsigned; - Minus : out Boolean) return Value_Array + (Str : String; + Base : out Unsigned; + Scale : out Scale_Array; + Extra2 : out Unsigned; + Minus : out Boolean) return Value_Array is P : aliased Integer; V : Value_Array; @@ -732,14 +701,14 @@ package body System.Value_R is declare subtype NT is String (1 .. Str'Length); begin - return Value_Raw_Real (NT (Str), Base, Scale, Extra, Minus); + return Value_Raw_Real (NT (Str), Base, Scale, Extra2, Minus); end; end if; -- Normal case P := Str'First; - V := Scan_Raw_Real (Str, P'Access, Str'Last, Base, Scale, Extra, Minus); + V := Scan_Raw_Real (Str, P'Access, Str'Last, Base, Scale, Extra2, Minus); Scan_Trailing_Blanks (Str, P); return V; diff --git a/gcc/ada/libgnat/s-valuer.ads b/gcc/ada/libgnat/s-valuer.ads index 9f27998..e48241e 100644 --- a/gcc/ada/libgnat/s-valuer.ads +++ b/gcc/ada/libgnat/s-valuer.ads @@ -45,9 +45,6 @@ generic Precision_Limit : Uns; -- Precision limit for each part of the value - Round : Boolean; - -- If Parts = 1, True if the extra digit must be rounded - package System.Value_R is pragma Preelaborate; @@ -61,13 +58,13 @@ package System.Value_R is -- The value split into parts function Scan_Raw_Real - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Base : out Unsigned; - Scale : out Scale_Array; - Extra : out Unsigned; - Minus : out Boolean) return Value_Array; + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Base : out Unsigned; + Scale : out Scale_Array; + Extra2 : out Unsigned; + Minus : out Boolean) return Value_Array; -- This function scans the string starting at Str (Ptr.all) for a valid -- real literal according to the syntax described in (RM 3.5(43)). The -- substring scanned extends no further than Str (Max). There are three @@ -75,17 +72,18 @@ package System.Value_R is -- -- If a valid real is found after scanning past any initial spaces, then -- Ptr.all is updated past the last character of the real (but trailing - -- spaces are not scanned out) and the Base, Scale, Extra and Minus out + -- spaces are not scanned out) and the Base, Scale, Extra2 and Minus out -- parameters are set; if Val is the result of the call, then the real -- represented by the literal is equal to -- - -- (Val (1) * Base + Extra) * (Base ** (Scale (1) - 1)) + -- (Val (1) * Base ** 2 + Extra2) * (Base ** (Scale (1) - 2)) -- -- when Parts = 1 and -- -- Sum [Val (N) * (Base ** Scale (N)), N in 1 .. Parts] -- - -- when Parts > 1, with the negative sign if Minus is true. + -- when Parts > 1, with the negative sign if Minus is true. Note that + -- Val (1) cannot be zero unless Val is entirely filled with zero. -- -- If no valid real is found, then Ptr.all points either to an initial -- non-blank character, or to Max + 1 if the field is all spaces and the @@ -108,11 +106,11 @@ package System.Value_R is -- case is not supported. Most such cases are eliminated by the caller. function Value_Raw_Real - (Str : String; - Base : out Unsigned; - Scale : out Scale_Array; - Extra : out Unsigned; - Minus : out Boolean) return Value_Array; + (Str : String; + Base : out Unsigned; + Scale : out Scale_Array; + Extra2 : out Unsigned; + Minus : out Boolean) return Value_Array; -- Used in computing X'Value (Str) where X is a real type. Str is the -- string argument of the attribute. Constraint_Error is raised if the -- string is malformed. diff --git a/gcc/ada/libgnat/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb index e6f1d5e..a27e00f 100644 --- a/gcc/ada/libgnat/s-valueu.adb +++ b/gcc/ada/libgnat/s-valueu.adb @@ -29,78 +29,10 @@ -- -- ------------------------------------------------------------------------------ -with System.SPARK.Cut_Operations; use System.SPARK.Cut_Operations; with System.Val_Util; use System.Val_Util; package body System.Value_U is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - - use type Spec.Uns_Option; - use type Spec.Split_Value_Ghost; - - -- Local lemmas - - procedure Lemma_Digit_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - with Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then P in From .. To - and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1 - and then Spec.Is_Based_Format_Ghost (Str (From .. To)), - Post => - (if Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - then P <= Spec.Last_Hexa_Ghost (Str (From .. To))); - - procedure Lemma_Underscore_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - with Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then P in From .. To - and then Str (P) = '_' - and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1 - and then Spec.Is_Based_Format_Ghost (Str (From .. To)), - Post => P + 1 <= Spec.Last_Hexa_Ghost (Str (From .. To)) - and then Str (P + 1) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - - ----------------------------- - -- Local lemma null bodies -- - ----------------------------- - - procedure Lemma_Digit_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - is null; - - procedure Lemma_Underscore_Not_Last - (Str : String; - P : Integer; - From : Integer; - To : Integer) - is null; - ----------------------- -- Scan_Raw_Unsigned -- ----------------------- @@ -132,36 +64,6 @@ package body System.Value_U is Digit : Uns; -- Digit value - Ptr_Old : constant Integer := Ptr.all - with Ghost; - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (Ptr.all .. Max)) - with Ghost; - Init_Val : constant Spec.Uns_Option := - Spec.Scan_Based_Number_Ghost (Str, Ptr.all, Last_Num_Init) - with Ghost; - Starts_As_Based : constant Boolean := - Spec.Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, Max) - with Ghost; - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Spec.Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Max)) - else Last_Num_Init) - with Ghost; - Is_Based : constant Boolean := - Spec.Raw_Unsigned_Is_Based_Ghost - (Str, Last_Num_Init, Last_Num_Based, Max) - with Ghost; - Based_Val : constant Spec.Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Spec.Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val) - with Ghost; - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1) - with Ghost; - begin -- We do not tolerate strings with Str'Last = Positive'Last @@ -171,7 +73,15 @@ package body System.Value_U is end if; P := Ptr.all; - Spec.Lemma_Scan_Based_Number_Ghost_Step (Str, P, Last_Num_Init); + + -- Exit when the initial string to parse is empty + + if Max < P then + raise Program_Error with + "Scan end Max=" & Max'Img & + " is smaller than scan end Ptr=" & P'Img; + end if; + Uval := Character'Pos (Str (P)) - Character'Pos ('0'); pragma Assert (Str (P) in '0' .. '9'); P := P + 1; @@ -189,14 +99,6 @@ package body System.Value_U is begin -- Loop through decimal digits loop - pragma Loop_Invariant (P in P'Loop_Entry .. Last_Num_Init + 1); - pragma Loop_Invariant - (if Overflow then Init_Val.Overflow); - pragma Loop_Invariant - (if not Overflow - then Init_Val = Spec.Scan_Based_Number_Ghost - (Str, P, Last_Num_Init, Acc => Uval)); - exit when P > Max; Digit := Character'Pos (Str (P)) - Character'Pos ('0'); @@ -205,8 +107,6 @@ package body System.Value_U is if Digit > 9 then if Str (P) = '_' then - Spec.Lemma_Scan_Based_Number_Ghost_Underscore - (Str, P, Last_Num_Init, Acc => Uval); Scan_Underscore (Str, P, Ptr, Max, False); else exit; @@ -215,55 +115,23 @@ package body System.Value_U is -- Accumulate result, checking for overflow else - pragma Assert - (By - (Str (P) in '0' .. '9', - By - (Character'Pos (Str (P)) >= Character'Pos ('0'), - Uns '(Character'Pos (Str (P))) >= - Character'Pos ('0')))); - Spec.Lemma_Scan_Based_Number_Ghost_Step - (Str, P, Last_Num_Init, Acc => Uval); - Spec.Lemma_Scan_Based_Number_Ghost_Overflow - (Str, P, Last_Num_Init, Acc => Uval); - if Uval <= Umax then Uval := 10 * Uval + Digit; - pragma Assert - (if not Overflow - then Init_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Init, Acc => Uval)); - elsif Uval > Umax10 then Overflow := True; - else Uval := 10 * Uval + Digit; if Uval < Umax10 then Overflow := True; end if; - pragma Assert - (if not Overflow - then Init_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Init, Acc => Uval)); - end if; P := P + 1; end if; end loop; - Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str, P, Last_Num_Init, Acc => Uval); end; - pragma Assert_And_Cut - (By - (P = Last_Num_Init + 1, - P > Max or else Str (P) not in '_' | '0' .. '9') - and then Overflow = Init_Val.Overflow - and then (if not Overflow then Init_Val.Value = Uval)); - Ptr.all := P; -- Deal with based case. We recognize either the standard '#' or the @@ -295,10 +163,6 @@ package body System.Value_U is -- Numbers bigger than UmaxB overflow if multiplied by base begin - pragma Assert - (if Str (P) in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' - then Spec.Is_Based_Format_Ghost (Str (P .. Max))); - -- Loop to scan out based integer value loop @@ -321,49 +185,11 @@ package body System.Value_U is -- already stored in Ptr.all. else - pragma Assert - (By - (Spec.Only_Hexa_Ghost (Str, P, Last_Num_Based), - P > Last_Num_Init + 1 - and Spec.Only_Hexa_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based))); - Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str, P, Last_Num_Based, Base, Uval); Uval := Base; Base := 10; - pragma Assert (Ptr.all = Last_Num_Init + 1); - pragma Assert - (if Starts_As_Based - then By - (P = Last_Num_Based + 1, - P <= Last_Num_Based + 1 - and Str (P) not in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_')); - pragma Assert (not Is_Based); - pragma Assert (if not Overflow then Uval = Init_Val.Value); exit; end if; - pragma Loop_Invariant (P in P'Loop_Entry .. Last_Num_Based); - pragma Loop_Invariant - (Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then Digit = Spec.Hexa_To_Unsigned_Ghost (Str (P))); - pragma Loop_Invariant - (if Overflow'Loop_Entry then Overflow); - pragma Loop_Invariant - (if Overflow then - (Overflow'Loop_Entry or else Based_Val.Overflow)); - pragma Loop_Invariant - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P, Last_Num_Based, Base, Uval)); - pragma Loop_Invariant (Ptr.all = Last_Num_Init + 1); - - Spec.Lemma_Scan_Based_Number_Ghost_Step - (Str, P, Last_Num_Based, Base, Uval); - Spec.Lemma_Scan_Based_Number_Ghost_Overflow - (Str, P, Last_Num_Based, Base, Uval); - -- If digit is too large, just signal overflow and continue. -- The idea here is to keep scanning as long as the input is -- syntactically valid, even if we have detected overflow @@ -375,24 +201,14 @@ package body System.Value_U is elsif Uval <= Umax then Uval := Base * Uval + Digit; - pragma Assert - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Based, Base, Uval)); - elsif Uval > UmaxB then Overflow := True; - else Uval := Base * Uval + Digit; if Uval < UmaxB then Overflow := True; end if; - pragma Assert - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P + 1, Last_Num_Based, Base, Uval)); end if; -- If at end of string with no base char, not a based number @@ -411,86 +227,22 @@ package body System.Value_U is if Str (P) = Base_Char then Ptr.all := P + 1; - pragma Assert (P = Last_Num_Based + 1); - pragma Assert (Ptr.all = Last_Num_Based + 2); - pragma Assert - (By - (Is_Based, - So - (Starts_As_Based, - So - (Last_Num_Based < Max, - Str (Last_Num_Based + 1) = Base_Char - and Base_Char = Str (Last_Num_Init + 1))))); - Spec.Lemma_Scan_Based_Number_Ghost_Base - (Str, P, Last_Num_Based, Base, Uval); exit; -- Deal with underscore elsif Str (P) = '_' then - Lemma_Underscore_Not_Last (Str, P, Last_Num_Init + 2, Max); - Spec.Lemma_Scan_Based_Number_Ghost_Underscore - (Str, P, Last_Num_Based, Base, Uval); Scan_Underscore (Str, P, Ptr, Max, True); - pragma Assert - (if not Overflow - then Based_Val = Spec.Scan_Based_Number_Ghost - (Str, P, Last_Num_Based, Base, Uval)); - pragma Assert (Str (P) not in '_' | Base_Char); end if; - - Lemma_Digit_Not_Last (Str, P, Last_Num_Init + 2, Max); - pragma Assert (Str (P) not in '_' | Base_Char); end loop; end; - pragma Assert - (if Starts_As_Based then P = Last_Num_Based + 1 - else P = Last_Num_Init + 2); - pragma Assert - (By - (Overflow /= Spec.Scan_Split_No_Overflow_Ghost - (Str, Ptr_Old, Max), - So - (Last_Num_Init < Max - 1 - and then Str (Last_Num_Init + 1) in '#' | ':', - Overflow = - (Init_Val.Overflow - or else Init_Val.Value not in 2 .. 16 - or else (Starts_As_Based and Based_Val.Overflow))))); end if; - pragma Assert_And_Cut - (Overflow /= Spec.Scan_Split_No_Overflow_Ghost (Str, Ptr_Old, Max) - and then Ptr.all = First_Exp - and then Base in 2 .. 16 - and then - (if not Overflow then - (if Is_Based then Base = Init_Val.Value else Base = 10)) - and then - (if not Overflow then - (if Is_Based then Uval = Based_Val.Value - else Uval = Init_Val.Value))); - -- Come here with scanned unsigned value in Uval. The only remaining -- required step is to deal with exponent if one is present. Scan_Exponent (Str, Ptr, Max, Expon); - pragma Assert - (By - (Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr_Old, Max), - Ptr.all = - (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. Max)) - then First_Exp - elsif Str (First_Exp + 1) in '-' | '+' then - Last_Number_Ghost (Str (First_Exp + 2 .. Max)) + 1 - else Last_Number_Ghost (Str (First_Exp + 1 .. Max)) + 1))); - pragma Assert - (if not Overflow - then Spec.Scan_Split_Value_Ghost (Str, Ptr_Old, Max) = - (Uval, Base, Expon)); - if Expon /= 0 and then Uval /= 0 then -- For non-zero value, scale by exponent value. No need to do this @@ -500,66 +252,22 @@ package body System.Value_U is declare UmaxB : constant Uns := Uns'Last / Base; -- Numbers bigger than UmaxB overflow if multiplied by base - - Res_Val : constant Spec.Uns_Option := - Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base) - with Ghost; begin for J in 1 .. Expon loop - pragma Loop_Invariant - (if Overflow'Loop_Entry then Overflow); - pragma Loop_Invariant - (if Overflow - then Overflow'Loop_Entry or else Res_Val.Overflow); - pragma Loop_Invariant (Uval /= 0); - pragma Loop_Invariant - (if not Overflow - then Res_Val = Spec.Exponent_Unsigned_Ghost - (Uval, Expon - J + 1, Base)); - - pragma Assert - ((Uval > UmaxB) = Spec.Scan_Overflows_Ghost (0, Base, Uval)); - if Uval > UmaxB then - Spec.Lemma_Exponent_Unsigned_Ghost_Overflow - (Uval, Expon - J + 1, Base); Overflow := True; exit; end if; - Spec.Lemma_Exponent_Unsigned_Ghost_Step - (Uval, Expon - J + 1, Base); - Uval := Uval * Base; end loop; - Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, Base); - - pragma Assert - (Overflow /= - Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max)); - pragma Assert (if not Overflow then Res_Val = (False, Uval)); end; end if; - Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, Expon, Base); - pragma Assert - (if Expon = 0 or else Uval = 0 then - Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base) = (False, Uval)); - pragma Assert - (Overflow /= - Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max)); - pragma Assert - (if not Overflow then - Uval = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr_Old, Max)); -- Return result, dealing with overflow if Overflow then Bad_Value (Str); - pragma Annotate - (GNATprove, Intentional, - "call to nonreturning subprogram might be executed", - "it is expected that Constraint_Error is raised in case of" - & " overflow"); else Res := Uval; end if; @@ -608,15 +316,7 @@ package body System.Value_U is if Str'Last = Positive'Last then declare subtype NT is String (1 .. Str'Length); - procedure Prove_Is_Unsigned_Ghost with - Ghost, - Pre => Str'Length < Natural'Last - and then not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Spec.Is_Unsigned_Ghost (Spec.Slide_To_1 (Str)), - Post => Spec.Is_Unsigned_Ghost (NT (Str)); - procedure Prove_Is_Unsigned_Ghost is null; begin - Prove_Is_Unsigned_Ghost; return Value_Unsigned (NT (Str)); end; @@ -626,12 +326,6 @@ package body System.Value_U is declare V : Uns; P : aliased Integer := Str'First; - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last) - with Ghost; - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank) - with Ghost; begin declare P_Acc : constant not null access Integer := P'Access; @@ -639,16 +333,7 @@ package body System.Value_U is Scan_Unsigned (Str, P_Acc, Str'Last, V); end; - pragma Assert - (P = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last)); - pragma Assert - (V = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)); - Scan_Trailing_Blanks (Str, P); - - pragma Assert - (Spec.Is_Value_Unsigned_Ghost - (Spec.Slide_If_Necessary (Str), V)); return V; end; end if; diff --git a/gcc/ada/libgnat/s-valueu.ads b/gcc/ada/libgnat/s-valueu.ads index 92e3ffe..488c342 100644 --- a/gcc/ada/libgnat/s-valueu.ads +++ b/gcc/ada/libgnat/s-valueu.ads @@ -32,29 +32,8 @@ -- This package contains routines for scanning modular Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Value_U_Spec; -with System.Val_Spec; use System.Val_Spec; - generic - type Uns is mod <>; - - -- Additional parameters for ghost subprograms used inside contracts - - with package Spec is new System.Value_U_Spec (Uns => Uns) with Ghost; - package System.Value_U is pragma Preelaborate; @@ -62,15 +41,7 @@ package System.Value_U is (Str : String; Ptr : not null access Integer; Max : Integer; - Res : out Uns) - with Pre => Str'Last /= Positive'Last - and then Ptr.all in Str'Range - and then Max in Ptr.all .. Str'Last - and then Spec.Is_Raw_Unsigned_Format_Ghost (Str (Ptr.all .. Max)), - Post => Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr.all'Old, Max) - and Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr.all'Old, Max) - and Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr.all'Old, Max); - + Res : out Uns); -- This function scans the string starting at Str (Ptr.all) for a valid -- integer according to the syntax described in (RM 3.5(43)). The substring -- scanned extends no further than Str (Max). Note: this does not scan @@ -131,11 +102,9 @@ package System.Value_U is -- This string results in a Constraint_Error with the pointer pointing -- past the second 2. -- - -- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - -- ??? This is not the case. We will read Str (Ptr.all) without checking - -- and increase Ptr.all by one. + -- Note: If Max is less than Ptr, then Ptr is left unchanged and + -- Program_Error is raised to indicate that a valid integer cannot + -- be parsed. -- -- Note: this routine should not be called with Str'Last = Positive'Last. -- If this occurs Program_Error is raised with a message noting that this @@ -145,45 +114,14 @@ package System.Value_U is (Str : String; Ptr : not null access Integer; Max : Integer; - Res : out Uns) - with Pre => Str'Last /= Positive'Last - and then Ptr.all in Str'Range - and then Max in Ptr.all .. Str'Last - and then not Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - Non_Blank : constant Positive := - First_Non_Space_Ghost (Str, Ptr.all, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max))), - Post => - (declare - Non_Blank : constant Positive := - First_Non_Space_Ghost (Str, Ptr.all'Old, Max); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Max) - and then Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max) - and then Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Max)); - + Res : out Uns); -- Same as Scan_Raw_Unsigned, except scans optional leading -- blanks, and an optional leading plus sign. -- -- Note: if a minus sign is present, Constraint_Error will be raised. -- Note: trailing blanks are not scanned. - function Value_Unsigned - (Str : String) return Uns - with Pre => Str'Length /= Positive'Last - and then not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Spec.Is_Unsigned_Ghost (Spec.Slide_If_Necessary (Str)), - Post => - Spec.Is_Value_Unsigned_Ghost - (Spec.Slide_If_Necessary (Str), Value_Unsigned'Result), - Subprogram_Variant => (Decreases => Str'First); + function Value_Unsigned (Str : String) return Uns; -- Used in computing X'Value (Str) where X is a modular integer type whose -- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str -- is the string argument of the attribute. Constraint_Error is raised if diff --git a/gcc/ada/libgnat/s-valuns.ads b/gcc/ada/libgnat/s-valuns.ads index 8bbb7fb..a015c12 100644 --- a/gcc/ada/libgnat/s-valuns.ads +++ b/gcc/ada/libgnat/s-valuns.ads @@ -32,28 +32,15 @@ -- This package contains routines for scanning modular Unsigned -- values for use in Text_IO.Modular_IO, and the Value attribute. --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - with System.Unsigned_Types; with System.Value_U; -with System.Vs_Uns; package System.Val_Uns with SPARK_Mode is pragma Preelaborate; subtype Unsigned is Unsigned_Types.Unsigned; - package Impl is new Value_U (Unsigned, System.Vs_Uns.Spec); + package Impl is new Value_U (Unsigned); procedure Scan_Raw_Unsigned (Str : String; diff --git a/gcc/ada/libgnat/s-valuti.adb b/gcc/ada/libgnat/s-valuti.adb index a2b79f1..a97ab00 100644 --- a/gcc/ada/libgnat/s-valuti.adb +++ b/gcc/ada/libgnat/s-valuti.adb @@ -29,15 +29,7 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - -with System.Case_Util; use System.Case_Util; +with System.Case_Util_NSS; use System.Case_Util_NSS; package body System.Val_Util with SPARK_Mode @@ -48,12 +40,11 @@ is --------------- procedure Bad_Value (S : String) is - pragma Annotate (GNATprove, Intentional, "exception might be raised", - "Intentional exception from Bad_Value"); begin -- Bad_Value might be called with very long strings allocated on the -- heap. Limit the size of the message so that we avoid creating a -- Storage_Error during error handling. + if S'Length > 127 then raise Constraint_Error with "bad input for 'Value: """ & S (S'First .. S'First + 127) & "..."""; @@ -69,8 +60,7 @@ is procedure Normalize_String (S : in out String; F, L : out Integer; - To_Upper_Case : Boolean) - is + To_Upper_Case : Boolean) is begin F := S'First; L := S'Last; @@ -84,9 +74,6 @@ is -- Scan for leading spaces while F < L and then S (F) = ' ' loop - pragma Loop_Invariant (F in S'First .. L - 1); - pragma Loop_Invariant (for all J in S'First .. F => S (J) = ' '); - pragma Loop_Variant (Increases => F); F := F + 1; end loop; @@ -101,9 +88,6 @@ is -- Scan for trailing spaces while S (L) = ' ' loop - pragma Loop_Invariant (L in F + 1 .. S'Last); - pragma Loop_Invariant (for all J in L .. S'Last => S (J) = ' '); - pragma Loop_Variant (Decreases => L); L := L - 1; end loop; @@ -112,8 +96,6 @@ is if To_Upper_Case and then S (F) /= ''' then for J in F .. L loop S (J) := To_Upper (S (J)); - pragma Loop_Invariant - (for all K in F .. J => S (K) = To_Upper (S'Loop_Entry (K))); end loop; end if; end Normalize_String; @@ -185,40 +167,23 @@ is X := 0; - declare - Rest : constant String := Str (P .. Max) with Ghost; - Last : constant Natural := Sp.Last_Number_Ghost (Rest) with Ghost; - - begin - pragma Assert (Sp.Is_Natural_Format_Ghost (Rest)); - - loop - pragma Assert (Str (P) in '0' .. '9'); + loop + pragma Assert (Str (P) in '0' .. '9'); - if X < (Integer'Last / 10) then - X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0')); - end if; - - pragma Loop_Invariant (X >= 0); - pragma Loop_Invariant (P in Rest'First .. Last); - pragma Loop_Invariant (Str (P) in '0' .. '9'); - pragma Loop_Invariant - (Sp.Scan_Natural_Ghost (Rest, Rest'First, 0) - = Sp.Scan_Natural_Ghost (Rest, P + 1, X)); - - P := P + 1; + if X < (Integer'Last / 10) then + X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0')); + end if; - exit when P > Max; + P := P + 1; - if Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, False); - else - exit when Str (P) not in '0' .. '9'; - end if; - end loop; + exit when P > Max; - pragma Assert (P = Last + 1); - end; + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + exit when Str (P) not in '0' .. '9'; + end if; + end loop; if M then X := -X; @@ -250,12 +215,6 @@ is while Str (P) = ' ' loop P := P + 1; - pragma Loop_Invariant (Ptr.all = Ptr.all'Loop_Entry); - pragma Loop_Invariant (P in Ptr.all .. Max); - pragma Loop_Invariant (for some J in P .. Max => Str (J) /= ' '); - pragma Loop_Invariant - (for all J in Ptr.all .. P - 1 => Str (J) = ' '); - if P > Max then Ptr.all := P; Bad_Value (Str); @@ -264,8 +223,6 @@ is Start := P; - pragma Assert (Start = Sp.First_Non_Space_Ghost (Str, Ptr.all, Max)); - -- Skip past an initial plus sign if Str (P) = '+' then @@ -292,7 +249,6 @@ is Start : out Positive) is P : Integer := Ptr.all; - begin -- Deal with case of null string (all blanks). As per spec, we raise -- constraint error, with Ptr unchanged, and thus > Max. @@ -306,12 +262,6 @@ is while Str (P) = ' ' loop P := P + 1; - pragma Loop_Invariant (Ptr.all = Ptr.all'Loop_Entry); - pragma Loop_Invariant (P in Ptr.all .. Max); - pragma Loop_Invariant (for some J in P .. Max => Str (J) /= ' '); - pragma Loop_Invariant - (for all J in Ptr.all .. P - 1 => Str (J) = ' '); - if P > Max then Ptr.all := P; Bad_Value (Str); @@ -320,8 +270,6 @@ is Start := P; - pragma Assert (Start = Sp.First_Non_Space_Ghost (Str, Ptr.all, Max)); - -- Remember an initial minus sign if Str (P) = '-' then @@ -361,8 +309,6 @@ is if Str (J) /= ' ' then Bad_Value (Str); end if; - - pragma Loop_Invariant (for all K in P .. J => Str (K) = ' '); end loop; end Scan_Trailing_Blanks; @@ -378,7 +324,6 @@ is Ext : Boolean) is C : Character; - begin P := P + 1; diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads index 8720c41..4a299ca 100644 --- a/gcc/ada/libgnat/s-valuti.ads +++ b/gcc/ada/libgnat/s-valuti.ads @@ -31,59 +31,16 @@ -- This package provides some common utilities used by the s-valxxx files --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - -with System.Case_Util; -with System.Val_Spec; - package System.Val_Util with SPARK_Mode, Pure is - pragma Unevaluated_Use_Of_Old (Allow); - - package Sp renames System.Val_Spec; - - procedure Bad_Value (S : String) - with - Always_Terminates, - Depends => (null => S), - Exceptional_Cases => (others => Standard.False); - pragma No_Return (Bad_Value); + procedure Bad_Value (S : String) with No_Return; -- Raises constraint error with message: bad input for 'Value: "xxx" procedure Normalize_String (S : in out String; F, L : out Integer; - To_Upper_Case : Boolean) - with - Post => (if Sp.Only_Space_Ghost (S'Old, S'First, S'Last) then - F > L - else - F >= S'First - and then L <= S'Last - and then F <= L - and then Sp.Only_Space_Ghost (S'Old, S'First, F - 1) - and then S'Old (F) /= ' ' - and then S'Old (L) /= ' ' - and then - (if L < S'Last then - Sp.Only_Space_Ghost (S'Old, L + 1, S'Last)) - and then - (if To_Upper_Case and then S'Old (F) /= ''' then - (for all J in S'Range => - (if J in F .. L then - S (J) = System.Case_Util.To_Upper (S'Old (J)) - else - S (J) = S'Old (J))))); + To_Upper_Case : Boolean); -- This procedure scans the string S setting F to be the index of the first -- non-blank character of S and L to be the index of the last non-blank -- character of S. If To_Upper_Case is True and S does not represent a @@ -96,27 +53,7 @@ is Ptr : not null access Integer; Max : Integer; Minus : out Boolean; - Start : out Positive) - with - Pre => - -- Ptr.all .. Max is either an empty range, or a valid range in Str - (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then not Sp.Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all, Max); - begin - (if Str (F) in '+' | '-' then - F <= Max - 1 and then Str (F + 1) /= ' ')), - Post => - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all'Old, Max); - begin - Minus = (Str (F) = '-') - and then Ptr.all = (if Str (F) in '+' | '-' then F + 1 else F) - and then Start = F); + Start : out Positive); -- The Str, Ptr, Max parameters are as for the scan routines (Str is the -- string to be scanned starting at Ptr.all, and Max is the index of the -- last character in the string). Scan_Sign first scans out any initial @@ -140,26 +77,7 @@ is (Str : String; Ptr : not null access Integer; Max : Integer; - Start : out Positive) - with - Pre => - -- Ptr.all .. Max is either an empty range, or a valid range in Str - (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then not Sp.Only_Space_Ghost (Str, Ptr.all, Max) - and then - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all, Max); - begin - (if Str (F) = '+' then - F <= Max - 1 and then Str (F + 1) /= ' ')), - Post => - (declare - F : constant Positive := - Sp.First_Non_Space_Ghost (Str, Ptr.all'Old, Max); - begin - Ptr.all = (if Str (F) = '+' then F + 1 else F) - and then Start = F); + Start : out Positive); -- Same as Scan_Sign, but allows only plus, not minus. This is used for -- modular types. @@ -168,22 +86,7 @@ is Ptr : not null access Integer; Max : Integer; Exp : out Integer; - Real : Boolean := False) - with - Pre => - -- Ptr.all .. Max is either an empty range, or a valid range in Str - (Ptr.all > Max or else (Ptr.all >= Str'First and then Max <= Str'Last)) - and then Max < Natural'Last - and then Sp.Is_Opt_Exponent_Format_Ghost (Str (Ptr.all .. Max), Real), - Post => - (if Sp.Starts_As_Exponent_Format_Ghost (Str (Ptr.all'Old .. Max), Real) - then Exp = Sp.Scan_Exponent_Ghost (Str (Ptr.all'Old .. Max), Real) - and then - (if Str (Ptr.all'Old + 1) in '-' | '+' then - Ptr.all = Sp.Last_Number_Ghost (Str (Ptr.all'Old + 2 .. Max)) + 1 - else - Ptr.all = Sp.Last_Number_Ghost (Str (Ptr.all'Old + 1 .. Max)) + 1) - else Exp = 0 and Ptr.all = Ptr.all'Old); + Real : Boolean := False); -- Called to scan a possible exponent. Str, Ptr, Max are as described above -- for Scan_Sign. If Ptr.all < Max and Str (Ptr.all) = 'E' or 'e', then an -- exponent is scanned out, with the exponent value returned in Exp, and @@ -198,35 +101,16 @@ is -- This routine must not be called with Str'Last = Positive'Last. There is -- no check for this case, the caller must ensure this condition is met. - procedure Scan_Trailing_Blanks (Str : String; P : Positive) - with - Pre => P >= Str'First - and then Sp.Only_Space_Ghost (Str, P, Str'Last); + procedure Scan_Trailing_Blanks (Str : String; P : Positive); -- Checks that the remainder of the field Str (P .. Str'Last) is all -- blanks. Raises Constraint_Error if a non-blank character is found. - pragma Warnings - (GNATprove, Off, """Ptr"" is not modified", - Reason => "Ptr is actually modified when raising an exception"); procedure Scan_Underscore (Str : String; P : in out Natural; Ptr : not null access Integer; Max : Integer; - Ext : Boolean) - with - Pre => P in Str'Range - and then Str (P) = '_' - and then Max in Str'Range - and then P < Max - and then - (if Ext then - Str (P + 1) in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' - else - Str (P + 1) in '0' .. '9'), - Post => - P = P'Old + 1 - and then Ptr.all'Old = Ptr.all; + Ext : Boolean); -- Called if an underscore is encountered while scanning digits. Str (P) -- contains the underscore. Ptr is the pointer to be returned to the -- ultimate caller of the scan routine, Max is the maximum subscript in @@ -237,6 +121,5 @@ is -- -- This routine must not be called with Str'Last = Positive'Last. There is -- no check for this case, the caller must ensure this condition is met. - pragma Warnings (GNATprove, On, """Ptr"" is not modified"); end System.Val_Util; diff --git a/gcc/ada/libgnat/s-vauspe.adb b/gcc/ada/libgnat/s-vauspe.adb deleted file mode 100644 index a350a56..0000000 --- a/gcc/ada/libgnat/s-vauspe.adb +++ /dev/null @@ -1,203 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ U _ S P E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2022-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -package body System.Value_U_Spec with SPARK_Mode is - - ----------------------------- - -- Exponent_Unsigned_Ghost -- - ----------------------------- - - function Exponent_Unsigned_Ghost - (Value : Uns; - Exp : Natural; - Base : Uns := 10) return Uns_Option - is - (if Exp = 0 or Value = 0 then (Overflow => False, Value => Value) - elsif Scan_Overflows_Ghost (0, Base, Value) then (Overflow => True) - else Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); - - --------------------- - -- Last_Hexa_Ghost -- - --------------------- - - function Last_Hexa_Ghost (Str : String) return Positive is - begin - pragma Annotate (Gnatcheck, Exempt_On, "Improper_Returns", - "occurs in ghost code, not executable"); - - for J in Str'Range loop - if Str (J) not in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' then - return J - 1; - end if; - - pragma Loop_Invariant - (for all K in Str'First .. J => - Str (K) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_'); - end loop; - - return Str'Last; - - pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns"); - end Last_Hexa_Ghost; - - ----------------------------- - -- Lemmas with null bodies -- - ----------------------------- - - procedure Lemma_Scan_Based_Number_Ghost_Base - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Scan_Based_Number_Ghost_Underscore - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Scan_Based_Number_Ghost_Overflow - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Scan_Based_Number_Ghost_Step - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is null; - - procedure Lemma_Exponent_Unsigned_Ghost_Base - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - is null; - - procedure Lemma_Exponent_Unsigned_Ghost_Overflow - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - is null; - - procedure Lemma_Exponent_Unsigned_Ghost_Step - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - is null; - - -------------------------------------- - -- Prove_Scan_Based_Number_Ghost_Eq -- - -------------------------------------- - - procedure Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - is - begin - if From > To then - null; - elsif Str1 (From) = '_' then - Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2, From + 1, To, Base, Acc); - elsif Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str1 (From)), Base, Acc) - then - null; - else - Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str1 (From))); - end if; - end Prove_Scan_Based_Number_Ghost_Eq; - - ----------------------------------- - -- Prove_Scan_Only_Decimal_Ghost -- - ----------------------------------- - - procedure Prove_Scan_Only_Decimal_Ghost - (Str : String; - Val : Uns) - is - pragma Assert (Str (Str'First + 1) /= ' '); - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - pragma Assert (Non_Blank = Str'First + 1); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - pragma Assert (Fst_Num = Str'First + 1); - begin - pragma Assert - (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); - pragma Assert - (Scan_Split_No_Overflow_Ghost (Str, Str'First + 1, Str'Last)); - pragma Assert - ((Val, 10, 0) = Scan_Split_Value_Ghost (Str, Str'First + 1, Str'Last)); - pragma Assert - (Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); - pragma Assert (Val = Exponent_Unsigned_Ghost (Val, 0, 10).Value); - pragma Assert (Is_Unsigned_Ghost (Str)); - pragma Assert (Is_Value_Unsigned_Ghost (Str, Val)); - end Prove_Scan_Only_Decimal_Ghost; - - ----------------------------- - -- Scan_Based_Number_Ghost -- - ----------------------------- - - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) return Uns_Option - is - (if From > To then (Overflow => False, Value => Acc) - elsif Str (From) = '_' - then Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc) - elsif Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) - then (Overflow => True) - else Scan_Based_Number_Ghost - (Str, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); - -end System.Value_U_Spec; diff --git a/gcc/ada/libgnat/s-vauspe.ads b/gcc/ada/libgnat/s-vauspe.ads deleted file mode 100644 index 5dbb57d..0000000 --- a/gcc/ada/libgnat/s-vauspe.ads +++ /dev/null @@ -1,629 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L U E _ U _ S P E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2022-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of a set of Ghost code packages used to proof the --- implementations of the Image and Value attributes. It provides the --- specification entities using for the formal verification of the routines --- for scanning modular unsigned integer values. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Val_Spec; use System.Val_Spec; - -generic - - type Uns is mod <>; - -package System.Value_U_Spec with - Ghost, - SPARK_Mode, - Always_Terminates -is - pragma Preelaborate; - - -- Maximum value of exponent for 10 that fits in Uns'Base - function Max_Log10 return Natural is - (case Uns'Base'Size is - when 8 => 2, - when 16 => 4, - when 32 => 9, - when 64 => 19, - when 128 => 38, - when others => raise Program_Error) - with Ghost; - - pragma Annotate (Gnatcheck, Exempt_On, "Discriminated_Records", - "variant record only used in proof code"); - type Uns_Option (Overflow : Boolean := False) is record - case Overflow is - when True => - null; - when False => - Value : Uns := 0; - end case; - end record; - pragma Annotate (Gnatcheck, Exempt_Off, "Discriminated_Records"); - - function Wrap_Option (Value : Uns) return Uns_Option is - (Overflow => False, Value => Value); - - function Only_Decimal_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (for all J in From .. To => Str (J) in '0' .. '9') - with - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only decimal characters - -- from index From to index To. - - function Only_Hexa_Ghost (Str : String; From, To : Integer) return Boolean - is - (for all J in From .. To => - Str (J) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') - with - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only hexadecimal characters - -- from index From to index To. - - function Last_Hexa_Ghost (Str : String) return Positive - with - Pre => Str /= "" - and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F', - Post => Last_Hexa_Ghost'Result in Str'Range - and then (if Last_Hexa_Ghost'Result < Str'Last then - Str (Last_Hexa_Ghost'Result + 1) not in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') - and then Only_Hexa_Ghost (Str, Str'First, Last_Hexa_Ghost'Result); - -- Ghost function that returns the index of the last character in S that - -- is either an hexadecimal digit or an underscore, which necessarily - -- exists given the precondition on Str. - - function Is_Based_Format_Ghost (Str : String) return Boolean - is - (Str /= "" - and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then - (declare - L : constant Positive := Last_Hexa_Ghost (Str); - begin - Str (L) /= '_' - and then (for all J in Str'First .. L => - (if Str (J) = '_' then Str (J + 1) /= '_')))); - -- Ghost function that determines if Str has the correct format for a - -- based number, consisting in a sequence of hexadecimal digits possibly - -- separated by single underscores. It may be followed by other characters. - - function Hexa_To_Unsigned_Ghost (X : Character) return Uns is - (case X is - when '0' .. '9' => Character'Pos (X) - Character'Pos ('0'), - when 'a' .. 'f' => Character'Pos (X) - Character'Pos ('a') + 10, - when 'A' .. 'F' => Character'Pos (X) - Character'Pos ('A') + 10, - when others => raise Program_Error) - with - Pre => X in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - -- Ghost function that computes the value corresponding to an hexadecimal - -- digit. - - function Scan_Overflows_Ghost - (Digit : Uns; - Base : Uns; - Acc : Uns) return Boolean - is - (Digit >= Base - or else Acc > Uns'Last / Base - or else Uns'Last - Digit < Base * Acc); - -- Ghost function which returns True if Digit + Base * Acc overflows or - -- Digit is greater than Base, as this is used by the algorithm for the - -- test of overflow. - - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) return Uns_Option - with - Subprogram_Variant => (Increases => From), - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To); - -- Ghost function that recursively computes the based number in Str, - -- assuming Acc has been scanned already and scanning continues at index - -- From. - - -- Lemmas unfolding the recursive definition of Scan_Based_Number_Ghost - - procedure Lemma_Scan_Based_Number_Ghost_Base - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From > To - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - (Overflow => False, Value => Acc)); - -- Base case: Scan_Based_Number_Ghost returns Acc if From is bigger than To - - procedure Lemma_Scan_Based_Number_Ghost_Underscore - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From <= To and then Str (From) = '_' - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc)); - -- Underscore case: underscores are ignored while scanning - - procedure Lemma_Scan_Based_Number_Ghost_Overflow - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From <= To - and then Str (From) /= '_' - and then Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - (Overflow => True)); - -- Overflow case: scanning a digit which causes an overflow - - procedure Lemma_Scan_Based_Number_Ghost_Step - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Global => null, - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To), - Post => - (if From <= To - and then Str (From) /= '_' - and then not Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) - then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - Scan_Based_Number_Ghost - (Str, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); - -- Normal case: scanning a digit without overflows - - function Exponent_Unsigned_Ghost - (Value : Uns; - Exp : Natural; - Base : Uns := 10) return Uns_Option - with - Subprogram_Variant => (Decreases => Exp); - -- Ghost function that recursively computes Value * Base ** Exp - - -- Lemmas unfolding the recursive definition of Exponent_Unsigned_Ghost - - procedure Lemma_Exponent_Unsigned_Ghost_Base - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - with - Post => - (if Exp = 0 or Value = 0 - then Exponent_Unsigned_Ghost (Value, Exp, Base) = - (Overflow => False, Value => Value)); - -- Base case: Exponent_Unsigned_Ghost returns 0 if Value or Exp is 0 - - procedure Lemma_Exponent_Unsigned_Ghost_Overflow - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - with - Post => - (if Exp /= 0 - and then Value /= 0 - and then Scan_Overflows_Ghost (0, Base, Value) - then Exponent_Unsigned_Ghost (Value, Exp, Base) = (Overflow => True)); - -- Overflow case: the next multiplication overflows - - procedure Lemma_Exponent_Unsigned_Ghost_Step - (Value : Uns; - Exp : Natural; - Base : Uns := 10) - with - Post => - (if Exp /= 0 - and then Value /= 0 - and then not Scan_Overflows_Ghost (0, Base, Value) - then Exponent_Unsigned_Ghost (Value, Exp, Base) = - Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); - -- Normal case: exponentiation without overflows - - function Raw_Unsigned_Starts_As_Based_Ghost - (Str : String; - Last_Num_Init, To : Integer) - return Boolean - is - (Last_Num_Init < To - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F') - with Ghost, - Pre => Last_Num_Init in Str'Range - and then To in Str'Range; - -- Return True if Str starts as a based number - - function Raw_Unsigned_Is_Based_Ghost - (Str : String; - Last_Num_Init : Integer; - Last_Num_Based : Integer; - To : Integer) - return Boolean - is - (Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To) - and then Last_Num_Based < To - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1)) - with Ghost, - Pre => Last_Num_Init in Str'Range - and then Last_Num_Based in Last_Num_Init .. Str'Last - and then To in Str'Range; - -- Return True if Str is a based number - - function Is_Raw_Unsigned_Format_Ghost (Str : String) return Boolean is - (Is_Natural_Format_Ghost (Str) - and then - (declare - Last_Num_Init : constant Integer := Last_Number_Ghost (Str); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, Str'Last); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) - else Last_Num_Init); - Is_Based : constant Boolean := - Raw_Unsigned_Is_Based_Ghost - (Str, Last_Num_Init, Last_Num_Based, Str'Last); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - begin - (if Starts_As_Based then - Is_Based_Format_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) - and then Last_Num_Based < Str'Last) - and then Is_Opt_Exponent_Format_Ghost - (Str (First_Exp .. Str'Last)))) - with - Pre => Str'Last /= Positive'Last; - -- Ghost function that determines if Str has the correct format for an - -- unsigned number without a sign character. - -- It is a natural number in base 10, optionally followed by a based - -- number surrounded by delimiters # or :, optionally followed by an - -- exponent part. - - type Split_Value_Ghost is record - Value : Uns; - Base : Uns; - Expon : Natural; - end record; - - function Scan_Split_No_Overflow_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, From, Last_Num_Init); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Based_Val : constant Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val); - begin - not Init_Val.Overflow - and then - (Last_Num_Init >= To - 1 - or else Str (Last_Num_Init + 1) not in '#' | ':' - or else Init_Val.Value in 2 .. 16) - and then - (not Starts_As_Based - or else not Based_Val.Overflow)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9'; - -- Ghost function that determines if an overflow might occur while scanning - -- the representation of an unsigned number. The computation overflows if - -- either: - -- * The computation of the decimal part overflows, - -- * The decimal part is followed by a valid delimiter for a based - -- part, and the number corresponding to the base is not a valid base, - -- or - -- * The computation of the based part overflows. - - pragma Warnings (Off, "constant * is not referenced"); - function Scan_Split_Value_Ghost - (Str : String; - From, To : Integer) - return Split_Value_Ghost - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, From, Last_Num_Init); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Raw_Unsigned_Is_Based_Ghost (Str, Last_Num_Init, Last_Num_Based, To); - Based_Val : constant Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - Expon : constant Natural := - (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then Scan_Exponent_Ghost (Str (First_Exp .. To)) - else 0); - Base : constant Uns := - (if Is_Based then Init_Val.Value else 10); - Value : constant Uns := - (if Is_Based then Based_Val.Value else Init_Val.Value); - begin - (Value => Value, Base => Base, Expon => Expon)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' - and then Scan_Split_No_Overflow_Ghost (Str, From, To); - -- Ghost function that scans an unsigned number without a sign character - -- and return a record containing the values scanned for its value, its - -- base, and its exponent. - pragma Warnings (On, "constant * is not referenced"); - - function Raw_Unsigned_No_Overflow_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (Scan_Split_No_Overflow_Ghost (Str, From, To) - and then - (declare - Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost - (Str, From, To); - begin - not Exponent_Unsigned_Ghost - (Val.Value, Val.Expon, Val.Base).Overflow)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9'; - -- Ghost function that determines if the computation of the unsigned number - -- represented by Str will overflow. The computation overflows if either: - -- * The scan of the string overflows, or - -- * The computation of the exponentiation overflows. - - function Scan_Raw_Unsigned_Ghost - (Str : String; - From, To : Integer) - return Uns - is - (declare - Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost - (Str, From, To); - begin - Exponent_Unsigned_Ghost (Val.Value, Val.Expon, Val.Base).Value) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' - and then Raw_Unsigned_No_Overflow_Ghost (Str, From, To); - -- Ghost function that scans an unsigned number without a sign character - - function Raw_Unsigned_Last_Ghost - (Str : String; - From, To : Integer) - return Positive - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Starts_As_Based : constant Boolean := - Raw_Unsigned_Starts_As_Based_Ghost (Str, Last_Num_Init, To); - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Raw_Unsigned_Is_Based_Ghost (Str, Last_Num_Init, Last_Num_Based, To); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - begin - (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then First_Exp - elsif Str (First_Exp + 1) in '-' | '+' then - Last_Number_Ghost (Str (First_Exp + 2 .. To)) + 1 - else Last_Number_Ghost (Str (First_Exp + 1 .. To)) + 1)) - with - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9', - Post => Raw_Unsigned_Last_Ghost'Result >= From; - -- Ghost function that returns the position of the cursor once an unsigned - -- number has been seen. - - function Slide_To_1 (Str : String) return String - with - Post => - Only_Space_Ghost (Str, Str'First, Str'Last) = - (for all J in Str'First .. Str'Last => - Slide_To_1'Result (J - Str'First + 1) = ' '); - -- Slides Str so that it starts at 1 - - function Slide_If_Necessary (Str : String) return String is - (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str); - -- If Str'Last = Positive'Last then slides Str so that it starts at 1 - - function Is_Unsigned_Ghost (Str : String) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) - and then Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last) - and then Only_Space_Ghost - (Str, Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last), Str'Last)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last; - -- Ghost function that determines if Str has the correct format for an - -- unsigned number, consisting in some blank characters, an optional - -- + sign, a raw unsigned number which does not overflow and then some - -- more blank characters. - - function Is_Value_Unsigned_Ghost (Str : String; Val : Uns) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Val = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)) - with - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last - and then Is_Unsigned_Ghost (Str); - -- Ghost function that returns True if Val is the value corresponding to - -- the unsigned number represented by Str. - - procedure Prove_Scan_Based_Number_Ghost_Eq - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) - with - Subprogram_Variant => (Increases => From), - Pre => Str1'Last /= Positive'Last - and then Str2'Last /= Positive'Last - and then - (From > To or else (From >= Str1'First and then To <= Str1'Last)) - and then - (From > To or else (From >= Str2'First and then To <= Str2'Last)) - and then Only_Hexa_Ghost (Str1, From, To) - and then (for all J in From .. To => Str1 (J) = Str2 (J)), - Post => - Scan_Based_Number_Ghost (Str1, From, To, Base, Acc) - = Scan_Based_Number_Ghost (Str2, From, To, Base, Acc); - -- Scan_Based_Number_Ghost returns the same value on two slices which are - -- equal. - - procedure Prove_Scan_Only_Decimal_Ghost - (Str : String; - Val : Uns) - with - Pre => Str'Last /= Positive'Last - and then Str'Length >= 2 - and then Str (Str'First) = ' ' - and then Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) - and then Scan_Based_Number_Ghost (Str, Str'First + 1, Str'Last) - = Wrap_Option (Val), - Post => Is_Unsigned_Ghost (Slide_If_Necessary (Str)) - and then - Is_Value_Unsigned_Ghost (Slide_If_Necessary (Str), Val); - -- Ghost lemma used in the proof of 'Image implementation, to prove that - -- the result of Value_Unsigned on a decimal string is the same as the - -- result of Scan_Based_Number_Ghost. - - -- Bundle Uns type with other types, constants and subprograms used in - -- ghost code, so that this package can be instantiated once and used - -- multiple times as generic formal for a given Int type. - -private - - ---------------- - -- Slide_To_1 -- - ---------------- - - function Slide_To_1 (Str : String) return String is - (declare - Res : constant String (1 .. Str'Length) := Str; - begin - Res); - -end System.Value_U_Spec; diff --git a/gcc/ada/libgnat/s-veboop.adb b/gcc/ada/libgnat/s-veboop.adb index fb92f1c..edff485 100644 --- a/gcc/ada/libgnat/s-veboop.adb +++ b/gcc/ada/libgnat/s-veboop.adb @@ -29,14 +29,6 @@ -- -- ------------------------------------------------------------------------------ --- Ghost code, loop invariants and assertions in this unit are meant for --- analysis only, not for run-time checking, as it would be too costly --- otherwise. This is enforced by setting the assertion policy to Ignore. - -pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - package body System.Vectors.Boolean_Operations with SPARK_Mode is @@ -86,26 +78,7 @@ is ----------- function "not" (Item : Vectors.Vector) return Vectors.Vector is - - procedure Prove_Not (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Item) - and then Result = (Item xor True_Val), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = not Model (Item) (J)); - - procedure Prove_Not (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = 1 - Element (Item, J)); - end loop; - end Prove_Not; - begin - Prove_Not (Item xor True_Val); return Item xor True_Val; end "not"; @@ -119,32 +92,7 @@ is end Nand; function Nand (Left, Right : Vectors.Vector) return Vectors.Vector is - - procedure Prove_And (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Left) - and then Valid (Right) - and then Result = (Left and Right), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = - (Model (Left) (J) and Model (Right) (J))); - - procedure Prove_And (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = - (if Element (Left, J) = 1 - and Element (Right, J) = 1 - then 1 - else 0)); - end loop; - end Prove_And; - begin - Prove_And (Left and Right); return not (Left and Right); end Nand; @@ -158,32 +106,7 @@ is end Nor; function Nor (Left, Right : Vectors.Vector) return Vectors.Vector is - - procedure Prove_Or (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Left) - and then Valid (Right) - and then Result = (Left or Right), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = - (Model (Left) (J) or Model (Right) (J))); - - procedure Prove_Or (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = - (if Element (Left, J) = 1 - or Element (Right, J) = 1 - then 1 - else 0)); - end loop; - end Prove_Or; - begin - Prove_Or (Left or Right); return not (Left or Right); end Nor; @@ -197,32 +120,7 @@ is end Nxor; function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector is - - procedure Prove_Xor (Result : Vectors.Vector) - with - Ghost, - Pre => Valid (Left) - and then Valid (Right) - and then Result = (Left xor Right), - Post => Valid (Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Result) (J) = - (Model (Left) (J) xor Model (Right) (J))); - - procedure Prove_Xor (Result : Vectors.Vector) is - begin - for J in 1 .. Vector_Boolean_Size loop - pragma Assert - (Element (Result, J) = - (if Element (Left, J) = 1 - xor Element (Right, J) = 1 - then 1 - else 0)); - end loop; - end Prove_Xor; - begin - Prove_Xor (Left xor Right); return not (Left xor Right); end Nxor; diff --git a/gcc/ada/libgnat/s-veboop.ads b/gcc/ada/libgnat/s-veboop.ads index 6283d19..0b4f894 100644 --- a/gcc/ada/libgnat/s-veboop.ads +++ b/gcc/ada/libgnat/s-veboop.ads @@ -31,116 +31,21 @@ -- This package contains functions for runtime operations on boolean vectors --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - package System.Vectors.Boolean_Operations with Pure, SPARK_Mode is - pragma Warnings (Off, "aspect ""Pre"" not enforced on inlined subprogram", - Reason => "Pre only used in proof"); - pragma Warnings (Off, "aspect ""Post"" not enforced on inlined subprogram", - Reason => "Post only used in proof"); - -- Type Vectors.Vector represents an array of Boolean, each of which - -- takes 8 bits of the representation, with the 7 msb set to zero. Express - -- in contracts the constraint on valid vectors and the model that they - -- represent, and the relationship between input models and output model. - - Vector_Boolean_Size : constant Positive := - System.Word_Size / System.Storage_Unit - with Ghost; - - type Vector_Element is mod 2 ** System.Storage_Unit with Ghost; - - type Vector_Boolean_Array is array (1 .. Vector_Boolean_Size) of Boolean - with Ghost; - - function Shift_Right (V : Vectors.Vector; N : Natural) return Vectors.Vector - with Ghost, Import, Convention => Intrinsic; - - function Element (V : Vectors.Vector; N : Positive) return Vector_Element is - (Vector_Element (Shift_Right (V, (N - 1) * System.Storage_Unit) - and (2 ** System.Storage_Unit - 1))) - with - Ghost, - Pre => N <= Vector_Boolean_Size; - -- Return the Nth element represented by the vector - - function Valid (V : Vectors.Vector) return Boolean is - (for all J in 1 .. Vector_Boolean_Size => - Element (V, J) in 0 .. 1) - with Ghost; - -- A valid vector is one for which all elements are 0 (representing False) - -- or 1 (representing True). - - function Model (V : Vectors.Vector) return Vector_Boolean_Array - with - Ghost, - Pre => Valid (V); - - function Model (V : Vectors.Vector) return Vector_Boolean_Array is - (for J in 1 .. Vector_Boolean_Size => Element (V, J) = 1); - -- The model of a valid vector is the corresponding array of Boolean values - - -- Although in general the boolean operations on arrays of booleans are - -- identical to operations on arrays of unsigned words of the same size, - -- for the "not" operator this is not the case as False is typically - -- represented by 0 and true by 1. - - function "not" (Item : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Item), - Post => Valid ("not"'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model ("not"'Result) (J) = not Model (Item) (J)); - - function Nand (Left, Right : Boolean) return Boolean - with - Post => Nand'Result = not (Left and Right); - - function Nor (Left, Right : Boolean) return Boolean - with - Post => Nor'Result = not (Left or Right); - - function Nxor (Left, Right : Boolean) return Boolean - with - Post => Nxor'Result = not (Left xor Right); + -- takes 8 bits of the representation, with the 7 msb set to zero. - function Nand (Left, Right : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Left) - and then Valid (Right), - Post => Valid (Nand'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Nand'Result) (J) = - Nand (Model (Left) (J), Model (Right) (J))); + function "not" (Item : Vectors.Vector) return Vectors.Vector; - function Nor (Left, Right : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Left) - and then Valid (Right), - Post => Valid (Nor'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Nor'Result) (J) = - Nor (Model (Left) (J), Model (Right) (J))); + function Nand (Left, Right : Boolean) return Boolean; + function Nor (Left, Right : Boolean) return Boolean; + function Nxor (Left, Right : Boolean) return Boolean; - function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector - with - Pre => Valid (Left) - and then Valid (Right), - Post => Valid (Nxor'Result) - and then (for all J in 1 .. Vector_Boolean_Size => - Model (Nxor'Result) (J) = - Nxor (Model (Left) (J), Model (Right) (J))); + function Nand (Left, Right : Vectors.Vector) return Vectors.Vector; + function Nor (Left, Right : Vectors.Vector) return Vectors.Vector; + function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector; -- The three boolean operations "nand", "nor" and "nxor" are needed -- for cases where the compiler moves boolean array operations into -- the body of the loop that iterates over the array elements. diff --git a/gcc/ada/libgnat/s-vs_int.ads b/gcc/ada/libgnat/s-vs_int.ads deleted file mode 100644 index a4cc0dc..0000000 --- a/gcc/ada/libgnat/s-vs_int.ads +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ I N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning signed Integer --- values for use in ``Text_IO.Integer_IO``, and the Value attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_I_Spec; -with System.Vs_Uns; - -package System.Vs_Int with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Unsigned is Unsigned_Types.Unsigned; - - package Spec is new System.Value_I_Spec - (Integer, Unsigned, System.Vs_Uns.Spec); - -end System.Vs_Int; diff --git a/gcc/ada/libgnat/s-vs_lli.ads b/gcc/ada/libgnat/s-vs_lli.ads deleted file mode 100644 index 3a4a010..0000000 --- a/gcc/ada/libgnat/s-vs_lli.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L I -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- Long_Long_Integer values for use in ``Text_IO.Integer_IO``, and the Value --- attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_I_Spec; -with System.Vs_LLU; - -package System.Vs_LLI with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - - package Spec is new System.Value_I_Spec - (Long_Long_Integer, Long_Long_Unsigned, System.Vs_LLU.Spec); - -end System.Vs_LLI; diff --git a/gcc/ada/libgnat/s-vs_llu.ads b/gcc/ada/libgnat/s-vs_llu.ads deleted file mode 100644 index e1c0fec..0000000 --- a/gcc/ada/libgnat/s-vs_llu.ads +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L U -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- Long_Long_Unsigned values for use in ``Text_IO.Modular_IO``, and the Value --- attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_U_Spec; - -package System.Vs_LLU with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - - package Spec is new System.Value_U_Spec (Long_Long_Unsigned); - -end System.Vs_LLU; diff --git a/gcc/ada/libgnat/s-vs_uns.ads b/gcc/ada/libgnat/s-vs_uns.ads deleted file mode 100644 index 7e5aac3..0000000 --- a/gcc/ada/libgnat/s-vs_uns.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ U N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning modular Unsigned --- values for use in ``Text_IO.Modular_IO``, and the Value attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_U_Spec; - -package System.Vs_Uns with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Unsigned is Unsigned_Types.Unsigned; - - package Spec is new System.Value_U_Spec (Unsigned); - -end System.Vs_Uns; diff --git a/gcc/ada/libgnat/s-vsllli.ads b/gcc/ada/libgnat/s-vsllli.ads deleted file mode 100644 index 5648060..0000000 --- a/gcc/ada/libgnat/s-vsllli.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L L I -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- ``Long_Long_Long_Integer`` values for use in ``Text_IO.Integer_IO``, and --- the Value attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_I_Spec; -with System.Vs_LLLU; - -package System.Vs_LLLI with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - - package Spec is new System.Value_I_Spec - (Long_Long_Long_Integer, Long_Long_Long_Unsigned, System.Vs_LLLU.Spec); - -end System.Vs_LLLI; diff --git a/gcc/ada/libgnat/s-vslllu.ads b/gcc/ada/libgnat/s-vslllu.ads deleted file mode 100644 index 7fe1235..0000000 --- a/gcc/ada/libgnat/s-vslllu.ads +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V S _ L L L U -- --- -- --- S p e c -- --- -- --- Copyright (C) 2023-2025, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specification functions for scanning --- Long_Long_Long_Unsigned values for use in Text_IO.Modular_IO, and the Value --- attribute. - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -with System.Unsigned_Types; -with System.Value_U_Spec; - -package System.Vs_LLLU with SPARK_Mode, Ghost is - pragma Preelaborate; - - subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - - package Spec is new System.Value_U_Spec (Long_Long_Long_Unsigned); - -end System.Vs_LLLU; diff --git a/gcc/ada/libgnat/s-widint.ads b/gcc/ada/libgnat/s-widint.ads index 22e342c..8af8d91 100644 --- a/gcc/ada/libgnat/s-widint.ads +++ b/gcc/ada/libgnat/s-widint.ads @@ -31,24 +31,11 @@ -- Width attribute for signed integers up to Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_I; package System.Wid_Int with SPARK_Mode is - function Width_Integer is new Width_I (Integer); pragma Pure_Function (Width_Integer); - end System.Wid_Int; diff --git a/gcc/ada/libgnat/s-widlli.ads b/gcc/ada/libgnat/s-widlli.ads index 3490b3f..a977096 100644 --- a/gcc/ada/libgnat/s-widlli.ads +++ b/gcc/ada/libgnat/s-widlli.ads @@ -31,24 +31,11 @@ -- Width attribute for signed integers larger than Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_I; package System.Wid_LLI with SPARK_Mode is - function Width_Long_Long_Integer is new Width_I (Long_Long_Integer); pragma Pure_Function (Width_Long_Long_Integer); - end System.Wid_LLI; diff --git a/gcc/ada/libgnat/s-widllli.ads b/gcc/ada/libgnat/s-widllli.ads index ee8f7af..325e80f 100644 --- a/gcc/ada/libgnat/s-widllli.ads +++ b/gcc/ada/libgnat/s-widllli.ads @@ -31,25 +31,12 @@ -- Width attribute for signed integers larger than Long_Long_Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_I; package System.Wid_LLLI with SPARK_Mode is - function Width_Long_Long_Long_Integer is new Width_I (Long_Long_Long_Integer); pragma Pure_Function (Width_Long_Long_Long_Integer); - end System.Wid_LLLI; diff --git a/gcc/ada/libgnat/s-widlllu.ads b/gcc/ada/libgnat/s-widlllu.ads index db5b9d1..8a5c04f 100644 --- a/gcc/ada/libgnat/s-widlllu.ads +++ b/gcc/ada/libgnat/s-widlllu.ads @@ -31,17 +31,6 @@ -- Width attribute for modular integers larger than Long_Long_Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_U; with System.Unsigned_Types; diff --git a/gcc/ada/libgnat/s-widllu.ads b/gcc/ada/libgnat/s-widllu.ads index 0fd3135..f8c8284 100644 --- a/gcc/ada/libgnat/s-widllu.ads +++ b/gcc/ada/libgnat/s-widllu.ads @@ -31,17 +31,6 @@ -- Width attribute for modular integers larger than Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_U; with System.Unsigned_Types; diff --git a/gcc/ada/libgnat/s-widthi.adb b/gcc/ada/libgnat/s-widthi.adb index 9595790..c66d662 100644 --- a/gcc/ada/libgnat/s-widthi.adb +++ b/gcc/ada/libgnat/s-widthi.adb @@ -29,109 +29,9 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - function System.Width_I (Lo, Hi : Int) return Natural is - - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - package Signed_Conversion is new Signed_Conversions (Int => Int); - - function Big (Arg : Int) return Big_Integer renames - Signed_Conversion.To_Big_Integer; - - -- Maximum value of exponent for 10 that fits in Uns'Base - function Max_Log10 return Natural is - (case Int'Base'Size is - when 8 => 2, - when 16 => 4, - when 32 => 9, - when 64 => 19, - when 128 => 38, - when others => raise Program_Error) - with Ghost; - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) - with - Ghost, - Pre => A <= B, - Post => A * C <= B * C; - - procedure Lemma_Div_Commutation (X, Y : Int) - with - Ghost, - Pre => X >= 0 and Y > 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - ---------------------- - -- Lemma_Lower_Mult -- - ---------------------- - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) is null; - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Div_Commutation (X, Y : Int) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - - -- Local variables - W : Natural; T : Int; - - -- Local ghost variables - - Max_W : constant Natural := Max_Log10 with Ghost; - Big_10 : constant Big_Integer := Big (10) with Ghost; - - Pow : Big_Integer := 1 with Ghost; - T_Init : constant Int := - Int'Max (abs Int'Max (Lo, Int'First + 1), - abs Int'Max (Hi, Int'First + 1)) - with Ghost; - --- Start of processing for System.Width_I - begin if Lo > Hi then return 0; @@ -151,41 +51,10 @@ begin -- Increase value if more digits required while T >= 10 loop - Lemma_Div_Commutation (T, 10); - Lemma_Div_Twice (Big (T_Init), Big_10 ** (W - 2), Big_10); - T := T / 10; W := W + 1; - Pow := Pow * 10; - - pragma Loop_Invariant (T >= 0); - pragma Loop_Invariant (W in 3 .. Max_W + 3); - pragma Loop_Invariant (Pow = Big_10 ** (W - 2)); - pragma Loop_Invariant (Big (T) = Big (T_Init) / Pow); - pragma Loop_Variant (Decreases => T); end loop; - declare - F : constant Big_Positive := Big_10 ** (W - 2) with Ghost; - Q : constant Big_Natural := Big (T_Init) / F with Ghost; - R : constant Big_Natural := Big (T_Init) rem F with Ghost; - begin - pragma Assert (Q < Big_10); - pragma Assert (Big (T_Init) = Q * F + R); - Lemma_Lower_Mult (Q, Big (9), F); - pragma Assert (Big (T_Init) <= Big (9) * F + F - 1); - pragma Assert (Big (T_Init) < Big_10 * F); - pragma Assert (Big_10 * F = Big_10 ** (W - 1)); - end; - - -- This is an expression of the functional postcondition for Width_I, - -- which cannot be expressed readily as a postcondition as this would - -- require making the instantiation Signed_Conversion and function Big - -- available from the spec. - - pragma Assert (Big (Int'Max (Lo, Int'First + 1)) < Big_10 ** (W - 1)); - pragma Assert (Big (Int'Max (Hi, Int'First + 1)) < Big_10 ** (W - 1)); - return W; end if; diff --git a/gcc/ada/libgnat/s-widthu.adb b/gcc/ada/libgnat/s-widthu.adb index df27e50..fe51d61 100644 --- a/gcc/ada/libgnat/s-widthu.adb +++ b/gcc/ada/libgnat/s-widthu.adb @@ -31,110 +31,12 @@ package body System.Width_U is - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore, - Assert_And_Cut => Ignore, - Subprogram_Variant => Ignore); - function Width (Lo, Hi : Uns) return Natural is - - -- Ghost code, loop invariants and assertions in this unit are meant for - -- analysis only, not for run-time checking, as it would be too costly - -- otherwise. This is enforced by setting the assertion policy to - -- Ignore. - - pragma Assertion_Policy (Ghost => Ignore, - Loop_Invariant => Ignore, - Assert => Ignore); - - ------------------ - -- Local Lemmas -- - ------------------ - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) - with - Ghost, - Pre => A <= B, - Post => A * C <= B * C; - - procedure Lemma_Div_Commutation (X, Y : Uns) - with - Ghost, - Pre => Y /= 0, - Post => Big (X) / Big (Y) = Big (X / Y); - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) - with - Ghost, - Post => X / Y / Z = X / (Y * Z); - - procedure Lemma_Euclidian (V, Q, F, R : Big_Integer) - with - Ghost, - Pre => F > 0 and then Q = V / F and then R = V rem F, - Post => V = Q * F + R; - -- Ghost lemma to prove the relation between the quotient/remainder of - -- division by F and the value V. - - ---------------------- - -- Lemma_Lower_Mult -- - ---------------------- - - procedure Lemma_Lower_Mult (A, B, C : Big_Natural) is null; - - --------------------------- - -- Lemma_Div_Commutation -- - --------------------------- - - procedure Lemma_Div_Commutation (X, Y : Uns) is null; - - --------------------- - -- Lemma_Div_Twice -- - --------------------- - - procedure Lemma_Div_Twice (X : Big_Natural; Y, Z : Big_Positive) is - XY : constant Big_Natural := X / Y; - YZ : constant Big_Natural := Y * Z; - XYZ : constant Big_Natural := X / Y / Z; - R : constant Big_Natural := (XY rem Z) * Y + (X rem Y); - begin - pragma Assert (X = XY * Y + (X rem Y)); - pragma Assert (XY = XY / Z * Z + (XY rem Z)); - pragma Assert (X = XYZ * YZ + R); - pragma Assert ((XY rem Z) * Y <= (Z - 1) * Y); - pragma Assert (R <= YZ - 1); - pragma Assert (X / YZ = (XYZ * YZ + R) / YZ); - pragma Assert (X / YZ = XYZ + R / YZ); - end Lemma_Div_Twice; - - --------------------- - -- Lemma_Euclidian -- - --------------------- - - procedure Lemma_Euclidian (V, Q, F, R : Big_Integer) is null; - - -- Local variables - W : Natural; T : Uns; - - -- Local ghost variables - - Max_W : constant Natural := Max_Log10 with Ghost; - Pow : Big_Integer := 1 with Ghost; - T_Init : constant Uns := Uns'Max (Lo, Hi) with Ghost; - - -- Start of processing for System.Width_U - begin if Lo > Hi then return 0; - else -- Minimum value is 2, one for space, one for digit @@ -147,32 +49,10 @@ package body System.Width_U is -- Increase value if more digits required while T >= 10 loop - Lemma_Div_Commutation (T, 10); - Lemma_Div_Twice (Big (T_Init), Big_10 ** (W - 2), Big_10); - T := T / 10; W := W + 1; - Pow := Pow * 10; - - pragma Loop_Invariant (W in 3 .. Max_W + 2); - pragma Loop_Invariant (Pow = Big_10 ** (W - 2)); - pragma Loop_Invariant (Big (T) = Big (T_Init) / Pow); - pragma Loop_Variant (Decreases => T); end loop; - declare - F : constant Big_Integer := Big_10 ** (W - 2) with Ghost; - Q : constant Big_Integer := Big (T_Init) / F with Ghost; - R : constant Big_Integer := Big (T_Init) rem F with Ghost; - begin - pragma Assert (Q < Big_10); - Lemma_Euclidian (Big (T_Init), Q, F, R); - Lemma_Lower_Mult (Q, Big (9), F); - pragma Assert (Big (T_Init) <= Big (9) * F + F - 1); - pragma Assert (Big (T_Init) < Big_10 * F); - pragma Assert (Big_10 * F = Big_10 ** (W - 1)); - end; - return W; end if; end Width; diff --git a/gcc/ada/libgnat/s-widthu.ads b/gcc/ada/libgnat/s-widthu.ads index 56da0a2..076dace 100644 --- a/gcc/ada/libgnat/s-widthu.ads +++ b/gcc/ada/libgnat/s-widthu.ads @@ -29,65 +29,14 @@ -- -- ------------------------------------------------------------------------------ --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore, - Subprogram_Variant => Ignore); - -- Compute Width attribute for non-static type derived from a modular integer -- type. The arguments Lo, Hi are the bounds of the type. -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - generic - type Uns is mod <>; package System.Width_U with Pure is - package BI_Ghost renames Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - subtype Big_Integer is BI_Ghost.Big_Integer with Ghost; - subtype Big_Natural is BI_Ghost.Big_Natural with Ghost; - subtype Big_Positive is BI_Ghost.Big_Positive with Ghost; - use type BI_Ghost.Big_Integer; - - package Unsigned_Conversion is - new BI_Ghost.Unsigned_Conversions (Int => Uns); - - function Big (Arg : Uns) return Big_Integer renames - Unsigned_Conversion.To_Big_Integer; - - Big_10 : constant Big_Integer := Big (Uns'(10)) with Ghost; - - -- Maximum value of exponent for 10 that fits in Uns'Base - function Max_Log10 return Natural is - (case Uns'Base'Size is - when 8 => 2, - when 16 => 4, - when 32 => 9, - when 64 => 19, - when 128 => 38, - when others => raise Program_Error) - with Ghost; - - function Width (Lo, Hi : Uns) return Natural - with - Post => - (declare - W : constant Natural := System.Width_U.Width'Result; - begin - (if Lo > Hi then W = 0 - else W > 0 - and then W <= Max_Log10 + 2 - and then Big (Lo) < Big_10 ** (W - 1) - and then Big (Hi) < Big_10 ** (W - 1))); - + function Width (Lo, Hi : Uns) return Natural; end System.Width_U; diff --git a/gcc/ada/libgnat/s-widuns.ads b/gcc/ada/libgnat/s-widuns.ads index d81b862..6ac2928 100644 --- a/gcc/ada/libgnat/s-widuns.ads +++ b/gcc/ada/libgnat/s-widuns.ads @@ -31,17 +31,6 @@ -- Width attribute for modular integers up to Integer --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised. This is enforced by --- setting the corresponding assertion policy to Ignore. Postconditions and --- contract cases should not be executed at runtime as well, in order not to --- slow down the execution of these functions. - -pragma Assertion_Policy (Pre => Ignore, - Post => Ignore, - Contract_Cases => Ignore, - Ghost => Ignore); - with System.Width_U; with System.Unsigned_Types; |