a-nallfl$(objext) \
a-nalofl$(objext) \
a-nashfl$(objext) \
- a-nbnbig$(objext) \
a-nbnbin$(objext) \
a-nbnbre$(objext) \
a-ncelfu$(objext) \
s-shasto$(objext) \
s-soflin$(objext) \
s-soliin$(objext) \
- s-spark$(objext) \
- s-spcuop$(objext) \
s-spsufi$(objext) \
s-stache$(objext) \
s-stalib$(objext) \
s-vaenu8$(objext) \
s-vafi32$(objext) \
s-vafi64$(objext) \
- s-vaispe$(objext) \
s-valboo$(objext) \
s-valcha$(objext) \
s-valflt$(objext) \
s-vallli$(objext) \
s-valllu$(objext) \
s-valrea$(objext) \
- s-valspe$(objext) \
s-valued$(objext) \
s-valuef$(objext) \
s-valuei$(objext) \
s-valuns$(objext) \
s-valuti$(objext) \
s-valwch$(objext) \
- s-vauspe$(objext) \
s-veboop$(objext) \
s-vector$(objext) \
s-vercon$(objext) \
- s-vs_int$(objext) \
- s-vs_lli$(objext) \
- s-vs_llu$(objext) \
- s-vs_uns$(objext) \
s-wchcnv$(objext) \
s-wchcon$(objext) \
s-wchjis$(objext) \
s-vafi128$(objext) \
s-valllli$(objext) \
s-vallllu$(objext) \
- s-vsllli$(objext) \
- s-vslllu$(objext) \
s-widllli$(objext) \
s-widlllu$(objext)
-- operator on private type might not be visible and won't be
-- resolved.
- else pragma Assert (Is_RTE (Base_Type (Typ), RE_Big_Integer)
- or else
- Is_RTE (Base_Type (Typ), RO_GH_Big_Integer)
- or else
- Is_RTE (Base_Type (Typ), RO_SP_Big_Integer));
+ else
+ pragma Assert
+ (Is_RTE (Base_Type (Typ), RE_Big_Integer)
+ or else Is_RTE (Base_Type (Typ), RO_SP_Big_Integer));
return
Make_Function_Call (Loc,
Name =>
ada/libgnat/s-secsta.o \
ada/libgnat/s-soflin.o \
ada/libgnat/s-soliin.o \
- ada/libgnat/s-spark.o \
- ada/libgnat/s-spcuop.o \
ada/libgnat/s-stache.o \
ada/libgnat/s-stalib.o \
ada/libgnat/s-stoele.o \
ada/libgnat/s-trasym.o \
ada/libgnat/s-unstyp.o \
ada/libgnat/s-valint.o \
- ada/libgnat/s-valspe.o \
ada/libgnat/s-valuns.o \
ada/libgnat/s-valuti.o \
- ada/libgnat/s-vs_int.o \
- ada/libgnat/s-vs_uns.o \
ada/libgnat/s-wchcnv.o \
ada/libgnat/s-wchcon.o \
ada/libgnat/s-wchjis.o \
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- 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
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 "*";
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 "*";
function Delete
(Source : String;
From : Positive;
- Through : Natural) return String
- is
+ Through : Natural) return String is
begin
if From > Through then
declare
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);
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;
(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,
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;
(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,
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;
(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,
-- 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
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;
Pad : Character := Space) return String
is
subtype Result_Type is String (1 .. Count);
-
begin
if Count = 0 then
return "";
-- 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
(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,
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;
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;
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;
(Source : in out String;
Side : Trim_End;
Justify : Alignment := Left;
- Pad : Character := Space)
- is
+ Pad : Character := Space) is
begin
Move (Trim (Source, Side),
Source,
Right : Maps.Character_Set) return String
is
High, Low : Integer;
-
begin
Low := Index (Source, Set => Left, Test => Outside, Going => Forward);
declare
Result_Length : constant Integer := High - Low + 1;
subtype Result_Type is String (1 .. Result_Length);
-
begin
return Result_Type (Source (Low .. High));
end;
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,
-- 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
---------------
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);
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;
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
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;
--------------
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;
---------------
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;
-- 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;
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);
-----------------
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
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);
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;
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;
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;
function Value
(Map : Character_Mapping;
- Element : Character) return Character
- is
- (Map (Element));
+ Element : Character) return Character is (Map (Element));
end Ada.Strings.Maps;
-- 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;
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
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;
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;
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;
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
Last := K - 1;
return;
end if;
-
- pragma Loop_Invariant
- (for all L in J .. K =>
- Belongs (Source (L), Set, Test));
end loop;
end if;
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
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
Last := K - 1;
return;
end if;
-
- pragma Loop_Invariant
- (for all L in J .. K =>
- Belongs (Source (L), Set, Test));
end loop;
end if;
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
if Source'First not in Positive then
raise Constraint_Error;
-
else
First := Source'First;
Last := 0;
Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
is
PL1 : constant Integer := Pattern'Length - 1;
-
begin
if Pattern = "" then
raise Pattern_Error;
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
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;
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
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;
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;
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;
(Source : String;
Set : Maps.Character_Set;
Test : Membership := Inside;
- Going : Direction := Forward) return Natural
- is
+ Going : Direction := Forward) return Natural is
begin
-- Forwards case
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
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;
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
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
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;
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
if Source (J) /= ' ' then
return J;
end if;
-
- pragma Loop_Invariant
- (for all C of Source (J .. Source'Last) => C = ' ');
end loop;
end if;
-- --
------------------------------------------------------------------------------
--- 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
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
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;
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;
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;
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);
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;
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;
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;
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;
is
Result : Super_String (Source.Max_Length);
Last : constant Natural := Source.Current_Length;
-
begin
case Side is
when Strings.Left =>
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;
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;
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;
if Slen <= Max_Length then
Result.Data (1 .. Slen) := Super_String_Data (Source);
Result.Current_Length := Slen;
-
else
case Drop is
when Strings.Right =>
-- --
------------------------------------------------------------------------------
--- 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 --
-----------------------
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;
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;
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;
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;
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
end if;
end loop;
- pragma Assert (From = Item'First + C_Length_Ghost (Item));
-
Count := Natural (From - Item'First);
else
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;
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
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;
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
end if;
end loop;
- pragma Assert (From = Item'First + C_Length_Ghost (Item));
-
Count := Natural (From - Item'First);
else
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;
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
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;
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
end if;
end loop;
- pragma Assert (From = Item'First + C_Length_Ghost (Item));
-
Count := Natural (From - Item'First);
else
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;
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
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;
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
end if;
end loop;
- pragma Assert (From = Item'First + C_Length_Ghost (Item));
-
Count := Natural (From - Item'First);
else
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;
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
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;
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;
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;
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;
Target (To) := nul;
Count := Item'Length + 1;
end if;
-
else
Count := Item'Length;
end if;
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;
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;
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;
Target (To) := wide_nul;
Count := Item'Length + 1;
end if;
-
else
Count := Item'Length;
end if;
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;
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;
Append_Nul : Boolean := True)
is
To : size_t;
-
begin
if Target'Length < Item'Length then
raise Constraint_Error;
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;
Target (To) := char16_nul;
Count := Item'Length + 1;
end if;
-
else
Count := Item'Length;
end if;
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;
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;
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;
end if;
end if;
end To_C;
- pragma Annotate (CodePeer, False_Positive, "validity check",
- "Count is only uninitialized on abnormal return.");
end Interfaces.C;
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
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
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
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
-- --
------------------------------------------------------------------------------
-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");
-- 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
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
(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
- Ghost,
- 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;
-- 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;
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
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;
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;
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;
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
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 --
end if;
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 --
-------------------------------
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;
-- 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;
-----------------
-- 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;
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;
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
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
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
-- 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
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;
-------------------------------
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;
pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns");
end System.Arith_Double;
-
-pragma Annotate (Gnatcheck, Exempt_Off, "Metrics_LSLOC");
-- 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 <>;
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.
--
-- 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.
--
-- 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.
-- 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``.
--
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``.
package body System.Arith_128
with SPARK_Mode
is
-
subtype Uns128 is Interfaces.Unsigned_128;
subtype Uns64 is Interfaces.Unsigned_64;
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
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
-- 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);
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 --
-----------------------
-- 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)))
- with Ghost;
- -- 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
- Ghost,
- 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 --
-----------------
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;
-------------------
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;
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;
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;
----------------
(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;
-- 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``.
--
-- 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;
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;
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.
--
-- 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.
--
-- 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.
-- 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``.
--
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.
-- --
------------------------------------------------------------------------------
--- 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
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;
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;
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;
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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);
-- --
------------------------------------------------------------------------------
--- 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 --
-----------------
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);
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;
-- 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
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:
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 --
-----------
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.
-- 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;
-- 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:
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 --
-----------
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.
-- 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;
-- 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:
-- --
------------------------------------------------------------------------------
-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.
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;
-- 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:
-- 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);
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;
Scale : Integer)
is
pragma Assert (S'First = 1);
-
begin
-- Add space at start for non-negative numbers
-- types.
generic
-
type Int is range <>;
- type Uns is mod <>;
-
package System.Image_D is
procedure Image_Decimal
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
-- 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;
Aft0 : Natural)
is
pragma Assert (S'First = 1);
-
begin
-- Add space at start for non-negative numbers
-- 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;
-- --
------------------------------------------------------------------------------
-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 --
-------------------
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",
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;
----------------
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
-- 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;
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,
-- 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.
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
-- --
------------------------------------------------------------------------------
-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 --
--------------------
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;
------------------------
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);
-- 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;
-- 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.
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
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;
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;
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;
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;
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;
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;
-- --
------------------------------------------------------------------------------
--- 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 --
-------------------
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;
-- 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
-- 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;
-- 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;
-- 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;
-- 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;
-- 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;
-- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- --
------------------------------------------------------------------------------
--- 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
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;
-- --
------------------------------------------------------------------------------
--- 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;
-- 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;
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;
-- 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;
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;
-- 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;
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;
-- 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;
-- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A L _ S P E C --
--- --
--- B o d y --
--- --
--- 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. --
--- --
-------------------------------------------------------------------------------
-
--- 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.Val_Spec
- with SPARK_Mode
-is
-
- ---------------------------
- -- First_Non_Space_Ghost --
- ---------------------------
-
- 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;
-
- pragma Loop_Invariant (for all K in From .. J => S (K) = ' ');
- end loop;
-
- raise Program_Error;
- end First_Non_Space_Ghost;
-
- -----------------------
- -- Last_Number_Ghost --
- -----------------------
-
- 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;
- end if;
-
- pragma Loop_Invariant
- (for all K in Str'First .. J => Str (K) in '0' .. '9' | '_');
- end loop;
-
- return Str'Last;
-
- pragma Annotate (Gnatcheck, Exempt_Off, "Improper_Returns");
- end Last_Number_Ghost;
-
-end System.Val_Spec;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
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 --
------------------
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
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);
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
else
Res := Int (Uval);
end if;
-
- Prove_Is_Int_Of_Uns
- (Minus => Str (Non_Blank) = '-',
- Uval => Uval,
- Val => Res);
end Scan_Integer;
-------------------
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;
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;
-- 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 <>;
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;
(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
-- 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
-- --
------------------------------------------------------------------------------
-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 --
-----------------------
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
end if;
P := Ptr.all;
- Spec.Lemma_Scan_Based_Number_Ghost_Step (Str, P, Last_Num_Init);
Uval := Character'Pos (Str (P)) - Character'Pos ('0');
pragma Assert (Str (P) in '0' .. '9');
P := P + 1;
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');
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;
-- 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
-- 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
-- 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
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
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
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;
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;
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;
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;
-- 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;
(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
(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
-- 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;
-- --
------------------------------------------------------------------------------
--- 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;
package body System.Val_Util
---------------
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) & "...""";
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;
-- 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;
-- 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;
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;
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;
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);
Start := P;
- pragma Assert (Start = Sp.First_Non_Space_Ghost (Str, Ptr.all, Max));
-
-- Skip past an initial plus sign
if Str (P) = '+' then
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.
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);
Start := P;
- pragma Assert (Start = Sp.First_Non_Space_Ghost (Str, Ptr.all, Max));
-
-- Remember an initial minus sign
if Str (P) = '-' then
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;
Ext : Boolean)
is
C : Character;
-
begin
P := P + 1;
-- 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
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
(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.
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
-- 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
--
-- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- --
------------------------------------------------------------------------------
--- 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
-----------
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";
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;
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;
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;
-- 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.
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- 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;
-- 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;
-- 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;
-- 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;
-- 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;
-- --
------------------------------------------------------------------------------
-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;
-- 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;
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
-- 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;
-- --
------------------------------------------------------------------------------
--- 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;
-- 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;
subtype Ada_Numerics_Descendant is Ada_Descendant
range Ada_Numerics_Big_Numbers ..
- Ada_Numerics_Big_Numbers_Big_Integers_Ghost;
+ Ada_Numerics_Big_Numbers_Big_Integers;
subtype Ada_Numerics_Big_Numbers_Descendant is Ada_Descendant
range Ada_Numerics_Big_Numbers_Big_Integers ..
- Ada_Numerics_Big_Numbers_Big_Integers_Ghost;
+ Ada_Numerics_Big_Numbers_Big_Integers;
subtype Ada_Real_Time_Descendant is Ada_Descendant
range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events;
-- Children of Ada.Numerics.Big_Numbers
Ada_Numerics_Big_Numbers_Big_Integers,
- Ada_Numerics_Big_Numbers_Big_Integers_Ghost,
-- Children of Ada.Real_Time
RE_Reference, -- Ada.Interrupts
RE_Big_Integer, -- Ada.Numerics.Big_Numbers.Big_Integers
- RO_GH_Big_Integer, -- Ada.Numerics.Big_Numbers.Big_Integers_Ghost
RO_SP_Big_Integer, -- SPARK.Big_Integers
RE_Names, -- Ada.Interrupts.Names
RE_Reference => Ada_Interrupts,
RE_Big_Integer => Ada_Numerics_Big_Numbers_Big_Integers,
- RO_GH_Big_Integer => Ada_Numerics_Big_Numbers_Big_Integers_Ghost,
RO_SP_Big_Integer => SPARK_Big_Integers,
RE_Names => Ada_Interrupts_Names,
then
null;
- -- Expression of a Big_Integer type (or its ghost variant) is
+ -- Expression of a Big_Integer type (or its SPARK variant) is
-- only allowed in Decreases clause.
elsif
Is_RTE (Base_Type (Etype (Expression (Variant))),
RE_Big_Integer)
or else
- Is_RTE (Base_Type (Etype (Expression (Variant))),
- RO_GH_Big_Integer)
- or else
Is_RTE (Base_Type (Etype (Expression (Variant))),
RO_SP_Big_Integer)
then
-- Expression of a Big_Integer type (or its ghost variant) is only
-- allowed in Decreases clause.
- elsif
- Is_RTE (Base_Type (Etype (Expr)), RE_Big_Integer)
- or else
- Is_RTE (Base_Type (Etype (Expr)), RO_GH_Big_Integer)
- or else
- Is_RTE (Base_Type (Etype (Expr)), RO_SP_Big_Integer)
+ elsif Is_RTE (Base_Type (Etype (Expr)), RE_Big_Integer)
+ or else Is_RTE (Base_Type (Etype (Expr)), RO_SP_Big_Integer)
then
if Chars (Direction) = Name_Increases then
Error_Msg_N
projects / thirdparty / gcc.git / commitdiff
