diff options
| author | Ian Lance Taylor <iant@golang.org> | 2022-07-27 10:15:41 -0700 |
|---|---|---|
| committer | Ian Lance Taylor <iant@golang.org> | 2022-07-27 10:15:41 -0700 |
| commit | 9f62ed218fa656607740b386c0caa03e65dcd283 (patch) | |
| tree | 6bde49bc5e4c4241266b108e4277baef4b85535d /gcc/ada/libgnat | |
| parent | 71e955da39cea0ebffcfee3432effa622d14ca99 (diff) | |
| parent | 5eb9f117a361538834b9740d59219911680717d1 (diff) | |
| download | gcc-9f62ed218fa656607740b386c0caa03e65dcd283.zip gcc-9f62ed218fa656607740b386c0caa03e65dcd283.tar.gz gcc-9f62ed218fa656607740b386c0caa03e65dcd283.tar.bz2 | |
Merge from trunk revision 5eb9f117a361538834b9740d59219911680717d1.
Diffstat (limited to 'gcc/ada/libgnat')
285 files changed, 10923 insertions, 3982 deletions
diff --git a/gcc/ada/libgnat/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb index 540fc93..d8cf6c3c 100644 --- a/gcc/ada/libgnat/a-cbdlli.adb +++ b/gcc/ada/libgnat/a-cbdlli.adb @@ -75,7 +75,7 @@ is Src_Pos : Count_Type; Tgt_Pos : out Count_Type); - function Vet (Position : Cursor) return Boolean; + function Vet (Position : Cursor) return Boolean with Inline; -- Checks invariants of the cursor and its designated container, as a -- simple way of detecting dangling references (see operation Free for a -- description of the detection mechanism), returning True if all checks @@ -2210,6 +2210,10 @@ is function Vet (Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = 0 then return Position.Container = null; end if; diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads index 10be7ab..78343a0 100644 --- a/gcc/ada/libgnat/a-cbdlli.ads +++ b/gcc/ada/libgnat/a-cbdlli.ads @@ -364,10 +364,10 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased List'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cbhama.adb b/gcc/ada/libgnat/a-cbhama.adb index 59c4c7e..f557ff9 100644 --- a/gcc/ada/libgnat/a-cbhama.adb +++ b/gcc/ada/libgnat/a-cbhama.adb @@ -66,7 +66,7 @@ is procedure Set_Next (Node : in out Node_Type; Next : Count_Type); pragma Inline (Set_Next); - function Vet (Position : Cursor) return Boolean; + function Vet (Position : Cursor) return Boolean with Inline; -------------------------- -- Local Instantiations -- @@ -1175,6 +1175,10 @@ is function Vet (Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = 0 then return Position.Container = null; end if; diff --git a/gcc/ada/libgnat/a-cbhama.ads b/gcc/ada/libgnat/a-cbhama.ads index 6891a2f..c62d451 100644 --- a/gcc/ada/libgnat/a-cbhama.ads +++ b/gcc/ada/libgnat/a-cbhama.ads @@ -439,10 +439,9 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cbhase.adb b/gcc/ada/libgnat/a-cbhase.adb index 3c1c7b4..b83ab80 100644 --- a/gcc/ada/libgnat/a-cbhase.adb +++ b/gcc/ada/libgnat/a-cbhase.adb @@ -79,7 +79,7 @@ is procedure Set_Next (Node : in out Node_Type; Next : Count_Type); pragma Inline (Set_Next); - function Vet (Position : Cursor) return Boolean; + function Vet (Position : Cursor) return Boolean with Inline; -------------------------- -- Local Instantiations -- @@ -1496,6 +1496,10 @@ is function Vet (Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = 0 then return Position.Container = null; end if; @@ -1595,6 +1599,64 @@ is raise Program_Error with "attempt to stream reference"; end Write; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + pragma Assert ((Position.Container = null) = (Position.Node = 0), + "bad nullity in Has_Element"); + return Position.Container = Container'Unrestricted_Access; + end Has_Element; + + function Tampering_With_Cursors_Prohibited + (Container : Set) return Boolean + is + begin + return Is_Busy (Container.TC); + end Tampering_With_Cursors_Prohibited; + + function Element (Container : Set; Position : Cursor) return Element_Type is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + return Element (Position); + end Element; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)) is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + Query_Element (Position, Process); + end Query_Element; + + function Next (Container : Set; Position : Cursor) return Cursor is + begin + if Checks and then + not (Position = No_Element or else Has_Element (Container, Position)) + then + raise Program_Error with "Position for wrong Container"; + end if; + + return Next (Position); + end Next; + + procedure Next (Container : Set; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + ------------------ + -- Generic_Keys -- + ------------------ + package body Generic_Keys is ----------------------- diff --git a/gcc/ada/libgnat/a-cbhase.ads b/gcc/ada/libgnat/a-cbhase.ads index c30a364..7c6d971 100644 --- a/gcc/ada/libgnat/a-cbhase.ads +++ b/gcc/ada/libgnat/a-cbhase.ads @@ -369,6 +369,25 @@ is (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean; + + function Tampering_With_Cursors_Prohibited (Container : Set) return Boolean; + + function Element (Container : Set; Position : Cursor) return Element_Type; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + function Next (Container : Set; Position : Cursor) return Cursor; + + procedure Next (Container : Set; Position : in out Cursor); + + ---------------- + generic type Key_Type (<>) is private; @@ -384,6 +403,9 @@ is -- Applies generic formal operation Key to the element of the node -- designated by Position. + function Key (Container : Set; Position : Cursor) return Key_Type is + (Key (Element (Container, Position))); + function Element (Container : Set; Key : Key_Type) return Element_Type; -- Searches (as per the key-based Find) for the node containing Key, and -- returns the associated element. @@ -574,10 +596,9 @@ private for Constant_Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cbmutr.ads b/gcc/ada/libgnat/a-cbmutr.ads index 2448eac..89d5cdf 100644 --- a/gcc/ada/libgnat/a-cbmutr.ads +++ b/gcc/ada/libgnat/a-cbmutr.ads @@ -386,10 +386,7 @@ private Item : out Reference_Type); for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following function Pseudo_Reference (Container : aliased Tree'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cborma.ads b/gcc/ada/libgnat/a-cborma.ads index 5b0ed73..af69feb 100644 --- a/gcc/ada/libgnat/a-cborma.ads +++ b/gcc/ada/libgnat/a-cborma.ads @@ -341,10 +341,10 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb index 55eca40..bc52b45 100644 --- a/gcc/ada/libgnat/a-cborse.adb +++ b/gcc/ada/libgnat/a-cborse.adb @@ -688,6 +688,62 @@ is else Cursor'(Container'Unrestricted_Access, Node)); end Floor; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean is + begin + pragma Assert + (Position.Container = null or else Vet (Container, Position.Node), + "bad cursor in Has_Element"); + pragma Assert ((Position.Container = null) = (Position.Node = 0), + "bad nullity in Has_Element"); + return Position.Container = Container'Unrestricted_Access; + end Has_Element; + + function Tampering_With_Cursors_Prohibited + (Container : Set) return Boolean + is + begin + return Is_Busy (Container.TC); + end Tampering_With_Cursors_Prohibited; + + function Element (Container : Set; Position : Cursor) return Element_Type is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + return Element (Position); + end Element; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)) is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + Query_Element (Position, Process); + end Query_Element; + + function Next (Container : Set; Position : Cursor) return Cursor is + begin + if Checks and then + not (Position = No_Element or else Has_Element (Container, Position)) + then + raise Program_Error with "Position for wrong Container"; + end if; + + return Next (Position); + end Next; + + procedure Next (Container : Set; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + ------------------ -- Generic_Keys -- ------------------ diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads index ceaf885..0b7e86f 100644 --- a/gcc/ada/libgnat/a-cborse.ads +++ b/gcc/ada/libgnat/a-cborse.ads @@ -230,6 +230,25 @@ is Start : Cursor) return Set_Iterator_Interfaces.Reversible_Iterator'class; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean; + + function Tampering_With_Cursors_Prohibited (Container : Set) return Boolean; + + function Element (Container : Set; Position : Cursor) return Element_Type; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + function Next (Container : Set; Position : Cursor) return Cursor; + + procedure Next (Container : Set; Position : in out Cursor); + + ---------------- + generic type Key_Type (<>) is private; @@ -243,6 +262,9 @@ is function Key (Position : Cursor) return Key_Type; + function Key (Container : Set; Position : Cursor) return Key_Type is + (Key (Element (Container, Position))); + function Element (Container : Set; Key : Key_Type) return Element_Type; procedure Replace @@ -413,10 +435,10 @@ private for Constant_Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb index 5828607..22cb146 100644 --- a/gcc/ada/libgnat/a-cdlili.adb +++ b/gcc/ada/libgnat/a-cdlili.adb @@ -64,7 +64,7 @@ is Source : in out List; Position : Node_Access); - function Vet (Position : Cursor) return Boolean; + function Vet (Position : Cursor) return Boolean with Inline; -- Checks invariants of the cursor and its designated container, as a -- simple way of detecting dangling references (see operation Free for a -- description of the detection mechanism), returning True if all checks @@ -1991,6 +1991,10 @@ is function Vet (Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = null then return Position.Container = null; end if; diff --git a/gcc/ada/libgnat/a-cdlili.ads b/gcc/ada/libgnat/a-cdlili.ads index abfd011..bfe10ee 100644 --- a/gcc/ada/libgnat/a-cdlili.ads +++ b/gcc/ada/libgnat/a-cdlili.ads @@ -374,10 +374,10 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased List'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cfdlli.adb b/gcc/ada/libgnat/a-cfdlli.adb index 14f0304..bbb8fd4 100644 --- a/gcc/ada/libgnat/a-cfdlli.adb +++ b/gcc/ada/libgnat/a-cfdlli.adb @@ -29,9 +29,17 @@ with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; with System; use type System.Address; +with Ada.Numerics.Big_Numbers.Big_Integers; +use Ada.Numerics.Big_Numbers.Big_Integers; + package body Ada.Containers.Formal_Doubly_Linked_Lists with SPARK_Mode => Off is + -- Convert Count_Type to Big_Interger + + package Conversions is new Signed_Conversions (Int => Count_Type); + use Conversions; + ----------------------- -- Local Subprograms -- ----------------------- @@ -48,7 +56,7 @@ is Before : Count_Type; New_Node : Count_Type); - function Vet (L : List; Position : Cursor) return Boolean; + function Vet (L : List; Position : Cursor) return Boolean with Inline; --------- -- "=" -- @@ -68,9 +76,9 @@ is end if; LI := Left.First; - RI := Left.First; + RI := Right.First; while LI /= 0 loop - if Left.Nodes (LI).Element /= Right.Nodes (LI).Element then + if Left.Nodes (LI).Element /= Right.Nodes (RI).Element then return False; end if; @@ -809,7 +817,7 @@ is while Position /= 0 loop R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = I); + pragma Assert (P.Length (R) = To_Big_Integer (I)); Position := Container.Nodes (Position).Next; I := I + 1; end loop; @@ -1766,8 +1774,11 @@ is function Vet (L : List; Position : Cursor) return Boolean is N : Node_Array renames L.Nodes; - begin + if not Container_Checks'Enabled then + return True; + end if; + if L.Length = 0 then return False; end if; diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads index 521f4bf..01e7db2 100644 --- a/gcc/ada/libgnat/a-cfdlli.ads +++ b/gcc/ada/libgnat/a-cfdlli.ads @@ -37,8 +37,10 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Formal_Doubly_Linked_Lists with - SPARK_Mode + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. @@ -543,15 +545,7 @@ is Lst => Length (Container), Item => New_Item)) - -- Container contains Count times New_Item at the end - - and M.Constant_Range - (Container => Model (Container), - Fst => Length (Container)'Old + 1, - Lst => Length (Container), - Item => New_Item) - - -- A Count cursors have been inserted at the end of Container + -- Count cursors have been inserted at the end of Container and P_Positions_Truncated (Positions (Container)'Old, diff --git a/gcc/ada/libgnat/a-cfhama.adb b/gcc/ada/libgnat/a-cfhama.adb index 48950de..bdf2c61 100644 --- a/gcc/ada/libgnat/a-cfhama.adb +++ b/gcc/ada/libgnat/a-cfhama.adb @@ -25,14 +25,17 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); +with Ada.Containers.Hash_Tables.Generic_Formal_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations); -with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); +with Ada.Containers.Hash_Tables.Generic_Formal_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; +with Ada.Numerics.Big_Numbers.Big_Integers; +use Ada.Numerics.Big_Numbers.Big_Integers; + with System; use type System.Address; package body Ada.Containers.Formal_Hashed_Maps with @@ -56,7 +59,7 @@ is generic with procedure Set_Element (Node : in out Node_Type); procedure Generic_Allocate - (HT : in out Map; + (HT : in out HT_Types.Hash_Table_Type; Node : out Count_Type); function Hash_Node (Node : Node_Type) return Hash_Type; @@ -68,21 +71,29 @@ is procedure Set_Next (Node : in out Node_Type; Next : Count_Type); pragma Inline (Set_Next); - function Vet (Container : Map; Position : Cursor) return Boolean; + function Vet (Container : Map; Position : Cursor) return Boolean + with Inline; + + -- Convert Count_Type to Big_Interger + + package Conversions is new Signed_Conversions (Int => Count_Type); + + function Big (J : Count_Type) return Big_Integer renames + Conversions.To_Big_Integer; -------------------------- -- Local Instantiations -- -------------------------- package HT_Ops is - new Hash_Tables.Generic_Bounded_Operations + new Hash_Tables.Generic_Formal_Operations (HT_Types => HT_Types, Hash_Node => Hash_Node, Next => Next, Set_Next => Set_Next); package Key_Ops is - new Hash_Tables.Generic_Bounded_Keys + new Hash_Tables.Generic_Formal_Keys (HT_Types => HT_Types, Next => Next, Set_Next => Set_Next, @@ -151,13 +162,9 @@ is Insert (Target, N.Key, N.Element); end Insert_Element; - -- Start of processing for Assign + -- Start of processing for Assign begin - if Target'Address = Source'Address then - return; - end if; - if Target.Capacity < Length (Source) then raise Constraint_Error with -- correct exception ??? "Source length exceeds Target capacity"; @@ -529,7 +536,7 @@ is while Position /= 0 loop R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = I); + pragma Assert (P.Length (R) = Big (I)); Position := HT_Ops.Next (Container.Content, Position); I := I + 1; end loop; @@ -556,13 +563,16 @@ is -- Generic_Allocate -- ---------------------- - procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is + procedure Generic_Allocate + (HT : in out HT_Types.Hash_Table_Type; + Node : out Count_Type) + is procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element); begin - Allocate (HT.Content, Node); - HT.Content.Nodes (Node).Has_Element := True; + Allocate (HT, Node); + HT.Nodes (Node).Has_Element := True; end Generic_Allocate; ----------------- @@ -606,7 +616,8 @@ is if not Inserted then declare - N : Node_Type renames Container.Content.Nodes (Position.Node); + P : constant Count_Type := Position.Node; + N : Node_Type renames Container.Content.Nodes (P); begin N.Key := Key; N.Element := New_Item; @@ -628,7 +639,9 @@ is procedure Assign_Key (Node : in out Node_Type); pragma Inline (Assign_Key); - function New_Node return Count_Type; + procedure New_Node + (HT : in out HT_Types.Hash_Table_Type; + Node : out Count_Type); pragma Inline (New_Node); procedure Local_Insert is @@ -651,11 +664,12 @@ is -- New_Node -- -------------- - function New_Node return Count_Type is - Result : Count_Type; + procedure New_Node + (HT : in out HT_Types.Hash_Table_Type; + Node : out Count_Type) + is begin - Allocate (Container, Result); - return Result; + Allocate (HT, Node); end New_Node; -- Start of processing for Insert @@ -669,11 +683,11 @@ is Key : Key_Type; New_Item : Element_Type) is - Position : Cursor; - Inserted : Boolean; + Unused_Position : Cursor; + Inserted : Boolean; begin - Insert (Container, Key, New_Item, Position, Inserted); + Insert (Container, Key, New_Item, Unused_Position, Inserted); if not Inserted then raise Constraint_Error with "attempt to insert key already in map"; @@ -727,10 +741,6 @@ is Y : Count_Type; begin - if Target'Address = Source'Address then - return; - end if; - if Target.Capacity < Length (Source) then raise Constraint_Error with -- ??? "Source length exceeds Target capacity"; @@ -902,6 +912,10 @@ is function Vet (Container : Map; Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = 0 then return True; end if; diff --git a/gcc/ada/libgnat/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads index 37024f0..8cb7488 100644 --- a/gcc/ada/libgnat/a-cfhama.ads +++ b/gcc/ada/libgnat/a-cfhama.ads @@ -62,8 +62,10 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Formal_Hashed_Maps with - SPARK_Mode + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. @@ -900,7 +902,7 @@ private end record; package HT_Types is new - Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); + Ada.Containers.Hash_Tables.Generic_Formal_Hash_Table_Types (Node_Type); type Map (Capacity : Count_Type; Modulus : Hash_Type) is record Content : HT_Types.Hash_Table_Type (Capacity, Modulus); diff --git a/gcc/ada/libgnat/a-cfhase.adb b/gcc/ada/libgnat/a-cfhase.adb index 6e289e4..34afa55 100644 --- a/gcc/ada/libgnat/a-cfhase.adb +++ b/gcc/ada/libgnat/a-cfhase.adb @@ -25,11 +25,11 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); +with Ada.Containers.Hash_Tables.Generic_Formal_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations); -with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); +with Ada.Containers.Hash_Tables.Generic_Formal_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; @@ -58,7 +58,7 @@ is generic with procedure Set_Element (Node : in out Node_Type); procedure Generic_Allocate - (HT : in out Set; + (HT : in out Hash_Table_Type; Node : out Count_Type); function Hash_Node (Node : Node_Type) return Hash_Type; @@ -89,19 +89,20 @@ is procedure Set_Next (Node : in out Node_Type; Next : Count_Type); pragma Inline (Set_Next); - function Vet (Container : Set; Position : Cursor) return Boolean; + function Vet (Container : Set; Position : Cursor) return Boolean + with Inline; -------------------------- -- Local Instantiations -- -------------------------- - package HT_Ops is new Hash_Tables.Generic_Bounded_Operations + package HT_Ops is new Hash_Tables.Generic_Formal_Operations (HT_Types => HT_Types, Hash_Node => Hash_Node, Next => Next, Set_Next => Set_Next); - package Element_Keys is new Hash_Tables.Generic_Bounded_Keys + package Element_Keys is new Hash_Tables.Generic_Formal_Keys (HT_Types => HT_Types, Next => Next, Set_Next => Set_Next, @@ -167,22 +168,18 @@ is -------------------- procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.Content.Nodes (Source_Node); - X : Count_Type; - B : Boolean; + N : Node_Type renames Source.Content.Nodes (Source_Node); + Unused_X : Count_Type; + B : Boolean; begin - Insert (Target, N.Element, X, B); + Insert (Target, N.Element, Unused_X, B); pragma Assert (B); end Insert_Element; -- Start of processing for Assign begin - if Target'Address = Source'Address then - return; - end if; - if Target.Capacity < Length (Source) then raise Storage_Error with "not enough capacity"; -- SE or CE? ??? end if; @@ -335,11 +332,6 @@ is SN : Nodes_Type renames Source.Content.Nodes; begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - Src_Length := Source.Content.Length; if Src_Length = 0 then @@ -393,13 +385,13 @@ is ------------- procedure Process (L_Node : Count_Type) is - B : Boolean; - E : Element_Type renames Left.Content.Nodes (L_Node).Element; - X : Count_Type; + B : Boolean; + E : Element_Type renames Left.Content.Nodes (L_Node).Element; + Unused_X : Count_Type; begin if Find (Right, E).Node = 0 then - Insert (Target, E, X, B); + Insert (Target, E, Unused_X, B); pragma Assert (B); end if; end Process; @@ -411,14 +403,7 @@ is end Difference; function Difference (Left : Set; Right : Set) return Set is - C : Count_Type; - H : Hash_Type; - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - if Length (Left) = 0 then return Empty_Set; end if; @@ -427,12 +412,14 @@ is return Copy (Left); end if; - C := Length (Left); - H := Default_Modulus (C); - - return S : Set (C, H) do - Difference (Left, Right, Target => S); - end return; + declare + C : constant Count_Type := Length (Left); + H : constant Hash_Type := Default_Modulus (C); + begin + return S : Set (C, H) do + Difference (Left, Right, Target => S); + end return; + end; end Difference; ------------- @@ -461,7 +448,7 @@ is function Equivalent_Sets (Left, Right : Set) return Boolean is function Find_Equivalent_Key - (R_HT : Hash_Table_Type'Class; + (R_HT : Hash_Table_Type; L_Node : Node_Type) return Boolean; pragma Inline (Find_Equivalent_Key); @@ -473,7 +460,7 @@ is ------------------------- function Find_Equivalent_Key - (R_HT : Hash_Table_Type'Class; + (R_HT : Hash_Table_Type; L_Node : Node_Type) return Boolean is R_Index : constant Hash_Type := @@ -766,7 +753,7 @@ is while Position /= 0 loop R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = I); + pragma Assert (P.Length (R) = Big (I)); Position := HT_Ops.Next (Container.Content, Position); I := I + 1; end loop; @@ -793,11 +780,14 @@ is -- Generic_Allocate -- ---------------------- - procedure Generic_Allocate (HT : in out Set; Node : out Count_Type) is + procedure Generic_Allocate + (HT : in out Hash_Table_Type; + Node : out Count_Type) + is procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element); begin - Allocate (HT.Content, Node); - HT.Content.Nodes (Node).Has_Element := True; + Allocate (HT, Node); + HT.Nodes (Node).Has_Element := True; end Generic_Allocate; package body Generic_Keys with SPARK_Mode => Off is @@ -815,7 +805,7 @@ is -- Local Instantiations -- -------------------------- - package Key_Keys is new Hash_Tables.Generic_Bounded_Keys + package Key_Keys is new Hash_Tables.Generic_Formal_Keys (HT_Types => HT_Types, Next => Next, Set_Next => Set_Next, @@ -1031,11 +1021,11 @@ is end Insert; procedure Insert (Container : in out Set; New_Item : Element_Type) is - Inserted : Boolean; - Position : Cursor; + Inserted : Boolean; + Unused_Position : Cursor; begin - Insert (Container, New_Item, Position, Inserted); + Insert (Container, New_Item, Unused_Position, Inserted); if not Inserted then raise Constraint_Error with @@ -1052,7 +1042,9 @@ is procedure Allocate_Set_Element (Node : in out Node_Type); pragma Inline (Allocate_Set_Element); - function New_Node return Count_Type; + procedure New_Node + (HT : in out Hash_Table_Type; + Node : out Count_Type); pragma Inline (New_Node); procedure Local_Insert is @@ -1074,11 +1066,12 @@ is -- New_Node -- -------------- - function New_Node return Count_Type is - Result : Count_Type; + procedure New_Node + (HT : in out Hash_Table_Type; + Node : out Count_Type) + is begin - Allocate (Container, Result); - return Result; + Allocate (HT, Node); end New_Node; -- Start of processing for Insert @@ -1096,10 +1089,6 @@ is TN : Nodes_Type renames Target.Content.Nodes; begin - if Target'Address = Source'Address then - return; - end if; - if Source.Content.Length = 0 then Clear (Target); return; @@ -1133,13 +1122,13 @@ is ------------- procedure Process (L_Node : Count_Type) is - E : Element_Type renames Left.Content.Nodes (L_Node).Element; - X : Count_Type; - B : Boolean; + E : Element_Type renames Left.Content.Nodes (L_Node).Element; + Unused_X : Count_Type; + B : Boolean; begin if Find (Right, E).Node /= 0 then - Insert (Target, E, X, B); + Insert (Target, E, Unused_X, B); pragma Assert (B); end if; end Process; @@ -1151,17 +1140,11 @@ is end Intersection; function Intersection (Left : Set; Right : Set) return Set is - C : Count_Type; - H : Hash_Type; + C : constant Count_Type := + Count_Type'Min (Length (Left), Length (Right)); -- ??? + H : constant Hash_Type := Default_Modulus (C); begin - if Left'Address = Right'Address then - return Copy (Left); - end if; - - C := Count_Type'Min (Length (Left), Length (Right)); -- ??? - H := Default_Modulus (C); - return S : Set (C, H) do if Length (Left) /= 0 and Length (Right) /= 0 then Intersection (Left, Right, Target => S); @@ -1196,10 +1179,6 @@ is Subset_Nodes : Nodes_Type renames Subset.Content.Nodes; begin - if Subset'Address = Of_Set'Address then - return True; - end if; - if Length (Subset) > Length (Of_Set) then return False; end if; @@ -1207,7 +1186,8 @@ is Subset_Node := First (Subset).Node; while Subset_Node /= 0 loop declare - N : Node_Type renames Subset_Nodes (Subset_Node); + S : constant Count_Type := Subset_Node; + N : Node_Type renames Subset_Nodes (S); E : Element_Type renames N.Element; begin @@ -1242,10 +1222,6 @@ is X, Y : Count_Type; begin - if Target'Address = Source'Address then - return; - end if; - if Target.Capacity < Length (Source) then raise Constraint_Error with -- ??? "Source length exceeds Target capacity"; @@ -1312,14 +1288,11 @@ is return False; end if; - if Left'Address = Right'Address then - return True; - end if; - Left_Node := First (Left).Node; while Left_Node /= 0 loop declare - N : Node_Type renames Left_Nodes (Left_Node); + L : constant Count_Type := Left_Node; + N : Node_Type renames Left_Nodes (L); E : Element_Type renames N.Element; begin if Find (Right, E).Node /= 0 then @@ -1416,15 +1389,15 @@ is ------------- procedure Process (Source_Node : Count_Type) is - B : Boolean; - N : Node_Type renames Source.Content.Nodes (Source_Node); - X : Count_Type; + B : Boolean; + N : Node_Type renames Source.Content.Nodes (Source_Node); + Unused_X : Count_Type; begin if Is_In (Target, N) then Delete (Target, N.Element); else - Insert (Target, N.Element, X, B); + Insert (Target, N.Element, Unused_X, B); pragma Assert (B); end if; end Process; @@ -1432,11 +1405,6 @@ is -- Start of processing for Symmetric_Difference begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - if Length (Target) = 0 then Assign (Target, Source); return; @@ -1446,14 +1414,7 @@ is end Symmetric_Difference; function Symmetric_Difference (Left : Set; Right : Set) return Set is - C : Count_Type; - H : Hash_Type; - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - if Length (Right) = 0 then return Copy (Left); end if; @@ -1462,13 +1423,15 @@ is return Copy (Right); end if; - C := Length (Left) + Length (Right); - H := Default_Modulus (C); - - return S : Set (C, H) do - Difference (Left, Right, S); - Difference (Right, Left, S); - end return; + declare + C : constant Count_Type := Length (Left) + Length (Right); + H : constant Hash_Type := Default_Modulus (C); + begin + return S : Set (C, H) do + Difference (Left, Right, S); + Difference (Right, Left, S); + end return; + end; end Symmetric_Difference; ------------ @@ -1476,12 +1439,12 @@ is ------------ function To_Set (New_Item : Element_Type) return Set is - X : Count_Type; - B : Boolean; + Unused_X : Count_Type; + B : Boolean; begin return S : Set (Capacity => 1, Modulus => 1) do - Insert (S, New_Item, X, B); + Insert (S, New_Item, Unused_X, B); pragma Assert (B); end return; end To_Set; @@ -1504,32 +1467,21 @@ is N : Node_Type renames Source.Content.Nodes (Src_Node); E : Element_Type renames N.Element; - X : Count_Type; - B : Boolean; + Unused_X : Count_Type; + Unused_B : Boolean; begin - Insert (Target, E, X, B); + Insert (Target, E, Unused_X, Unused_B); end Process; -- Start of processing for Union begin - if Target'Address = Source'Address then - return; - end if; - Iterate (Source.Content); end Union; function Union (Left : Set; Right : Set) return Set is - C : Count_Type; - H : Hash_Type; - begin - if Left'Address = Right'Address then - return Copy (Left); - end if; - if Length (Right) = 0 then return Copy (Left); end if; @@ -1538,12 +1490,15 @@ is return Copy (Right); end if; - C := Length (Left) + Length (Right); - H := Default_Modulus (C); - return S : Set (C, H) do - Assign (Target => S, Source => Left); - Union (Target => S, Source => Right); - end return; + declare + C : constant Count_Type := Length (Left) + Length (Right); + H : constant Hash_Type := Default_Modulus (C); + begin + return S : Set (C, H) do + Assign (Target => S, Source => Left); + Union (Target => S, Source => Right); + end return; + end; end Union; --------- @@ -1552,6 +1507,10 @@ is function Vet (Container : Set; Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = 0 then return True; end if; diff --git a/gcc/ada/libgnat/a-cfhase.ads b/gcc/ada/libgnat/a-cfhase.ads index 425824d..248a0ac 100644 --- a/gcc/ada/libgnat/a-cfhase.ads +++ b/gcc/ada/libgnat/a-cfhase.ads @@ -48,6 +48,8 @@ with Ada.Containers.Functional_Maps; with Ada.Containers.Functional_Sets; with Ada.Containers.Functional_Vectors; +with Ada.Numerics.Big_Numbers.Big_Integers; +use Ada.Numerics.Big_Numbers.Big_Integers; private with Ada.Containers.Hash_Tables; generic @@ -60,8 +62,10 @@ generic Right : Element_Type) return Boolean is "="; package Ada.Containers.Formal_Hashed_Sets with - SPARK_Mode + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. @@ -70,6 +74,13 @@ is pragma Assertion_Policy (Contract_Cases => Ignore); pragma Annotate (CodePeer, Skip_Analysis); + -- Convert Count_Type to Big_Interger. + + package Conversions is new Signed_Conversions (Int => Count_Type); + + function Big (J : Count_Type) return Big_Integer renames + Conversions.To_Big_Integer; + type Set (Capacity : Count_Type; Modulus : Hash_Type) is private with Iterable => (First => First, Next => Next, @@ -261,7 +272,7 @@ is Ghost, Global => null, - Post => M.Length (Model'Result) = Length (Container); + Post => M.Length (Model'Result) = Big (Length (Container)); function Elements (Container : Set) return E.Sequence with -- The Elements sequence represents the underlying list structure of @@ -859,9 +870,9 @@ is Length (Source) - Length (Target and Source) <= Target.Capacity - Length (Target), Post => - Length (Target) = Length (Target)'Old + Big (Length (Target)) = Big (Length (Target)'Old) - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - + Length (Source) + + Big (Length (Source)) -- Elements already in Target are still in Target @@ -907,9 +918,9 @@ is Global => null, Pre => Length (Left) <= Count_Type'Last - Length (Right), Post => - Length (Union'Result) = Length (Left) + Big (Length (Union'Result)) = Big (Length (Left)) - M.Num_Overlaps (Model (Left), Model (Right)) - + Length (Right) + + Big (Length (Right)) -- Elements of Left and Right are in the result of Union @@ -946,7 +957,7 @@ is procedure Intersection (Target : in out Set; Source : Set) with Global => null, Post => - Length (Target) = + Big (Length (Target)) = M.Num_Overlaps (Model (Target)'Old, Model (Source)) -- Elements of Target were already in Target @@ -982,7 +993,7 @@ is function Intersection (Left, Right : Set) return Set with Global => null, Post => - Length (Intersection'Result) = + Big (Length (Intersection'Result)) = M.Num_Overlaps (Model (Left), Model (Right)) -- Elements in the result of Intersection are in Left and Right @@ -1012,7 +1023,7 @@ is procedure Difference (Target : in out Set; Source : Set) with Global => null, Post => - Length (Target) = Length (Target)'Old - + Big (Length (Target)) = Big (Length (Target)'Old) - M.Num_Overlaps (Model (Target)'Old, Model (Source)) -- Elements of Target were already in Target @@ -1048,7 +1059,7 @@ is function Difference (Left, Right : Set) return Set with Global => null, Post => - Length (Difference'Result) = Length (Left) - + Big (Length (Difference'Result)) = Big (Length (Left)) - M.Num_Overlaps (Model (Left), Model (Right)) -- Elements of the result of Difference are in Left @@ -1085,9 +1096,9 @@ is Length (Source) - Length (Target and Source) <= Target.Capacity - Length (Target) + Length (Target and Source), Post => - Length (Target) = Length (Target)'Old - + Big (Length (Target)) = Big (Length (Target)'Old) - 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) + - Length (Source) + Big (Length (Source)) -- Elements of the difference were not both in Source and in Target @@ -1125,9 +1136,9 @@ is Global => null, Pre => Length (Left) <= Count_Type'Last - Length (Right), Post => - Length (Symmetric_Difference'Result) = Length (Left) - + Big (Length (Symmetric_Difference'Result)) = Big (Length (Left)) - 2 * M.Num_Overlaps (Model (Left), Model (Right)) + - Length (Right) + Big (Length (Right)) -- Elements of the difference were not both in Left and Right @@ -1479,7 +1490,7 @@ private end record; package HT_Types is new - Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); + Ada.Containers.Hash_Tables.Generic_Formal_Hash_Table_Types (Node_Type); type Set (Capacity : Count_Type; Modulus : Hash_Type) is record Content : HT_Types.Hash_Table_Type (Capacity, Modulus); diff --git a/gcc/ada/libgnat/a-cfidll.adb b/gcc/ada/libgnat/a-cfidll.adb new file mode 100644 index 0000000..17e48d2 --- /dev/null +++ b/gcc/ada/libgnat/a-cfidll.adb @@ -0,0 +1,2054 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FORMAL_INDEFINITE_DOUBLY_LINKED_LISTS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2022-2022, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; + +with System; use type System.Address; + +with Ada.Numerics.Big_Numbers.Big_Integers; +use Ada.Numerics.Big_Numbers.Big_Integers; + +package body Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with + SPARK_Mode => Off +is + -- Convert Count_Type to Big_Integer + + package Conversions is new Signed_Conversions (Int => Count_Type); + use Conversions; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Allocate + (Container : in out List; + New_Item : Element_Type; + New_Node : out Count_Type); + + procedure Allocate + (Container : in out List; + New_Node : out Count_Type); + + procedure Free (Container : in out List; X : Count_Type); + + procedure Insert_Internal + (Container : in out List; + Before : Count_Type; + New_Node : Count_Type); + + function Vet (L : List; Position : Cursor) return Boolean with Inline; + + procedure Resize (Container : in out List) with + -- Add more room in the internal array + + Global => null, + Pre => Container.Nodes = null + or else Length (Container) = Container.Nodes'Length, + Post => Model (Container) = Model (Container)'Old + and Positions (Container) = Positions (Container)'Old; + + procedure Finalize_Element is new Ada.Unchecked_Deallocation + (Object => Element_Type, + Name => Element_Access); + + procedure Finalize_Nodes is new Ada.Unchecked_Deallocation + (Object => Node_Array, + Name => Node_Array_Access); + + --------- + -- "=" -- + --------- + + function "=" (Left : List; Right : List) return Boolean is + LI : Count_Type; + RI : Count_Type; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + LI := Left.First; + RI := Right.First; + while LI /= 0 loop + if Left.Nodes (LI).Element.all /= Right.Nodes (RI).Element.all then + return False; + end if; + + LI := Left.Nodes (LI).Next; + RI := Right.Nodes (RI).Next; + end loop; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (Container : in out List) is + N_Src : Node_Array_Access renames Container.Nodes; + N_Tar : Node_Array_Access; + + begin + if N_Src = null then + return; + end if; + + if Container.Length = 0 then + Container.Nodes := null; + Container.Free := -1; + return; + end if; + + N_Tar := new Node_Array (1 .. N_Src'Length); + + for X in 1 .. Count_Type (N_Src'Length) loop + N_Tar (X) := N_Src (X); + if N_Src (X).Element /= null + then + N_Tar (X).Element := new Element_Type'(N_Src (X).Element.all); + end if; + end loop; + + N_Src := N_Tar; + + end Adjust; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Container : in out List; + New_Node : out Count_Type) + is + N : Node_Array_Access renames Container.Nodes; + + begin + if Container.Nodes = null + or else Length (Container) = Container.Nodes'Length + then + Resize (Container); + end if; + + if Container.Free >= 0 then + New_Node := Container.Free; + Container.Free := N (New_Node).Next; + else + New_Node := abs Container.Free; + Container.Free := Container.Free - 1; + end if; + + N (New_Node).Element := null; + end Allocate; + + procedure Allocate + (Container : in out List; + New_Item : Element_Type; + New_Node : out Count_Type) + is + N : Node_Array_Access renames Container.Nodes; + + begin + Allocate (Container, New_Node); + + N (New_Node).Element := new Element_Type'(New_Item); + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out List; New_Item : Element_Type) is + begin + Insert (Container, No_Element, New_Item, 1); + end Append; + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + N : Node_Array_Access renames Source.Nodes; + J : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + Clear (Target); + + J := Source.First; + while J /= 0 loop + Append (Target, N (J).Element.all); + J := N (J).Next; + end loop; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + N : Node_Array_Access renames Container.Nodes; + X : Count_Type; + + begin + if Container.Length = 0 then + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + return; + end if; + + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + while Container.Length > 1 loop + X := Container.First; + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + + X := Container.First; + + Container.First := 0; + Container.Last := 0; + Container.Length := 0; + + Free (Container, X); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : List; + Position : Cursor) return not null access constant Element_Type + is + begin + if not Has_Element (Container => Container, Position => Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return Container.Nodes (Position.Node).Element; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : List) return List + is + N : Count_Type; + P : List; + + begin + if Source.Nodes = null then + return P; + end if; + + P.Nodes := new Node_Array (1 .. Source.Nodes'Length); + + N := 1; + while N <= Source.Nodes'Length loop + P.Nodes (N).Prev := Source.Nodes (N).Prev; + P.Nodes (N).Next := Source.Nodes (N).Next; + if Source.Nodes (N).Element /= null then + P.Nodes (N).Element := + new Element_Type'(Source.Nodes (N).Element.all); + end if; + N := N + 1; + end loop; + + P.Free := Source.Free; + P.Length := Source.Length; + P.First := Source.First; + P.Last := Source.Last; + + return P; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out List; Position : in out Cursor) is + begin + Delete + (Container => Container, + Position => Position, + Count => 1); + end Delete; + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type) + is + N : Node_Array_Access renames Container.Nodes; + X : Count_Type; + + begin + if not Has_Element (Container => Container, + Position => Position) + then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert (Vet (Container, Position), "bad cursor in Delete"); + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := No_Element; + return; + end if; + + if Count = 0 then + Position := No_Element; + return; + end if; + + for Index in 1 .. Count loop + pragma Assert (Container.Length >= 2); + + X := Position.Node; + Container.Length := Container.Length - 1; + + if X = Container.Last then + Position := No_Element; + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Free (Container, X); + return; + end if; + + Position.Node := N (X).Next; + pragma Assert (N (Position.Node).Prev >= 0); + + N (N (X).Next).Prev := N (X).Prev; + N (N (X).Prev).Next := N (X).Next; + + Free (Container, X); + end loop; + + Position := No_Element; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out List) is + begin + Delete_First + (Container => Container, + Count => 1); + end Delete_First; + + procedure Delete_First (Container : in out List; Count : Count_Type) is + N : Node_Array_Access renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + for J in 1 .. Count loop + X := Container.First; + pragma Assert (N (N (X).Next).Prev = Container.First); + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out List) is + begin + Delete_Last + (Container => Container, + Count => 1); + end Delete_Last; + + procedure Delete_Last (Container : in out List; Count : Count_Type) is + N : Node_Array_Access renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + for J in 1 .. Count loop + X := Container.Last; + pragma Assert (N (N (X).Prev).Next = Container.Last); + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element + (Container : List; + Position : Cursor) return Element_Type + is + begin + if not Has_Element (Container => Container, Position => Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return Container.Nodes (Position.Node).Element.all; + end Element; + + ---------------- + -- Empty_List -- + ---------------- + + function Empty_List return List is + ((Controlled with others => <>)); + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out List) is + X : Count_Type := Container.First; + N : Node_Array_Access renames Container.Nodes; + begin + + if N = null then + return; + end if; + + while X /= 0 loop + Finalize_Element (N (X).Element); + X := N (X).Next; + end loop; + + Finalize_Nodes (N); + + Container.Free := 0; + Container.Last := 0; + Container.First := 0; + Container.Length := 0; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + From : Count_Type := Position.Node; + + begin + if From = 0 and Container.Length = 0 then + return No_Element; + end if; + + if From = 0 then + From := Container.First; + end if; + + if Position.Node /= 0 and then not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + while From /= 0 loop + if Container.Nodes (From).Element.all = Item then + return (Node => From); + end if; + + From := Container.Nodes (From).Next; + end loop; + + return No_Element; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = 0 then + return No_Element; + end if; + + return (Node => Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + F : constant Count_Type := Container.First; + begin + if F = 0 then + raise Constraint_Error with "list is empty"; + else + return Container.Nodes (F).Element.all; + end if; + end First_Element; + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ---------------------------- + -- Lift_Abstraction_Level -- + ---------------------------- + + procedure Lift_Abstraction_Level (Container : List) is null; + + ------------------------- + -- M_Elements_In_Union -- + ------------------------- + + function M_Elements_In_Union + (Container : M.Sequence; + Left : M.Sequence; + Right : M.Sequence) return Boolean + is + Elem : Element_Type; + + begin + for Index in 1 .. M.Length (Container) loop + Elem := Element (Container, Index); + + if not M.Contains (Left, 1, M.Length (Left), Elem) + and then not M.Contains (Right, 1, M.Length (Right), Elem) + then + return False; + end if; + end loop; + + return True; + end M_Elements_In_Union; + + ------------------------- + -- M_Elements_Included -- + ------------------------- + + function M_Elements_Included + (Left : M.Sequence; + L_Fst : Positive_Count_Type := 1; + L_Lst : Count_Type; + Right : M.Sequence; + R_Fst : Positive_Count_Type := 1; + R_Lst : Count_Type) return Boolean + is + begin + for I in L_Fst .. L_Lst loop + declare + Found : Boolean := False; + J : Count_Type := R_Fst - 1; + + begin + while not Found and J < R_Lst loop + J := J + 1; + if Element (Left, I) = Element (Right, J) then + Found := True; + end if; + end loop; + + if not Found then + return False; + end if; + end; + end loop; + + return True; + end M_Elements_Included; + + ------------------------- + -- M_Elements_Reversed -- + ------------------------- + + function M_Elements_Reversed + (Left : M.Sequence; + Right : M.Sequence) return Boolean + is + L : constant Count_Type := M.Length (Left); + + begin + if L /= M.Length (Right) then + return False; + end if; + + for I in 1 .. L loop + if Element (Left, I) /= Element (Right, L - I + 1) then + return False; + end if; + end loop; + + return True; + end M_Elements_Reversed; + + ------------------------ + -- M_Elements_Swapped -- + ------------------------ + + function M_Elements_Swapped + (Left : M.Sequence; + Right : M.Sequence; + X : Positive_Count_Type; + Y : Positive_Count_Type) return Boolean + is + begin + if M.Length (Left) /= M.Length (Right) + or else Element (Left, X) /= Element (Right, Y) + or else Element (Left, Y) /= Element (Right, X) + then + return False; + end if; + + for I in 1 .. M.Length (Left) loop + if I /= X and then I /= Y + and then Element (Left, I) /= Element (Right, I) + then + return False; + end if; + end loop; + + return True; + end M_Elements_Swapped; + + ----------- + -- Model -- + ----------- + + function Model (Container : List) return M.Sequence is + Position : Count_Type := Container.First; + R : M.Sequence; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := M.Add (R, Container.Nodes (Position).Element.all); + Position := Container.Nodes (Position).Next; + end loop; + + return R; + end Model; + + ----------------------- + -- Mapping_Preserved -- + ----------------------- + + function Mapping_Preserved + (M_Left : M.Sequence; + M_Right : M.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + is + begin + for C of P_Left loop + if not P.Has_Key (P_Right, C) + or else P.Get (P_Left, C) > M.Length (M_Left) + or else P.Get (P_Right, C) > M.Length (M_Right) + or else M.Get (M_Left, P.Get (P_Left, C)) /= + M.Get (M_Right, P.Get (P_Right, C)) + then + return False; + end if; + end loop; + + for C of P_Right loop + if not P.Has_Key (P_Left, C) then + return False; + end if; + end loop; + + return True; + end Mapping_Preserved; + + ------------------------- + -- P_Positions_Shifted -- + ------------------------- + + function P_Positions_Shifted + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + is + begin + for Cu of Small loop + if not P.Has_Key (Big, Cu) then + return False; + end if; + end loop; + + for Cu of Big loop + declare + Pos : constant Positive_Count_Type := P.Get (Big, Cu); + + begin + if Pos < Cut then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + then + return False; + end if; + + elsif Pos >= Cut + Count then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + Count + then + return False; + end if; + + else + if P.Has_Key (Small, Cu) then + return False; + end if; + end if; + end; + end loop; + + return True; + end P_Positions_Shifted; + + ------------------------- + -- P_Positions_Swapped -- + ------------------------- + + function P_Positions_Swapped + (Left : P.Map; + Right : P.Map; + X : Cursor; + Y : Cursor) return Boolean + is + begin + if not P.Has_Key (Left, X) + or not P.Has_Key (Left, Y) + or not P.Has_Key (Right, X) + or not P.Has_Key (Right, Y) + then + return False; + end if; + + if P.Get (Left, X) /= P.Get (Right, Y) + or P.Get (Left, Y) /= P.Get (Right, X) + then + return False; + end if; + + for C of Left loop + if not P.Has_Key (Right, C) then + return False; + end if; + end loop; + + for C of Right loop + if not P.Has_Key (Left, C) + or else (C /= X + and C /= Y + and P.Get (Left, C) /= P.Get (Right, C)) + then + return False; + end if; + end loop; + + return True; + end P_Positions_Swapped; + + --------------------------- + -- P_Positions_Truncated -- + --------------------------- + + function P_Positions_Truncated + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + is + begin + for Cu of Small loop + if not P.Has_Key (Big, Cu) then + return False; + end if; + end loop; + + for Cu of Big loop + declare + Pos : constant Positive_Count_Type := P.Get (Big, Cu); + + begin + if Pos < Cut then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + then + return False; + end if; + + elsif Pos >= Cut + Count then + return False; + + elsif P.Has_Key (Small, Cu) then + return False; + end if; + end; + end loop; + + return True; + end P_Positions_Truncated; + + --------------- + -- Positions -- + --------------- + + function Positions (Container : List) return P.Map is + I : Count_Type := 1; + Position : Count_Type := Container.First; + R : P.Map; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := P.Add (R, (Node => Position), I); + pragma Assert (P.Length (R) = To_Big_Integer (I)); + Position := Container.Nodes (Position).Next; + I := I + 1; + end loop; + + return R; + end Positions; + + end Formal_Model; + + ---------- + -- Free -- + ---------- + + procedure Free (Container : in out List; X : Count_Type) is + pragma Assert (X > 0); + pragma Assert (X <= Container.Nodes'Length); + + N : Node_Array_Access renames Container.Nodes; + + begin + N (X).Prev := -1; -- Node is deallocated (not on active list) + + if N (X).Element /= null then + Finalize_Element (N (X).Element); + end if; + + if Container.Free >= 0 then + N (X).Next := Container.Free; + Container.Free := X; + elsif X + 1 = abs Container.Free then + N (X).Next := 0; -- Not strictly necessary, but marginally safer + Container.Free := Container.Free + 1; + else + Container.Free := abs Container.Free; + + for J in Container.Free .. Container.Nodes'Length loop + N (J).Next := J + 1; + end loop; + + N (Container.Nodes'Length).Next := 0; + + N (X).Next := Container.Free; + Container.Free := X; + end if; + end Free; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting with SPARK_Mode => Off is + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ----------------------- + -- M_Elements_Sorted -- + ----------------------- + + function M_Elements_Sorted (Container : M.Sequence) return Boolean is + begin + if M.Length (Container) = 0 then + return True; + end if; + + declare + E1 : Element_Type := Element (Container, 1); + + begin + for I in 2 .. M.Length (Container) loop + declare + E2 : constant Element_Type := Element (Container, I); + + begin + if E2 < E1 then + return False; + end if; + + E1 := E2; + end; + end loop; + end; + + return True; + end M_Elements_Sorted; + + end Formal_Model; + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : List) return Boolean is + Nodes : Node_Array_Access renames Container.Nodes; + Node : Count_Type := Container.First; + + begin + for J in 2 .. Container.Length loop + if Nodes (Nodes (Node).Next).Element.all < Nodes (Node).Element.all + then + return False; + else + Node := Nodes (Node).Next; + end if; + end loop; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target : in out List; Source : in out List) is + LN : Node_Array_Access renames Target.Nodes; + RN : Node_Array_Access renames Source.Nodes; + LI : Cursor; + RI : Cursor; + + begin + if Target'Address = Source'Address then + raise Program_Error with "Target and Source denote same container"; + end if; + + LI := First (Target); + RI := First (Source); + while RI.Node /= 0 loop + pragma Assert + (RN (RI.Node).Next = 0 + or else not (RN (RN (RI.Node).Next).Element.all < + RN (RI.Node).Element.all)); + + if LI.Node = 0 then + Splice (Target, No_Element, Source); + return; + end if; + + pragma Assert + (LN (LI.Node).Next = 0 + or else not (LN (LN (LI.Node).Next).Element.all < + LN (LI.Node).Element.all)); + + if RN (RI.Node).Element.all < LN (LI.Node).Element.all then + declare + RJ : Cursor := RI; + pragma Warnings (Off, RJ); + begin + RI.Node := RN (RI.Node).Next; + Splice (Target, LI, Source, RJ); + end; + + else + LI.Node := LN (LI.Node).Next; + end if; + end loop; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out List) is + N : Node_Array_Access renames Container.Nodes; + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + declare + package Descriptors is new List_Descriptors + (Node_Ref => Count_Type, Nil => 0); + use Descriptors; + + function Next (Idx : Count_Type) return Count_Type is + (N (Idx).Next); + procedure Set_Next (Idx : Count_Type; Next : Count_Type) + with Inline; + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) + with Inline; + function "<" (L, R : Count_Type) return Boolean is + (N (L).Element.all < N (R).Element.all); + procedure Update_Container (List : List_Descriptor) with Inline; + + procedure Set_Next (Idx : Count_Type; Next : Count_Type) is + begin + N (Idx).Next := Next; + end Set_Next; + + procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is + begin + N (Idx).Prev := Prev; + end Set_Prev; + + procedure Update_Container (List : List_Descriptor) is + begin + Container.First := List.First; + Container.Last := List.Last; + Container.Length := List.Length; + end Update_Container; + + procedure Sort_List is new Doubly_Linked_List_Sort; + begin + Sort_List (List_Descriptor'(First => Container.First, + Last => Container.Last, + Length => Container.Length)); + end; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Sort; + + end Generic_Sorting; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Container : List; Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return False; + end if; + + return Container.Nodes (Position.Node).Prev /= -1; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type) + is + J : Count_Type; + + begin + if Before.Node /= 0 then + pragma Assert (Vet (Container, Before), "bad cursor in Insert"); + end if; + + if Count = 0 then + Position := Before; + return; + end if; + Allocate (Container, New_Item, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + Position := (Node => J); + + for Index in 2 .. Count loop + Allocate (Container, New_Item, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + end loop; + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor) + is + begin + Insert + (Container => Container, + Before => Before, + New_Item => New_Item, + Position => Position, + Count => 1); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type) + is + Position : Cursor; + + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type) + is + Position : Cursor; + + begin + Insert (Container, Before, New_Item, Position, 1); + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List; + Before : Count_Type; + New_Node : Count_Type) + is + N : Node_Array_Access renames Container.Nodes; + + begin + if Container.Length = 0 then + pragma Assert (Before = 0); + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + + Container.First := New_Node; + Container.Last := New_Node; + + N (Container.First).Prev := 0; + N (Container.Last).Next := 0; + + elsif Before = 0 then + pragma Assert (N (Container.Last).Next = 0); + + N (Container.Last).Next := New_Node; + N (New_Node).Prev := Container.Last; + + Container.Last := New_Node; + N (Container.Last).Next := 0; + + elsif Before = Container.First then + pragma Assert (N (Container.First).Prev = 0); + + N (Container.First).Prev := New_Node; + N (New_Node).Next := Container.First; + + Container.First := New_Node; + N (Container.First).Prev := 0; + + else + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + N (New_Node).Next := Before; + N (New_Node).Prev := N (Before).Prev; + + N (N (Before).Prev).Next := New_Node; + N (Before).Prev := New_Node; + end if; + Container.Length := Container.Length + 1; + end Insert_Internal; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : List) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = 0 then + return No_Element; + end if; + + return (Node => Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + L : constant Count_Type := Container.Last; + + begin + if L = 0 then + raise Constraint_Error with "list is empty"; + else + return Container.Nodes (L).Element.all; + end if; + end Last_Element; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out List; Source : in out List) is + N : Node_Array_Access renames Source.Nodes; + + procedure Finalize_Node_Array is new Ada.Unchecked_Deallocation + (Object => Node_Array, + Name => Node_Array_Access); + + begin + if Target'Address = Source'Address then + return; + end if; + + Clear (Target); + + if Source.Length = 0 then + return; + end if; + + -- Make sure that Target is large enough + + if Target.Nodes = null + or else Target.Nodes'Length < Source.Length + then + if Target.Nodes /= null then + Finalize_Node_Array (Target.Nodes); + end if; + Target.Nodes := new Node_Array (1 .. Source.Length); + end if; + + -- Copy first element from Source to Target + + Target.First := 1; + + Target.Nodes (1).Prev := 0; + Target.Nodes (1).Element := N (Source.First).Element; + N (Source.First).Element := null; + + -- Copy the other elements + + declare + X_Src : Count_Type := N (Source.First).Next; + X_Tar : Count_Type := 2; + + begin + while X_Src /= 0 loop + Target.Nodes (X_Tar).Prev := X_Tar - 1; + Target.Nodes (X_Tar - 1).Next := X_Tar; + + Target.Nodes (X_Tar).Element := N (X_Src).Element; + N (X_Src).Element := null; + + X_Src := N (X_Src).Next; + X_Tar := X_Tar + 1; + end loop; + end; + + Target.Last := Source.Length; + Target.Length := Source.Length; + Target.Nodes (Target.Last).Next := 0; + + -- Set up the free list + + Target.Free := -Source.Length - 1; + + -- It is possible to Clear Source because the Element accesses were + -- set to null. + + Clear (Source); + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Container : List; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + function Next (Container : List; Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Program_Error with "Position cursor has no element"; + end if; + + return (Node => Container.Nodes (Position.Node).Next); + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Container : in out List; New_Item : Element_Type) is + begin + Insert (Container, First (Container), New_Item, 1); + end Prepend; + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + is + begin + Insert (Container, First (Container), New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Container : List; Position : in out Cursor) is + begin + Position := Previous (Container, Position); + end Previous; + + function Previous (Container : List; Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Program_Error with "Position cursor has no element"; + end if; + + return (Node => Container.Nodes (Position.Node).Prev); + end Previous; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : not null access List; + Position : Cursor) return not null access Element_Type + is + begin + if not Has_Element (Container.all, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return Container.Nodes (Position.Node).Element; + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) + is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert + (Vet (Container, Position), "bad cursor in Replace_Element"); + + Finalize_Element (Container.Nodes (Position.Node).Element); + Container.Nodes (Position.Node).Element := new Element_Type'(New_Item); + end Replace_Element; + + ------------ + -- Resize -- + ------------ + + procedure Resize (Container : in out List) is + Min_Size : constant Count_Type := 100; + begin + if Container.Nodes = null then + Container.Nodes := new Node_Array (1 .. Min_Size); + Container.First := 0; + Container.Last := 0; + Container.Length := 0; + Container.Free := -1; + + return; + end if; + + if Container.Length /= Container.Nodes'Length then + raise Program_Error with "List must be at size max to resize"; + end if; + + declare + procedure Finalize_Node_Array is new Ada.Unchecked_Deallocation + (Object => Node_Array, + Name => Node_Array_Access); + + New_Size : constant Count_Type := + (if Container.Nodes'Length > Count_Type'Last / 2 + then Count_Type'Last + else 2 * Container.Nodes'Length); + New_Nodes : Node_Array_Access; + + begin + New_Nodes := + new Node_Array (1 .. Count_Type'Max (New_Size, Min_Size)); + + New_Nodes (1 .. Container.Nodes'Length) := + Container.Nodes (1 .. Container.Nodes'Length); + + Container.Free := -Container.Nodes'Length - 1; + + Finalize_Node_Array (Container.Nodes); + Container.Nodes := New_Nodes; + end; + end Resize; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out List) is + N : Node_Array_Access renames Container.Nodes; + I : Count_Type := Container.First; + J : Count_Type := Container.Last; + + procedure Swap (L : Count_Type; R : Count_Type); + + ---------- + -- Swap -- + ---------- + + procedure Swap (L : Count_Type; R : Count_Type) is + LN : constant Count_Type := N (L).Next; + LP : constant Count_Type := N (L).Prev; + + RN : constant Count_Type := N (R).Next; + RP : constant Count_Type := N (R).Prev; + + begin + if LP /= 0 then + N (LP).Next := R; + end if; + + if RN /= 0 then + N (RN).Prev := L; + end if; + + N (L).Next := RN; + N (R).Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + N (L).Prev := R; + N (R).Next := L; + + else + N (L).Prev := RP; + N (RP).Next := L; + + N (R).Next := LN; + N (LN).Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_Elements + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + Container.First := J; + Container.Last := I; + loop + Swap (L => I, R => J); + + J := N (J).Next; + exit when I = J; + + I := N (I).Prev; + exit when I = J; + + Swap (L => J, R => I); + + I := N (I).Next; + exit when I = J; + + J := N (J).Prev; + exit when I = J; + end loop; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + CFirst : Count_Type := Position.Node; + + begin + if CFirst = 0 then + CFirst := Container.Last; + end if; + + if Container.Length = 0 then + return No_Element; + else + while CFirst /= 0 loop + if Container.Nodes (CFirst).Element.all = Item then + return (Node => CFirst); + else + CFirst := Container.Nodes (CFirst).Prev; + end if; + end loop; + + return No_Element; + end if; + end Reverse_Find; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + SN : Node_Array_Access renames Source.Nodes; + TN : Node_Array_Access renames Target.Nodes; + + begin + if Target'Address = Source'Address then + raise Program_Error with "Target and Source denote same container"; + end if; + + if Before.Node /= 0 then + pragma Assert (Vet (Target, Before), "bad cursor in Splice"); + end if; + + if Is_Empty (Source) then + return; + end if; + + pragma Assert (SN (Source.First).Prev = 0); + pragma Assert (SN (Source.Last).Next = 0); + + declare + X : Count_Type; + + begin + while not Is_Empty (Source) loop + Allocate (Target, X); + + TN (X).Element := SN (Source.Last).Element; + + -- Insert the new node in Target + + Insert_Internal (Target, Before.Node, X); + + -- Free the last node of Source + + SN (Source.Last).Element := null; + Delete_Last (Source); + end loop; + end; + + end Splice; + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor) + is + begin + if Target'Address = Source'Address then + raise Program_Error with "Target and Source denote same container"; + end if; + + if Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert (Vet (Source, Position), "bad Position cursor in Splice"); + + declare + X : Count_Type; + + begin + Allocate (Target, X); + + Target.Nodes (X).Element := Source.Nodes (Position.Node).Element; + + -- Insert the new node in Target + + Insert_Internal (Target, Before.Node, X); + + -- Free the node at position Position in Source + + Source.Nodes (Position.Node).Element := null; + Delete (Source, Position); + + Position := (Node => X); + end; + end Splice; + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + is + N : Node_Array_Access renames Container.Nodes; + + begin + if Before.Node /= 0 then + pragma Assert + (Vet (Container, Before), "bad Before cursor in Splice"); + end if; + + if Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert + (Vet (Container, Position), "bad Position cursor in Splice"); + + if Position.Node = Before.Node + or else N (Position.Node).Next = Before.Node + then + return; + end if; + + pragma Assert (Container.Length >= 2); + + if Before.Node = 0 then + pragma Assert (Position.Node /= Container.Last); + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.Last).Next := Position.Node; + N (Position.Node).Prev := Container.Last; + + Container.Last := Position.Node; + N (Container.Last).Next := 0; + + return; + end if; + + if Before.Node = Container.First then + pragma Assert (Position.Node /= Container.First); + + if Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.First).Prev := Position.Node; + N (Position.Node).Next := Container.First; + + Container.First := Position.Node; + N (Container.First).Prev := 0; + + return; + end if; + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + elsif Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (N (Before.Node).Prev).Next := Position.Node; + N (Position.Node).Prev := N (Before.Node).Prev; + + N (Before.Node).Prev := Position.Node; + N (Position.Node).Next := Before.Node; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Splice; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + I : Cursor; + J : Cursor) + is + begin + if I.Node = 0 then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Node = J.Node then + return; + end if; + + pragma Assert (Vet (Container, I), "bad I cursor in Swap"); + pragma Assert (Vet (Container, J), "bad J cursor in Swap"); + + declare + NN : Node_Array_Access renames Container.Nodes; + NI : Node_Type renames NN (I.Node); + NJ : Node_Type renames NN (J.Node); + + EI_Copy : constant Element_Access := NI.Element; + + begin + NI.Element := NJ.Element; + NJ.Element := EI_Copy; + end; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I : Cursor; + J : Cursor) + is + I_Next : Cursor; + J_Next : Cursor; + + begin + if I.Node = 0 then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Node = J.Node then + return; + end if; + + pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links"); + + I_Next := Next (Container, I); + + if I_Next = J then + Splice (Container, Before => I, Position => J); + + else + J_Next := Next (Container, J); + + if J_Next = I then + Splice (Container, Before => J, Position => I); + + else + pragma Assert (Container.Length >= 3); + Splice (Container, Before => I_Next, Position => J); + Splice (Container, Before => J_Next, Position => I); + end if; + end if; + end Swap_Links; + + --------- + -- Vet -- + --------- + + function Vet (L : List; Position : Cursor) return Boolean is + N : Node_Array_Access renames L.Nodes; + begin + if not Container_Checks'Enabled then + return True; + end if; + + if L.Length = 0 then + return False; + end if; + + if L.First = 0 then + return False; + end if; + + if L.Last = 0 then + return False; + end if; + + if Position.Node > L.Nodes'Length then + return False; + end if; + + if N (Position.Node).Prev < 0 + or else N (Position.Node).Prev > L.Nodes'Length + then + return False; + end if; + + if N (Position.Node).Next > L.Nodes'Length then + return False; + end if; + + if N (L.First).Prev /= 0 then + return False; + end if; + + if N (L.Last).Next /= 0 then + return False; + end if; + + if N (Position.Node).Prev = 0 and then Position.Node /= L.First then + return False; + end if; + + if N (Position.Node).Next = 0 and then Position.Node /= L.Last then + return False; + end if; + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if N (L.First).Next = 0 then + return False; + end if; + + if N (L.Last).Prev = 0 then + return False; + end if; + + if N (N (L.First).Next).Prev /= L.First then + return False; + end if; + + if N (N (L.Last).Prev).Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if N (L.First).Next /= L.Last then + return False; + end if; + + if N (L.Last).Prev /= L.First then + return False; + end if; + + return True; + end if; + + if N (L.First).Next = L.Last then + return False; + end if; + + if N (L.Last).Prev = L.First then + return False; + end if; + + if Position.Node = L.First then + return True; + end if; + + if Position.Node = L.Last then + return True; + end if; + + if N (Position.Node).Next = 0 then + return False; + end if; + + if N (Position.Node).Prev = 0 then + return False; + end if; + + if N (N (Position.Node).Next).Prev /= Position.Node then + return False; + end if; + + if N (N (Position.Node).Prev).Next /= Position.Node then + return False; + end if; + + if L.Length = 3 then + if N (L.First).Next /= Position.Node then + return False; + end if; + + if N (L.Last).Prev /= Position.Node then + return False; + end if; + end if; + + return True; + end Vet; + +end Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfidll.ads b/gcc/ada/libgnat/a-cfidll.ads new file mode 100644 index 0000000..c4d244a --- /dev/null +++ b/gcc/ada/libgnat/a-cfidll.ads @@ -0,0 +1,1670 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FORMAL_INDEFINITE_DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-2022, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Functional_Vectors; +with Ada.Containers.Functional_Maps; +private with Ada.Finalization; + +generic + type Element_Type is private; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with + SPARK_Mode +is + -- Contracts in this unit are meant for analysis only, not for run-time + -- checking. + + pragma Assertion_Policy (Pre => Ignore); + pragma Assertion_Policy (Post => Ignore); + pragma Assertion_Policy (Contract_Cases => Ignore); + pragma Annotate (CodePeer, Skip_Analysis); + + type List is private with + Iterable => (First => First, + Next => Next, + Has_Element => Has_Element, + Element => Element), + Default_Initial_Condition => Is_Empty (List); + + type Cursor is record + Node : Count_Type := 0; + end record; + + No_Element : constant Cursor := Cursor'(Node => 0); + + function Length (Container : List) return Count_Type with + Global => null; + + function Empty_List return List with + Global => null, + Post => Length (Empty_List'Result) = 0; + + pragma Unevaluated_Use_Of_Old (Allow); + + package Formal_Model with Ghost is + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + + package M is new Ada.Containers.Functional_Vectors + (Index_Type => Positive_Count_Type, + Element_Type => Element_Type); + + function "=" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."="; + + function "<" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."<"; + + function "<=" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."<="; + + function M_Elements_In_Union + (Container : M.Sequence; + Left : M.Sequence; + Right : M.Sequence) return Boolean + -- The elements of Container are contained in either Left or Right + with + Global => null, + Post => + M_Elements_In_Union'Result = + (for all I in 1 .. M.Length (Container) => + (for some J in 1 .. M.Length (Left) => + Element (Container, I) = Element (Left, J)) + or (for some J in 1 .. M.Length (Right) => + Element (Container, I) = Element (Right, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); + + function M_Elements_Included + (Left : M.Sequence; + L_Fst : Positive_Count_Type := 1; + L_Lst : Count_Type; + Right : M.Sequence; + R_Fst : Positive_Count_Type := 1; + R_Lst : Count_Type) return Boolean + -- The elements of the slice from L_Fst to L_Lst in Left are contained + -- in the slide from R_Fst to R_Lst in Right. + with + Global => null, + Pre => L_Lst <= M.Length (Left) and R_Lst <= M.Length (Right), + Post => + M_Elements_Included'Result = + (for all I in L_Fst .. L_Lst => + (for some J in R_Fst .. R_Lst => + Element (Left, I) = Element (Right, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); + + function M_Elements_Reversed + (Left : M.Sequence; + Right : M.Sequence) return Boolean + -- Right is Left in reverse order + with + Global => null, + Post => + M_Elements_Reversed'Result = + (M.Length (Left) = M.Length (Right) + and (for all I in 1 .. M.Length (Left) => + Element (Left, I) = + Element (Right, M.Length (Left) - I + 1)) + and (for all I in 1 .. M.Length (Left) => + Element (Right, I) = + Element (Left, M.Length (Left) - I + 1))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); + + function M_Elements_Swapped + (Left : M.Sequence; + Right : M.Sequence; + X : Positive_Count_Type; + Y : Positive_Count_Type) return Boolean + -- Elements stored at X and Y are reversed in Left and Right + with + Global => null, + Pre => X <= M.Length (Left) and Y <= M.Length (Left), + Post => + M_Elements_Swapped'Result = + (M.Length (Left) = M.Length (Right) + and Element (Left, X) = Element (Right, Y) + and Element (Left, Y) = Element (Right, X) + and M.Equal_Except (Left, Right, X, Y)); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); + + package P is new Ada.Containers.Functional_Maps + (Key_Type => Cursor, + Element_Type => Positive_Count_Type, + Equivalent_Keys => "=", + Enable_Handling_Of_Equivalence => False); + + function "=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."="; + + function "<=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."<="; + + function P_Positions_Shifted + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + with + Global => null, + Post => + P_Positions_Shifted'Result = + + -- Big contains all cursors of Small + + (P.Keys_Included (Small, Big) + + -- Cursors located before Cut are not moved, cursors located + -- after are shifted by Count. + + and (for all I of Small => + (if P.Get (Small, I) < Cut then + P.Get (Big, I) = P.Get (Small, I) + else + P.Get (Big, I) - Count = P.Get (Small, I))) + + -- New cursors of Big (if any) are between Cut and Cut - 1 + + -- Count. + + and (for all I of Big => + P.Has_Key (Small, I) + or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); + + function P_Positions_Swapped + (Left : P.Map; + Right : P.Map; + X : Cursor; + Y : Cursor) return Boolean + -- Left and Right contain the same cursors, but the positions of X and Y + -- are reversed. + with + Ghost, + Global => null, + Post => + P_Positions_Swapped'Result = + (P.Same_Keys (Left, Right) + and P.Elements_Equal_Except (Left, Right, X, Y) + and P.Has_Key (Left, X) + and P.Has_Key (Left, Y) + and P.Get (Left, X) = P.Get (Right, Y) + and P.Get (Left, Y) = P.Get (Right, X)); + + function P_Positions_Truncated + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + with + Ghost, + Global => null, + Post => + P_Positions_Truncated'Result = + + -- Big contains all cursors of Small at the same position + + (Small <= Big + + -- New cursors of Big (if any) are between Cut and Cut - 1 + + -- Count. + + and (for all I of Big => + P.Has_Key (Small, I) + or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); + + function Mapping_Preserved + (M_Left : M.Sequence; + M_Right : M.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + with + Ghost, + Global => null, + Post => + (if Mapping_Preserved'Result then + + -- Left and Right contain the same cursors + + P.Same_Keys (P_Left, P_Right) + + -- Mappings from cursors to elements induced by M_Left, P_Left + -- and M_Right, P_Right are the same. + + and (for all C of P_Left => + M.Get (M_Left, P.Get (P_Left, C)) = + M.Get (M_Right, P.Get (P_Right, C)))); + + function Model (Container : List) return M.Sequence with + -- The high-level model of a list is a sequence of elements. Cursors are + -- not represented in this model. + + Ghost, + Global => null, + Post => M.Length (Model'Result) = Length (Container); + pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model); + + function Positions (Container : List) return P.Map with + -- The Positions map is used to model cursors. It only contains valid + -- cursors and map them to their position in the container. + + Ghost, + Global => null, + Post => + not P.Has_Key (Positions'Result, No_Element) + + -- Positions of cursors are smaller than the container's length + + and then + (for all I of Positions'Result => + P.Get (Positions'Result, I) in 1 .. Length (Container) + + -- No two cursors have the same position. Note that we do not + -- state that there is a cursor in the map for each position, as + -- it is rarely needed. + + and then + (for all J of Positions'Result => + (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) + then I = J))); + + procedure Lift_Abstraction_Level (Container : List) with + -- Lift_Abstraction_Level is a ghost procedure that does nothing but + -- assume that we can access to the same elements by iterating over + -- positions or cursors. + -- This information is not generally useful except when switching from + -- a low-level cursor-aware view of a container to a high-level + -- position-based view. + + Ghost, + Global => null, + Post => + (for all Elt of Model (Container) => + (for some I of Positions (Container) => + M.Get (Model (Container), P.Get (Positions (Container), I)) = + Elt)); + + function Element + (S : M.Sequence; + I : Count_Type) return Element_Type renames M.Get; + -- To improve readability of contracts, we rename the function used to + -- access an element in the model to Element. + + end Formal_Model; + use Formal_Model; + + function "=" (Left, Right : List) return Boolean with + Global => null, + Post => "="'Result = (Model (Left) = Model (Right)); + + function Is_Empty (Container : List) return Boolean with + Global => null, + Post => Is_Empty'Result = (Length (Container) = 0); + + procedure Clear (Container : in out List) with + Global => null, + Post => Length (Container) = 0; + + procedure Assign (Target : in out List; Source : List) with + Global => null, + Post => Model (Target) = Model (Source); + + function Copy (Source : List) return List with + Global => null, + Post => + Model (Copy'Result) = Model (Source) + and Positions (Copy'Result) = Positions (Source); + + function Element + (Container : List; + Position : Cursor) return Element_Type + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Element'Result = + Element (Model (Container), P.Get (Positions (Container), Position)); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Length (Container) = Length (Container)'Old + + -- Cursors are preserved + + and Positions (Container)'Old = Positions (Container) + + -- The element at the position of Position in Container is New_Item + + and Element + (Model (Container), + P.Get (Positions (Container), Position)) = New_Item + + -- Other elements are preserved + + and M.Equal_Except + (Model (Container)'Old, + Model (Container), + P.Get (Positions (Container), Position)); + + function At_End (E : access constant List) return access constant List + is (E) + with Ghost, + Annotate => (GNATprove, At_End_Borrow); + + function At_End + (E : access constant Element_Type) return access constant Element_Type + is (E) + with Ghost, + Annotate => (GNATprove, At_End_Borrow); + + function Constant_Reference + (Container : List; + Position : Cursor) return not null access constant Element_Type + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Constant_Reference'Result.all = + Element (Model (Container), P.Get (Positions (Container), Position)); + + function Reference + (Container : not null access List; + Position : Cursor) return not null access Element_Type + with + Global => null, + Pre => Has_Element (Container.all, Position), + Post => + Length (Container.all) = Length (At_End (Container).all) + + -- Cursors are preserved + + and Positions (Container.all) = Positions (At_End (Container).all) + + -- Container will have Result.all at position Position + + and At_End (Reference'Result).all = + Element (Model (At_End (Container).all), + P.Get (Positions (At_End (Container).all), Position)) + + -- All other elements are preserved + + and M.Equal_Except + (Model (Container.all), + Model (At_End (Container).all), + P.Get (Positions (At_End (Container).all), Position)); + + procedure Move (Target : in out List; Source : in out List) with + Global => null, + Post => Model (Target) = Model (Source'Old) and Length (Source) = 0; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type) + with + Global => null, + Pre => + Length (Container) < Count_Type'Last + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => Length (Container) = Length (Container)'Old + 1, + Contract_Cases => + (Before = No_Element => + + -- Positions contains a new mapping from the last cursor of + -- Container to its length. + + P.Get (Positions (Container), Last (Container)) = Length (Container) + + -- Other cursors come from Container'Old + + and P.Keys_Included_Except + (Left => Positions (Container), + Right => Positions (Container)'Old, + New_Key => Last (Container)) + + -- Cursors of Container'Old keep the same position + + and Positions (Container)'Old <= Positions (Container) + + -- Model contains a new element New_Item at the end + + and Element (Model (Container), Length (Container)) = New_Item + + -- Elements of Container'Old are preserved + + and Model (Container)'Old <= Model (Container), + + others => + + -- The elements of Container located before Before are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Before) - 1) + + -- Other elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before), + Lst => Length (Container)'Old, + Offset => 1) + + -- New_Item is stored at the previous position of Before in + -- Container. + + and Element + (Model (Container), + P.Get (Positions (Container)'Old, Before)) = New_Item + + -- A new cursor has been inserted at position Before in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container)'Old, Before))); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => + Length (Container) <= Count_Type'Last - Count + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => Length (Container) = Length (Container)'Old + Count, + Contract_Cases => + (Before = No_Element => + + -- The elements of Container are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => Length (Container)'Old) + + -- Container contains Count times New_Item at the end + + and (if Count > 0 then + M.Constant_Range + (Container => Model (Container), + Fst => Length (Container)'Old + 1, + Lst => Length (Container), + Item => New_Item)) + + -- Count cursors have been inserted at the end of Container + + and P_Positions_Truncated + (Positions (Container)'Old, + Positions (Container), + Cut => Length (Container)'Old + 1, + Count => Count), + + others => + + -- The elements of Container located before Before are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Before) - 1) + + -- Other elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before), + Lst => Length (Container)'Old, + Offset => Count) + + -- Container contains Count times New_Item after position Before + + and M.Constant_Range + (Container => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before), + Lst => + P.Get (Positions (Container)'Old, Before) - 1 + Count, + Item => New_Item) + + -- Count cursors have been inserted at position Before in + -- Container. + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container)'Old, Before), + Count => Count)); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor) + with + Global => null, + Pre => + Length (Container) < Count_Type'Last + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Positions is valid in Container and it is located either before + -- Before if it is valid in Container or at the end if it is + -- No_Element. + + and P.Has_Key (Positions (Container), Position) + and (if Before = No_Element then + P.Get (Positions (Container), Position) = Length (Container) + else + P.Get (Positions (Container), Position) = + P.Get (Positions (Container)'Old, Before)) + + -- The elements of Container located before Position are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container), Position) - 1) + + -- Other elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container), Position), + Lst => Length (Container)'Old, + Offset => 1) + + -- New_Item is stored at Position in Container + + and Element + (Model (Container), + P.Get (Positions (Container), Position)) = New_Item + + -- A new cursor has been inserted at position Position in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container), Position)); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type) + with + Global => null, + Pre => + Length (Container) <= Count_Type'Last - Count + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => Length (Container) = Length (Container)'Old + Count, + Contract_Cases => + (Count = 0 => + Position = Before + and Model (Container) = Model (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + others => + + -- Positions is valid in Container and it is located either before + -- Before if it is valid in Container or at the end if it is + -- No_Element. + + P.Has_Key (Positions (Container), Position) + and (if Before = No_Element then + P.Get (Positions (Container), Position) = + Length (Container)'Old + 1 + else + P.Get (Positions (Container), Position) = + P.Get (Positions (Container)'Old, Before)) + + -- The elements of Container located before Position are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container), Position) - 1) + + -- Other elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container), Position), + Lst => Length (Container)'Old, + Offset => Count) + + -- Container contains Count times New_Item after position Position + + and M.Constant_Range + (Container => Model (Container), + Fst => P.Get (Positions (Container), Position), + Lst => + P.Get (Positions (Container), Position) - 1 + Count, + Item => New_Item) + + -- Count cursor have been inserted at Position in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container), Position), + Count => Count)); + + procedure Prepend (Container : in out List; New_Item : Element_Type) with + Global => null, + Pre => Length (Container) < Count_Type'Last, + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => Length (Container)'Old, + Offset => 1) + + -- New_Item is the first element of Container + + and Element (Model (Container), 1) = New_Item + + -- A new cursor has been inserted at the beginning of Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => 1); + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => Length (Container) <= Count_Type'Last - Count, + Post => + Length (Container) = Length (Container)'Old + Count + + -- Elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => Length (Container)'Old, + Offset => Count) + + -- Container starts with Count times New_Item + + and M.Constant_Range + (Container => Model (Container), + Fst => 1, + Lst => Count, + Item => New_Item) + + -- Count cursors have been inserted at the beginning of Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => 1, + Count => Count); + + procedure Append (Container : in out List; New_Item : Element_Type) with + Global => null, + Pre => Length (Container) < Count_Type'Last, + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Positions contains a new mapping from the last cursor of Container + -- to its length. + + and P.Get (Positions (Container), Last (Container)) = + Length (Container) + + -- Other cursors come from Container'Old + + and P.Keys_Included_Except + (Left => Positions (Container), + Right => Positions (Container)'Old, + New_Key => Last (Container)) + + -- Cursors of Container'Old keep the same position + + and Positions (Container)'Old <= Positions (Container) + + -- Model contains a new element New_Item at the end + + and Element (Model (Container), Length (Container)) = New_Item + + -- Elements of Container'Old are preserved + + and Model (Container)'Old <= Model (Container); + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => Length (Container) <= Count_Type'Last - Count, + Post => + Length (Container) = Length (Container)'Old + Count + + -- The elements of Container are preserved + + and Model (Container)'Old <= Model (Container) + + -- Container contains Count times New_Item at the end + + and (if Count > 0 then + M.Constant_Range + (Container => Model (Container), + Fst => Length (Container)'Old + 1, + Lst => Length (Container), + Item => New_Item)) + + -- Count cursors have been inserted at the end of Container + + and P_Positions_Truncated + (Positions (Container)'Old, + Positions (Container), + Cut => Length (Container)'Old + 1, + Count => Count); + + procedure Delete (Container : in out List; Position : in out Cursor) with + Global => null, + Depends => (Container =>+ Position, Position => null), + Pre => Has_Element (Container, Position), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Position is set to No_Element + + and Position = No_Element + + -- The elements of Container located before Position are preserved. + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) + + -- The elements located after Position are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => P.Get (Positions (Container)'Old, Position'Old), + Lst => Length (Container), + Offset => 1) + + -- Position has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => P.Get (Positions (Container)'Old, Position'Old)); + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type) + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Length (Container) in + Length (Container)'Old - Count .. Length (Container)'Old + + -- Position is set to No_Element + + and Position = No_Element + + -- The elements of Container located before Position are preserved. + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Position'Old) - 1), + + Contract_Cases => + + -- All the elements after Position have been erased + + (Length (Container) - Count < P.Get (Positions (Container), Position) => + Length (Container) = + P.Get (Positions (Container)'Old, Position'Old) - 1 + + -- At most Count cursors have been removed at the end of Container + + and P_Positions_Truncated + (Positions (Container), + Positions (Container)'Old, + Cut => P.Get (Positions (Container)'Old, Position'Old), + Count => Count), + + others => + Length (Container) = Length (Container)'Old - Count + + -- Other elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => P.Get (Positions (Container)'Old, Position'Old), + Lst => Length (Container), + Offset => Count) + + -- Count cursors have been removed from Container at Position + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => P.Get (Positions (Container)'Old, Position'Old), + Count => Count)); + + procedure Delete_First (Container : in out List) with + Global => null, + Pre => not Is_Empty (Container), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- The elements of Container are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => 1, + Lst => Length (Container), + Offset => 1) + + -- The first cursor of Container has been removed + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => 1); + + procedure Delete_First (Container : in out List; Count : Count_Type) with + Global => null, + Contract_Cases => + + -- All the elements of Container have been erased + + (Length (Container) <= Count => + Length (Container) = 0, + + others => + Length (Container) = Length (Container)'Old - Count + + -- Elements of Container are shifted by Count + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => 1, + Lst => Length (Container), + Offset => Count) + + -- The first Count cursors have been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => 1, + Count => Count)); + + procedure Delete_Last (Container : in out List) with + Global => null, + Pre => not Is_Empty (Container), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- The elements of Container are preserved + + and Model (Container) <= Model (Container)'Old + + -- The last cursor of Container has been removed + + and not P.Has_Key (Positions (Container), Last (Container)'Old) + + -- Other cursors are still valid + + and P.Keys_Included_Except + (Left => Positions (Container)'Old, + Right => Positions (Container)'Old, + New_Key => Last (Container)'Old) + + -- The positions of other cursors are preserved + + and Positions (Container) <= Positions (Container)'Old; + + procedure Delete_Last (Container : in out List; Count : Count_Type) with + Global => null, + Contract_Cases => + + -- All the elements of Container have been erased + + (Length (Container) <= Count => + Length (Container) = 0, + + others => + Length (Container) = Length (Container)'Old - Count + + -- The elements of Container are preserved + + and Model (Container) <= Model (Container)'Old + + -- At most Count cursors have been removed at the end of Container + + and P_Positions_Truncated + (Positions (Container), + Positions (Container)'Old, + Cut => Length (Container) + 1, + Count => Count)); + + procedure Reverse_Elements (Container : in out List) with + Global => null, + Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); + + procedure Swap + (Container : in out List; + I : Cursor; + J : Cursor) + with + Global => null, + Pre => Has_Element (Container, I) and then Has_Element (Container, J), + Post => + M_Elements_Swapped + (Model (Container)'Old, + Model (Container), + X => P.Get (Positions (Container)'Old, I), + Y => P.Get (Positions (Container)'Old, J)) + + and Positions (Container) = Positions (Container)'Old; + + procedure Swap_Links + (Container : in out List; + I : Cursor; + J : Cursor) + with + Global => null, + Pre => Has_Element (Container, I) and then Has_Element (Container, J), + Post => + M_Elements_Swapped + (Model (Container'Old), + Model (Container), + X => P.Get (Positions (Container)'Old, I), + Y => P.Get (Positions (Container)'Old, J)) + and P_Positions_Swapped + (Positions (Container)'Old, Positions (Container), I, J); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + -- Target and Source should not be aliased + with + Global => null, + Pre => + Length (Source) <= Count_Type'Last - Length (Target) + and then (Has_Element (Target, Before) or else Before = No_Element), + Post => + Length (Source) = 0 + and Length (Target) = Length (Target)'Old + Length (Source)'Old, + Contract_Cases => + (Before = No_Element => + + -- The elements of Target are preserved + + M.Range_Equal + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => 1, + Lst => Length (Target)'Old) + + -- The elements of Source are appended to target, the order is not + -- specified. + + and M_Elements_Included + (Left => Model (Source)'Old, + L_Lst => Length (Source)'Old, + Right => Model (Target), + R_Fst => Length (Target)'Old + 1, + R_Lst => Length (Target)) + + and M_Elements_Included + (Left => Model (Target), + L_Fst => Length (Target)'Old + 1, + L_Lst => Length (Target), + Right => Model (Source)'Old, + R_Lst => Length (Source)'Old) + + -- Cursors have been inserted at the end of Target + + and P_Positions_Truncated + (Positions (Target)'Old, + Positions (Target), + Cut => Length (Target)'Old + 1, + Count => Length (Source)'Old), + + others => + + -- The elements of Target located before Before are preserved + + M.Range_Equal + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => 1, + Lst => P.Get (Positions (Target)'Old, Before) - 1) + + -- The elements of Source are inserted before Before, the order is + -- not specified. + + and M_Elements_Included + (Left => Model (Source)'Old, + L_Lst => Length (Source)'Old, + Right => Model (Target), + R_Fst => P.Get (Positions (Target)'Old, Before), + R_Lst => + P.Get (Positions (Target)'Old, Before) - 1 + + Length (Source)'Old) + + and M_Elements_Included + (Left => Model (Target), + L_Fst => P.Get (Positions (Target)'Old, Before), + L_Lst => + P.Get (Positions (Target)'Old, Before) - 1 + + Length (Source)'Old, + Right => Model (Source)'Old, + R_Lst => Length (Source)'Old) + + -- Other elements are shifted by the length of Source + + and M.Range_Shifted + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => P.Get (Positions (Target)'Old, Before), + Lst => Length (Target)'Old, + Offset => Length (Source)'Old) + + -- Cursors have been inserted at position Before in Target + + and P_Positions_Shifted + (Positions (Target)'Old, + Positions (Target), + Cut => P.Get (Positions (Target)'Old, Before), + Count => Length (Source)'Old)); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor) + -- Target and Source should not be aliased + with + Global => null, + Pre => + (Has_Element (Target, Before) or else Before = No_Element) + and then Has_Element (Source, Position) + and then Length (Target) < Count_Type'Last, + Post => + Length (Target) = Length (Target)'Old + 1 + and Length (Source) = Length (Source)'Old - 1 + + -- The elements of Source located before Position are preserved + + and M.Range_Equal + (Left => Model (Source)'Old, + Right => Model (Source), + Fst => 1, + Lst => P.Get (Positions (Source)'Old, Position'Old) - 1) + + -- The elements located after Position are shifted by 1 + + and M.Range_Shifted + (Left => Model (Source)'Old, + Right => Model (Source), + Fst => P.Get (Positions (Source)'Old, Position'Old) + 1, + Lst => Length (Source)'Old, + Offset => -1) + + -- Position has been removed from Source + + and P_Positions_Shifted + (Positions (Source), + Positions (Source)'Old, + Cut => P.Get (Positions (Source)'Old, Position'Old)) + + -- Positions is valid in Target and it is located either before + -- Before if it is valid in Target or at the end if it is No_Element. + + and P.Has_Key (Positions (Target), Position) + and (if Before = No_Element then + P.Get (Positions (Target), Position) = Length (Target) + else + P.Get (Positions (Target), Position) = + P.Get (Positions (Target)'Old, Before)) + + -- The elements of Target located before Position are preserved + + and M.Range_Equal + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => 1, + Lst => P.Get (Positions (Target), Position) - 1) + + -- Other elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => P.Get (Positions (Target), Position), + Lst => Length (Target)'Old, + Offset => 1) + + -- The element located at Position in Source is moved to Target + + and Element (Model (Target), + P.Get (Positions (Target), Position)) = + Element (Model (Source)'Old, + P.Get (Positions (Source)'Old, Position'Old)) + + -- A new cursor has been inserted at position Position in Target + + and P_Positions_Shifted + (Positions (Target)'Old, + Positions (Target), + Cut => P.Get (Positions (Target), Position)); + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + with + Global => null, + Pre => + (Has_Element (Container, Before) or else Before = No_Element) + and then Has_Element (Container, Position), + Post => Length (Container) = Length (Container)'Old, + Contract_Cases => + (Before = Position => + Model (Container) = Model (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + Before = No_Element => + + -- The elements located before Position are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Position) - 1) + + -- The elements located after Position are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Position) + 1, + Lst => Length (Container)'Old, + Offset => -1) + + -- The last element of Container is the one that was previously at + -- Position. + + and Element (Model (Container), + Length (Container)) = + Element (Model (Container)'Old, + P.Get (Positions (Container)'Old, Position)) + + -- Cursors from Container continue designating the same elements + + and Mapping_Preserved + (M_Left => Model (Container)'Old, + M_Right => Model (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container)), + + others => + + -- The elements located before Position and Before are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => + Count_Type'Min + (P.Get (Positions (Container)'Old, Position) - 1, + P.Get (Positions (Container)'Old, Before) - 1)) + + -- The elements located after Position and Before are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => + Count_Type'Max + (P.Get (Positions (Container)'Old, Position) + 1, + P.Get (Positions (Container)'Old, Before) + 1), + Lst => Length (Container)) + + -- The elements located after Before and before Position are + -- shifted by 1 to the right. + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before) + 1, + Lst => P.Get (Positions (Container)'Old, Position) - 1, + Offset => 1) + + -- The elements located after Position and before Before are + -- shifted by 1 to the left. + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Position) + 1, + Lst => P.Get (Positions (Container)'Old, Before) - 1, + Offset => -1) + + -- The element previously at Position is now before Before + + and Element + (Model (Container), + P.Get (Positions (Container)'Old, Before)) = + Element + (Model (Container)'Old, + P.Get (Positions (Container)'Old, Position)) + + -- Cursors from Container continue designating the same elements + + and Mapping_Preserved + (M_Left => Model (Container)'Old, + M_Right => Model (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container))); + + function First (Container : List) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + First'Result = No_Element, + + others => + Has_Element (Container, First'Result) + and P.Get (Positions (Container), First'Result) = 1); + + function First_Element (Container : List) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => First_Element'Result = M.Get (Model (Container), 1); + + function Last (Container : List) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + Last'Result = No_Element, + + others => + Has_Element (Container, Last'Result) + and P.Get (Positions (Container), Last'Result) = + Length (Container)); + + function Last_Element (Container : List) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + Last_Element'Result = M.Get (Model (Container), Length (Container)); + + function Next (Container : List; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Next'Result = No_Element, + + others => + Has_Element (Container, Next'Result) + and then P.Get (Positions (Container), Next'Result) = + P.Get (Positions (Container), Position) + 1); + + procedure Next (Container : List; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) + 1); + + function Previous (Container : List; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = 1 + => + Previous'Result = No_Element, + + others => + Has_Element (Container, Previous'Result) + and then P.Get (Positions (Container), Previous'Result) = + P.Get (Positions (Container), Position) - 1); + + procedure Previous (Container : List; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = 1 + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) - 1); + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + + -- If Item is not contained in Container after Position, Find returns + -- No_Element. + + (not M.Contains + (Container => Model (Container), + Fst => + (if Position = No_Element then + 1 + else + P.Get (Positions (Container), Position)), + Lst => Length (Container), + Item => Item) + => + Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Find'Result) + + -- The element designated by the result of Find is Item + + and Element + (Model (Container), + P.Get (Positions (Container), Find'Result)) = Item + + -- The result of Find is located after Position + + and (if Position /= No_Element then + P.Get (Positions (Container), Find'Result) >= + P.Get (Positions (Container), Position)) + + -- It is the first occurrence of Item in this slice + + and not M.Contains + (Container => Model (Container), + Fst => + (if Position = No_Element then + 1 + else + P.Get (Positions (Container), Position)), + Lst => + P.Get (Positions (Container), Find'Result) - 1, + Item => Item)); + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + + -- If Item is not contained in Container before Position, Find returns + -- No_Element. + + (not M.Contains + (Container => Model (Container), + Fst => 1, + Lst => + (if Position = No_Element then + Length (Container) + else + P.Get (Positions (Container), Position)), + Item => Item) + => + Reverse_Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Reverse_Find'Result) + + -- The element designated by the result of Find is Item + + and Element + (Model (Container), + P.Get (Positions (Container), Reverse_Find'Result)) = Item + + -- The result of Find is located before Position + + and (if Position /= No_Element then + P.Get (Positions (Container), Reverse_Find'Result) <= + P.Get (Positions (Container), Position)) + + -- It is the last occurrence of Item in this slice + + and not M.Contains + (Container => Model (Container), + Fst => + P.Get (Positions (Container), + Reverse_Find'Result) + 1, + Lst => + (if Position = No_Element then + Length (Container) + else + P.Get (Positions (Container), Position)), + Item => Item)); + + function Contains + (Container : List; + Item : Element_Type) return Boolean + with + Global => null, + Post => + Contains'Result = M.Contains (Container => Model (Container), + Fst => 1, + Lst => Length (Container), + Item => Item); + + function Has_Element + (Container : List; + Position : Cursor) return Boolean + with + Global => null, + Post => + Has_Element'Result = P.Has_Key (Positions (Container), Position); + pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + + package Generic_Sorting with SPARK_Mode is + + package Formal_Model with Ghost is + function M_Elements_Sorted (Container : M.Sequence) return Boolean + with + Global => null, + Post => + M_Elements_Sorted'Result = + (for all I in 1 .. M.Length (Container) => + (for all J in I .. M.Length (Container) => + not (Element (Container, J) < Element (Container, I)))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); + + end Formal_Model; + use Formal_Model; + + function Is_Sorted (Container : List) return Boolean with + Global => null, + Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); + + procedure Sort (Container : in out List) with + Global => null, + Post => + Length (Container) = Length (Container)'Old + and M_Elements_Sorted (Model (Container)) + and M_Elements_Included + (Left => Model (Container)'Old, + L_Lst => Length (Container), + Right => Model (Container), + R_Lst => Length (Container)) + and M_Elements_Included + (Left => Model (Container), + L_Lst => Length (Container), + Right => Model (Container)'Old, + R_Lst => Length (Container)); + + procedure Merge (Target : in out List; Source : in out List) with + -- Target and Source should not be aliased + Global => null, + Pre => Length (Target) <= Count_Type'Last - Length (Source), + Post => + Length (Target) = Length (Target)'Old + Length (Source)'Old + and Length (Source) = 0 + and (if M_Elements_Sorted (Model (Target)'Old) + and M_Elements_Sorted (Model (Source)'Old) + then + M_Elements_Sorted (Model (Target))) + and M_Elements_Included + (Left => Model (Target)'Old, + L_Lst => Length (Target)'Old, + Right => Model (Target), + R_Lst => Length (Target)) + and M_Elements_Included + (Left => Model (Source)'Old, + L_Lst => Length (Source)'Old, + Right => Model (Target), + R_Lst => Length (Target)) + and M_Elements_In_Union + (Model (Target), + Model (Source)'Old, + Model (Target)'Old); + end Generic_Sorting; + +private + pragma SPARK_Mode (Off); + + use Ada.Finalization; + + type Element_Access is access all Element_Type; + + type Node_Type is record + Prev : Count_Type'Base := -1; + Next : Count_Type := 0; + Element : Element_Access := null; + end record; + + type Node_Access is access all Node_Type; + + function "=" (L, R : Node_Type) return Boolean is abstract; + + type Node_Array is array (Count_Type range <>) of Node_Type; + function "=" (L, R : Node_Array) return Boolean is abstract; + + type Node_Array_Access is access all Node_Array; + + type List is new Controlled with record + Free : Count_Type'Base := -1; + Length : Count_Type := 0; + First : Count_Type := 0; + Last : Count_Type := 0; + Nodes : Node_Array_Access := null; + end record; + + overriding procedure Finalize (Container : in out List); + overriding procedure Adjust (Container : in out List); +end Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfinse.adb b/gcc/ada/libgnat/a-cfinse.adb new file mode 100644 index 0000000..7b457f6 --- /dev/null +++ b/gcc/ada/libgnat/a-cfinse.adb @@ -0,0 +1,304 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FUNCTIONAL_INFINITE_SEQUENCE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2022-2022, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +package body Ada.Containers.Functional_Infinite_Sequences +with SPARK_Mode => Off +is + use Containers; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + package Big_From_Count is new Signed_Conversions + (Int => Count_Type); + + function Big (C : Count_Type) return Big_Integer renames + Big_From_Count.To_Big_Integer; + + -- Store Count_Type'Last as a Big Natural because it is often used + + Count_Type_Big_Last : constant Big_Natural := Big (Count_Type'Last); + + function To_Count (C : Big_Natural) return Count_Type; + -- Convert Big_Natural to Count_Type + + --------- + -- "<" -- + --------- + + function "<" (Left : Sequence; Right : Sequence) return Boolean is + (Length (Left) < Length (Right) + and then (for all N in Left => + Get (Left, N) = Get (Right, N))); + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left : Sequence; Right : Sequence) return Boolean is + (Length (Left) <= Length (Right) + and then (for all N in Left => + Get (Left, N) = Get (Right, N))); + + --------- + -- "=" -- + --------- + + function "=" (Left : Sequence; Right : Sequence) return Boolean is + (Left.Content = Right.Content); + + --------- + -- Add -- + --------- + + function Add (Container : Sequence; New_Item : Element_Type) return Sequence + is + (Add (Container, Last (Container) + 1, New_Item)); + + function Add + (Container : Sequence; + Position : Big_Positive; + New_Item : Element_Type) return Sequence is + (Content => Add (Container.Content, To_Count (Position), New_Item)); + + -------------------- + -- Constant_Range -- + -------------------- + + function Constant_Range + (Container : Sequence; + Fst : Big_Positive; + Lst : Big_Natural; + Item : Element_Type) return Boolean + is + Count_Fst : constant Count_Type := To_Count (Fst); + Count_Lst : constant Count_Type := To_Count (Lst); + + begin + for J in Count_Fst .. Count_Lst loop + if Get (Container.Content, J) /= Item then + return False; + end if; + end loop; + + return True; + end Constant_Range; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Sequence; + Fst : Big_Positive; + Lst : Big_Natural; + Item : Element_Type) return Boolean + is + Count_Fst : constant Count_Type := To_Count (Fst); + Count_Lst : constant Count_Type := To_Count (Lst); + + begin + for J in Count_Fst .. Count_Lst loop + if Get (Container.Content, J) = Item then + return True; + end if; + end loop; + + return False; + end Contains; + + -------------------- + -- Empty_Sequence -- + -------------------- + + function Empty_Sequence return Sequence is + (Content => <>); + + ------------------ + -- Equal_Except -- + ------------------ + + function Equal_Except + (Left : Sequence; + Right : Sequence; + Position : Big_Positive) return Boolean + is + Count_Pos : constant Count_Type := To_Count (Position); + Count_Lst : constant Count_Type := To_Count (Last (Left)); + + begin + if Length (Left) /= Length (Right) then + return False; + end if; + + for J in 1 .. Count_Lst loop + if J /= Count_Pos + and then Get (Left.Content, J) /= Get (Right.Content, J) + then + return False; + end if; + end loop; + + return True; + end Equal_Except; + + function Equal_Except + (Left : Sequence; + Right : Sequence; + X : Big_Positive; + Y : Big_Positive) return Boolean + is + Count_X : constant Count_Type := To_Count (X); + Count_Y : constant Count_Type := To_Count (Y); + Count_Lst : constant Count_Type := To_Count (Last (Left)); + + begin + if Length (Left) /= Length (Right) then + return False; + end if; + + for J in 1 .. Count_Lst loop + if J /= Count_X + and then J /= Count_Y + and then Get (Left.Content, J) /= Get (Right.Content, J) + then + return False; + end if; + end loop; + + return True; + end Equal_Except; + + --------- + -- Get -- + --------- + + function Get + (Container : Sequence; + Position : Big_Integer) return Element_Type is + (Get (Container.Content, To_Count (Position))); + + ---------- + -- Last -- + ---------- + + function Last (Container : Sequence) return Big_Natural is + (Length (Container)); + + ------------ + -- Length -- + ------------ + + function Length (Container : Sequence) return Big_Natural is + (Big (Length (Container.Content))); + + ----------------- + -- Range_Equal -- + ----------------- + + function Range_Equal + (Left : Sequence; + Right : Sequence; + Fst : Big_Positive; + Lst : Big_Natural) return Boolean + is + Count_Fst : constant Count_Type := To_Count (Fst); + Count_Lst : constant Count_Type := To_Count (Lst); + + begin + for J in Count_Fst .. Count_Lst loop + if Get (Left.Content, J) /= Get (Right.Content, J) then + return False; + end if; + end loop; + + return True; + end Range_Equal; + + ------------------- + -- Range_Shifted -- + ------------------- + + function Range_Shifted + (Left : Sequence; + Right : Sequence; + Fst : Big_Positive; + Lst : Big_Natural; + Offset : Big_Integer) return Boolean + is + Count_Fst : constant Count_Type := To_Count (Fst); + Count_Lst : constant Count_Type := To_Count (Lst); + + begin + for J in Count_Fst .. Count_Lst loop + if Get (Left.Content, J) /= Get (Right, Big (J) + Offset) then + return False; + end if; + end loop; + + return True; + end Range_Shifted; + + ------------ + -- Remove -- + ------------ + + function Remove + (Container : Sequence; + Position : Big_Positive) return Sequence is + (Content => Remove (Container.Content, To_Count (Position))); + + --------- + -- Set -- + --------- + + function Set + (Container : Sequence; + Position : Big_Positive; + New_Item : Element_Type) return Sequence is + (Content => Set (Container.Content, To_Count (Position), New_Item)); + + -------------- + -- To_Count -- + -------------- + + function To_Count (C : Big_Natural) return Count_Type is + begin + if C > Count_Type_Big_Last then + raise Program_Error with "Big_Integer too large for Count_Type"; + end if; + return Big_From_Count.From_Big_Integer (C); + end To_Count; + +end Ada.Containers.Functional_Infinite_Sequences; diff --git a/gcc/ada/libgnat/a-cfinse.ads b/gcc/ada/libgnat/a-cfinse.ads new file mode 100644 index 0000000..d7fdb04 --- /dev/null +++ b/gcc/ada/libgnat/a-cfinse.ads @@ -0,0 +1,380 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FUNCTIONAL_INFINITE_SEQUENCE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-2022, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +pragma Ada_2012; +private with Ada.Containers.Functional_Base; +with Ada.Numerics.Big_Numbers.Big_Integers; +use Ada.Numerics.Big_Numbers.Big_Integers; + +generic + type Element_Type (<>) is private; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Functional_Infinite_Sequences with + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is + + type Sequence is private + with Default_Initial_Condition => Length (Sequence) = 0, + Iterable => (First => Iter_First, + Has_Element => Iter_Has_Element, + Next => Iter_Next, + Element => Get); + -- Sequences are empty when default initialized. + -- Quantification over sequences can be done using the regular + -- quantification over its range or directly on its elements with "for of". + + ----------------------- + -- Basic operations -- + ----------------------- + + -- Sequences are axiomatized using Length and Get, providing respectively + -- the length of a sequence and an accessor to its Nth element: + + function Length (Container : Sequence) return Big_Natural with + -- Length of a sequence + + Global => null; + + function Get + (Container : Sequence; + Position : Big_Integer) return Element_Type + -- Access the Element at position Position in Container + + with + Global => null, + Pre => Iter_Has_Element (Container, Position); + + function Last (Container : Sequence) return Big_Natural with + -- Last index of a sequence + + Global => null, + Post => + Last'Result = Length (Container); + pragma Annotate (GNATprove, Inline_For_Proof, Last); + + function First return Big_Positive is (1) with + -- First index of a sequence + + Global => null; + + ------------------------ + -- Property Functions -- + ------------------------ + + function "=" (Left : Sequence; Right : Sequence) return Boolean with + -- Extensional equality over sequences + + Global => null, + Post => + "="'Result = + (Length (Left) = Length (Right) + and then (for all N in Left => Get (Left, N) = Get (Right, N))); + pragma Annotate (GNATprove, Inline_For_Proof, "="); + + function "<" (Left : Sequence; Right : Sequence) return Boolean with + -- Left is a strict subsequence of Right + + Global => null, + Post => + "<"'Result = + (Length (Left) < Length (Right) + and then (for all N in Left => Get (Left, N) = Get (Right, N))); + pragma Annotate (GNATprove, Inline_For_Proof, "<"); + + function "<=" (Left : Sequence; Right : Sequence) return Boolean with + -- Left is a subsequence of Right + + Global => null, + Post => + "<="'Result = + (Length (Left) <= Length (Right) + and then (for all N in Left => Get (Left, N) = Get (Right, N))); + pragma Annotate (GNATprove, Inline_For_Proof, "<="); + + function Contains + (Container : Sequence; + Fst : Big_Positive; + Lst : Big_Natural; + Item : Element_Type) return Boolean + -- Returns True if Item occurs in the range from Fst to Lst of Container + + with + Global => null, + Pre => Lst <= Last (Container), + Post => + Contains'Result = + (for some J in Container => + Fst <= J and J <= Lst and Get (Container, J) = Item); + pragma Annotate (GNATprove, Inline_For_Proof, Contains); + + function Constant_Range + (Container : Sequence; + Fst : Big_Positive; + Lst : Big_Natural; + Item : Element_Type) return Boolean + -- Returns True if every element of the range from Fst to Lst of Container + -- is equal to Item. + + with + Global => null, + Pre => Lst <= Last (Container), + Post => + Constant_Range'Result = + (for all J in Container => + (if Fst <= J and J <= Lst then Get (Container, J) = Item)); + pragma Annotate (GNATprove, Inline_For_Proof, Constant_Range); + + function Equal_Except + (Left : Sequence; + Right : Sequence; + Position : Big_Positive) return Boolean + -- Returns True is Left and Right are the same except at position Position + + with + Global => null, + Pre => Position <= Last (Left), + Post => + Equal_Except'Result = + (Length (Left) = Length (Right) + and then (for all J in Left => + (if J /= Position then + Get (Left, J) = Get (Right, J)))); + pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); + + function Equal_Except + (Left : Sequence; + Right : Sequence; + X : Big_Positive; + Y : Big_Positive) return Boolean + -- Returns True is Left and Right are the same except at positions X and Y + + with + Global => null, + Pre => X <= Last (Left) and Y <= Last (Left), + Post => + Equal_Except'Result = + (Length (Left) = Length (Right) + and then (for all J in Left => + (if J /= X and J /= Y then + Get (Left, J) = Get (Right, J)))); + pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); + + function Range_Equal + (Left : Sequence; + Right : Sequence; + Fst : Big_Positive; + Lst : Big_Natural) return Boolean + -- Returns True if the ranges from Fst to Lst contain the same elements in + -- Left and Right. + + with + Global => null, + Pre => Lst <= Last (Left) and Lst <= Last (Right), + Post => + Range_Equal'Result = + (for all J in Left => + (if Fst <= J and J <= Lst then Get (Left, J) = Get (Right, J))); + pragma Annotate (GNATprove, Inline_For_Proof, Range_Equal); + + function Range_Shifted + (Left : Sequence; + Right : Sequence; + Fst : Big_Positive; + Lst : Big_Natural; + Offset : Big_Integer) return Boolean + -- Returns True if the range from Fst to Lst in Left contains the same + -- elements as the range from Fst + Offset to Lst + Offset in Right. + + with + Global => null, + Pre => + Lst <= Last (Left) + and then + (if Fst <= Lst then + Offset + Fst >= 1 and Offset + Lst <= Length (Right)), + Post => + Range_Shifted'Result = + ((for all J in Left => + (if Fst <= J and J <= Lst then + Get (Left, J) = Get (Right, J + Offset))) + and + (for all J in Right => + (if Fst + Offset <= J and J <= Lst + Offset then + Get (Left, J - Offset) = Get (Right, J)))); + pragma Annotate (GNATprove, Inline_For_Proof, Range_Shifted); + + ---------------------------- + -- Construction Functions -- + ---------------------------- + + -- For better efficiency of both proofs and execution, avoid using + -- construction functions in annotations and rather use property functions. + + function Set + (Container : Sequence; + Position : Big_Positive; + New_Item : Element_Type) return Sequence + -- Returns a new sequence which contains the same elements as Container + -- except for the one at position Position which is replaced by New_Item. + + with + Global => null, + Pre => Position <= Last (Container), + Post => + Get (Set'Result, Position) = New_Item + and then Equal_Except (Container, Set'Result, Position); + + function Add (Container : Sequence; New_Item : Element_Type) return Sequence + -- Returns a new sequence which contains the same elements as Container + -- plus New_Item at the end. + + with + Global => null, + Post => + Length (Add'Result) = Length (Container) + 1 + and then Get (Add'Result, Last (Add'Result)) = New_Item + and then Container <= Add'Result; + + function Add + (Container : Sequence; + Position : Big_Positive; + New_Item : Element_Type) return Sequence + with + -- Returns a new sequence which contains the same elements as Container + -- except that New_Item has been inserted at position Position. + + Global => null, + Pre => Position <= Last (Container) + 1, + Post => + Length (Add'Result) = Length (Container) + 1 + and then Get (Add'Result, Position) = New_Item + and then Range_Equal + (Left => Container, + Right => Add'Result, + Fst => 1, + Lst => Position - 1) + and then Range_Shifted + (Left => Container, + Right => Add'Result, + Fst => Position, + Lst => Last (Container), + Offset => 1); + + function Remove + (Container : Sequence; + Position : Big_Positive) return Sequence + -- Returns a new sequence which contains the same elements as Container + -- except that the element at position Position has been removed. + + with + Global => null, + Pre => Position <= Last (Container), + Post => + Length (Remove'Result) = Length (Container) - 1 + and then Range_Equal + (Left => Container, + Right => Remove'Result, + Fst => 1, + Lst => Position - 1) + and then Range_Shifted + (Left => Remove'Result, + Right => Container, + Fst => Position, + Lst => Last (Remove'Result), + Offset => 1); + + function Copy_Element (Item : Element_Type) return Element_Type is (Item); + -- Elements of containers are copied by numerous primitives in this + -- package. This function causes GNATprove to verify that such a copy is + -- valid (in particular, it does not break the ownership policy of SPARK, + -- i.e. it does not contain pointers that could be used to alias mutable + -- data). + + function Empty_Sequence return Sequence with + -- Return an empty Sequence + + Global => null, + Post => Length (Empty_Sequence'Result) = 0; + + --------------------------- + -- Iteration Primitives -- + --------------------------- + + function Iter_First (Container : Sequence) return Big_Integer with + Global => null, + Post => Iter_First'Result = 1; + + function Iter_Has_Element + (Container : Sequence; + Position : Big_Integer) return Boolean + with + Global => null, + Post => Iter_Has_Element'Result = + In_Range (Position, 1, Length (Container)); + pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element); + + function Iter_Next + (Container : Sequence; + Position : Big_Integer) return Big_Integer + with + Global => null, + Pre => Iter_Has_Element (Container, Position), + Post => Iter_Next'Result = Position + 1; + +private + pragma SPARK_Mode (Off); + + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + + package Containers is new Ada.Containers.Functional_Base + (Index_Type => Positive_Count_Type, + Element_Type => Element_Type); + + type Sequence is record + Content : Containers.Container; + end record; + + function Iter_First (Container : Sequence) return Big_Integer is (1); + + function Iter_Next + (Container : Sequence; + Position : Big_Integer) return Big_Integer + is + (Position + 1); + + function Iter_Has_Element + (Container : Sequence; + Position : Big_Integer) return Boolean + is + (In_Range (Position, 1, Length (Container))); +end Ada.Containers.Functional_Infinite_Sequences; diff --git a/gcc/ada/libgnat/a-cfinve.adb b/gcc/ada/libgnat/a-cfinve.adb index 17b57cb..a55786d 100644 --- a/gcc/ada/libgnat/a-cfinve.adb +++ b/gcc/ada/libgnat/a-cfinve.adb @@ -432,7 +432,7 @@ is function Element (Container : Vector; - Index : Index_Type) return Element_Type + Index : Extended_Index) return Element_Type is begin if Index > Container.Last then diff --git a/gcc/ada/libgnat/a-cfinve.ads b/gcc/ada/libgnat/a-cfinve.ads index ec6af99..f44e45b 100644 --- a/gcc/ada/libgnat/a-cfinve.ads +++ b/gcc/ada/libgnat/a-cfinve.ads @@ -53,8 +53,10 @@ generic -- grow via heap allocation. package Ada.Containers.Formal_Indefinite_Vectors with - SPARK_Mode => On + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. @@ -284,7 +286,7 @@ is function Element (Container : Vector; - Index : Index_Type) return Element_Type + Index : Extended_Index) return Element_Type with Global => null, Pre => Index in First_Index (Container) .. Last_Index (Container), diff --git a/gcc/ada/libgnat/a-cforma.adb b/gcc/ada/libgnat/a-cforma.adb index 79f25f8..38d15e7 100644 --- a/gcc/ada/libgnat/a-cforma.adb +++ b/gcc/ada/libgnat/a-cforma.adb @@ -32,12 +32,22 @@ pragma Elaborate_All with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); +with Ada.Numerics.Big_Numbers.Big_Integers; +use Ada.Numerics.Big_Numbers.Big_Integers; + with System; use type System.Address; package body Ada.Containers.Formal_Ordered_Maps with SPARK_Mode => Off is + -- Convert Count_Type to Big_Interger + + package Conversions is new Signed_Conversions (Int => Count_Type); + + function Big (J : Count_Type) return Big_Integer renames + Conversions.To_Big_Integer; + ----------------------------- -- Node Access Subprograms -- ----------------------------- @@ -745,7 +755,7 @@ is while Position /= 0 loop R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = I); + pragma Assert (P.Length (R) = Big (I)); Position := Tree_Operations.Next (Container.Content, Position); I := I + 1; end loop; diff --git a/gcc/ada/libgnat/a-cforma.ads b/gcc/ada/libgnat/a-cforma.ads index 1e3c57b..7be2eec 100644 --- a/gcc/ada/libgnat/a-cforma.ads +++ b/gcc/ada/libgnat/a-cforma.ads @@ -61,8 +61,10 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Formal_Ordered_Maps with - SPARK_Mode + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. diff --git a/gcc/ada/libgnat/a-cforse.adb b/gcc/ada/libgnat/a-cforse.adb index 3b64511..e5cddde 100644 --- a/gcc/ada/libgnat/a-cforse.adb +++ b/gcc/ada/libgnat/a-cforse.adb @@ -943,7 +943,7 @@ is while Position /= 0 loop R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = I); + pragma Assert (P.Length (R) = Big (I)); Position := Tree_Operations.Next (Container.Content, Position); I := I + 1; end loop; diff --git a/gcc/ada/libgnat/a-cforse.ads b/gcc/ada/libgnat/a-cforse.ads index a736b48..ff96d8e 100644 --- a/gcc/ada/libgnat/a-cforse.ads +++ b/gcc/ada/libgnat/a-cforse.ads @@ -49,6 +49,8 @@ with Ada.Containers.Functional_Maps; with Ada.Containers.Functional_Sets; with Ada.Containers.Functional_Vectors; +with Ada.Numerics.Big_Numbers.Big_Integers; +use Ada.Numerics.Big_Numbers.Big_Integers; private with Ada.Containers.Red_Black_Trees; generic @@ -57,8 +59,10 @@ generic with function "<" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Formal_Ordered_Sets with - SPARK_Mode + SPARK_Mode, + Annotate => (GNATprove, Always_Return) is + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. @@ -67,6 +71,13 @@ is pragma Assertion_Policy (Contract_Cases => Ignore); pragma Annotate (CodePeer, Skip_Analysis); + -- Convert Count_Type to Big_Interger + + package Conversions is new Signed_Conversions (Int => Count_Type); + + function Big (J : Count_Type) return Big_Integer renames + Conversions.To_Big_Integer; + function Equivalent_Elements (Left, Right : Element_Type) return Boolean with Global => null, @@ -341,7 +352,7 @@ is Ghost, Global => null, - Post => M.Length (Model'Result) = Length (Container); + Post => M.Length (Model'Result) = Big (Length (Container)); function Elements (Container : Set) return E.Sequence with -- The Elements sequence represents the underlying list structure of @@ -990,9 +1001,9 @@ is Length (Source) - Length (Target and Source) <= Target.Capacity - Length (Target), Post => - Length (Target) = Length (Target)'Old + Big (Length (Target)) = Big (Length (Target)'Old) - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - + Length (Source) + + Big (Length (Source)) -- Elements already in Target are still in Target @@ -1038,9 +1049,9 @@ is Global => null, Pre => Length (Left) <= Count_Type'Last - Length (Right), Post => - Length (Union'Result) = Length (Left) + Big (Length (Union'Result)) = Big (Length (Left)) - M.Num_Overlaps (Model (Left), Model (Right)) - + Length (Right) + + Big (Length (Right)) -- Elements of Left and Right are in the result of Union @@ -1076,7 +1087,7 @@ is procedure Intersection (Target : in out Set; Source : Set) with Global => null, Post => - Length (Target) = + Big (Length (Target)) = M.Num_Overlaps (Model (Target)'Old, Model (Source)) -- Elements of Target were already in Target @@ -1111,7 +1122,7 @@ is function Intersection (Left, Right : Set) return Set with Global => null, Post => - Length (Intersection'Result) = + Big (Length (Intersection'Result)) = M.Num_Overlaps (Model (Left), Model (Right)) -- Elements in the result of Intersection are in Left and Right @@ -1139,7 +1150,7 @@ is procedure Difference (Target : in out Set; Source : Set) with Global => null, Post => - Length (Target) = Length (Target)'Old - + Big (Length (Target)) = Big (Length (Target)'Old) - M.Num_Overlaps (Model (Target)'Old, Model (Source)) -- Elements of Target were already in Target @@ -1174,7 +1185,7 @@ is function Difference (Left, Right : Set) return Set with Global => null, Post => - Length (Difference'Result) = Length (Left) - + Big (Length (Difference'Result)) = Big (Length (Left)) - M.Num_Overlaps (Model (Left), Model (Right)) -- Elements of the result of Difference are in Left @@ -1209,9 +1220,9 @@ is Length (Source) - Length (Target and Source) <= Target.Capacity - Length (Target) + Length (Target and Source), Post => - Length (Target) = Length (Target)'Old - + Big (Length (Target)) = Big (Length (Target)'Old) - 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) + - Length (Source) + Big (Length (Source)) -- Elements of the difference were not both in Source and in Target @@ -1248,9 +1259,9 @@ is Global => null, Pre => Length (Left) <= Count_Type'Last - Length (Right), Post => - Length (Symmetric_Difference'Result) = Length (Left) - + Big (Length (Symmetric_Difference'Result)) = Big (Length (Left)) - 2 * M.Num_Overlaps (Model (Left), Model (Right)) + - Length (Right) + Big (Length (Right)) -- Elements of the difference were not both in Left and Right diff --git a/gcc/ada/libgnat/a-chahan.ads b/gcc/ada/libgnat/a-chahan.ads index e98cda3..dc1a629 100644 --- a/gcc/ada/libgnat/a-chahan.ads +++ b/gcc/ada/libgnat/a-chahan.ads @@ -46,6 +46,8 @@ is pragma Pure; -- In accordance with Ada 2005 AI-362 + pragma Annotate (GNATprove, Always_Return, Handling); + ---------------------------------------- -- Character Classification Functions -- ---------------------------------------- diff --git a/gcc/ada/libgnat/a-chtgfk.adb b/gcc/ada/libgnat/a-chtgfk.adb new file mode 100644 index 0000000..7d355e0 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgfk.adb @@ -0,0 +1,278 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_KEYS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2022, 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Hash_Tables.Generic_Formal_Keys is + + Checks : constant Boolean := Container_Checks'Enabled; + + -------------------------- + -- Delete_Key_Sans_Free -- + -------------------------- + + procedure Delete_Key_Sans_Free + (HT : in out Hash_Table_Type; + Key : Key_Type; + X : out Count_Type) + is + Indx : Hash_Type; + Prev : Count_Type; + + begin + if HT.Length = 0 then + X := 0; + return; + end if; + + Indx := Index (HT, Key); + X := HT.Buckets (Indx); + + if X = 0 then + return; + end if; + + if Equivalent_Keys (Key, HT.Nodes (X)) then + HT.Buckets (Indx) := Next (HT.Nodes (X)); + HT.Length := HT.Length - 1; + return; + end if; + + loop + Prev := X; + X := Next (HT.Nodes (Prev)); + + if X = 0 then + return; + end if; + + if Equivalent_Keys (Key, HT.Nodes (X)) then + Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X))); + HT.Length := HT.Length - 1; + return; + end if; + end loop; + end Delete_Key_Sans_Free; + + ---------- + -- Find -- + ---------- + + function Find + (HT : Hash_Table_Type; + Key : Key_Type) return Count_Type + is + Indx : Hash_Type; + Node : Count_Type; + + begin + if HT.Length = 0 then + return 0; + end if; + + Indx := Index (HT, Key); + + Node := HT.Buckets (Indx); + while Node /= 0 loop + if Equivalent_Keys (Key, HT.Nodes (Node)) then + return Node; + end if; + Node := Next (HT.Nodes (Node)); + end loop; + + return 0; + end Find; + + -------------------------------- + -- Generic_Conditional_Insert -- + -------------------------------- + + procedure Generic_Conditional_Insert + (HT : in out Hash_Table_Type; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + Indx : Hash_Type; + + begin + Indx := Index (HT, Key); + Node := HT.Buckets (Indx); + + if Node = 0 then + if Checks and then HT.Length = HT.Capacity then + raise Capacity_Error with "no more capacity for insertion"; + end if; + + New_Node (HT, Node); + Set_Next (HT.Nodes (Node), Next => 0); + + Inserted := True; + + HT.Buckets (Indx) := Node; + HT.Length := HT.Length + 1; + + return; + end if; + + loop + if Equivalent_Keys (Key, HT.Nodes (Node)) then + Inserted := False; + return; + end if; + + Node := Next (HT.Nodes (Node)); + + exit when Node = 0; + end loop; + + if Checks and then HT.Length = HT.Capacity then + raise Capacity_Error with "no more capacity for insertion"; + end if; + + New_Node (HT, Node); + Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx)); + + Inserted := True; + + HT.Buckets (Indx) := Node; + HT.Length := HT.Length + 1; + end Generic_Conditional_Insert; + + ----------------------------- + -- Generic_Replace_Element -- + ----------------------------- + + procedure Generic_Replace_Element + (HT : in out Hash_Table_Type; + Node : Count_Type; + Key : Key_Type) + is + pragma Assert (HT.Length > 0); + pragma Assert (Node /= 0); + + BB : Buckets_Type renames HT.Buckets; + NN : Nodes_Type renames HT.Nodes; + + Old_Indx : Hash_Type; + New_Indx : constant Hash_Type := Index (HT, Key); + + New_Bucket : Count_Type renames BB (New_Indx); + N, M : Count_Type; + + begin + Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length; + + -- Replace_Element is allowed to change a node's key to Key + -- (generic formal operation Assign provides the mechanism), but + -- only if Key is not already in the hash table. (In a unique-key + -- hash table as this one, a key is mapped to exactly one node.) + + if Equivalent_Keys (Key, NN (Node)) then + -- The new Key value is mapped to this same Node, so Node + -- stays in the same bucket. + + Assign (NN (Node), Key); + return; + end if; + + -- Key is not equivalent to Node, so we now have to determine if it's + -- equivalent to some other node in the hash table. This is the case + -- irrespective of whether Key is in the same or a different bucket from + -- Node. + + N := New_Bucket; + while N /= 0 loop + if Checks and then Equivalent_Keys (Key, NN (N)) then + pragma Assert (N /= Node); + raise Program_Error with + "attempt to replace existing element"; + end if; + + N := Next (NN (N)); + end loop; + + -- We have determined that Key is not already in the hash table, so + -- the change is allowed. + + if Old_Indx = New_Indx then + -- The node is already in the bucket implied by Key. In this case + -- we merely change its value without moving it. + + Assign (NN (Node), Key); + return; + end if; + + -- The node is in a bucket different from the bucket implied by Key. + -- Do the assignment first, before moving the node, so that if Assign + -- propagates an exception, then the hash table will not have been + -- modified (except for any possible side-effect Assign had on Node). + + Assign (NN (Node), Key); + + -- Now we can safely remove the node from its current bucket + + N := BB (Old_Indx); -- get value of first node in old bucket + pragma Assert (N /= 0); + + if N = Node then -- node is first node in its bucket + BB (Old_Indx) := Next (NN (Node)); + + else + pragma Assert (HT.Length > 1); + + loop + M := Next (NN (N)); + pragma Assert (M /= 0); + + if M = Node then + Set_Next (NN (N), Next => Next (NN (Node))); + exit; + end if; + + N := M; + end loop; + end if; + + -- Now we link the node into its new bucket (corresponding to Key) + + Set_Next (NN (Node), Next => New_Bucket); + New_Bucket := Node; + end Generic_Replace_Element; + + ----------- + -- Index -- + ----------- + + function Index + (HT : Hash_Table_Type; + Key : Key_Type) return Hash_Type is + begin + return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; + end Index; + +end Ada.Containers.Hash_Tables.Generic_Formal_Keys; diff --git a/gcc/ada/libgnat/a-chtgfk.ads b/gcc/ada/libgnat/a-chtgfk.ads new file mode 100644 index 0000000..363eaf0 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgfk.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_KEYS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2022, 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Hash_Table_Type is used to implement hashed containers. This package +-- declares hash-table operations that depend on keys. + +generic + with package HT_Types is + new Generic_Formal_Hash_Table_Types (<>); + + use HT_Types; + + with function Next (Node : Node_Type) return Count_Type; + + with procedure Set_Next + (Node : in out Node_Type; + Next : Count_Type); + + type Key_Type (<>) is limited private; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys + (Key : Key_Type; + Node : Node_Type) return Boolean; + +package Ada.Containers.Hash_Tables.Generic_Formal_Keys is + pragma Pure; + + function Index + (HT : Hash_Table_Type; + Key : Key_Type) return Hash_Type; + pragma Inline (Index); + -- Returns the bucket number (array index value) for the given key + + procedure Delete_Key_Sans_Free + (HT : in out Hash_Table_Type; + Key : Key_Type; + X : out Count_Type); + -- Removes the node (if any) with the given key from the hash table + + function Find + (HT : Hash_Table_Type; + Key : Key_Type) return Count_Type; + -- Returns the node (if any) corresponding to the given key + + generic + with procedure New_Node + (HT : in out Hash_Table_Type; + Node : out Count_Type); + procedure Generic_Conditional_Insert + (HT : in out Hash_Table_Type; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean); + -- Attempts to insert a new node with the given key into the hash table. + -- If a node with that key already exists in the table, then that node + -- is returned and Inserted returns False. Otherwise New_Node is called + -- to allocate a new node, and Inserted returns True. + + generic + with function Hash (Node : Node_Type) return Hash_Type; + with procedure Assign (Node : in out Node_Type; Key : Key_Type); + procedure Generic_Replace_Element + (HT : in out Hash_Table_Type; + Node : Count_Type; + Key : Key_Type); + -- Assigns Key to Node, possibly changing its equivalence class. Procedure + -- Assign is called to assign Key to Node. If Node is not in the same + -- bucket as Key before the assignment, it is moved from its current bucket + -- to the bucket implied by Key. Note that it is never proper to assign to + -- Node a key value already in the hash table, and so if Key is equivalent + -- to some other node then Program_Error is raised. + +end Ada.Containers.Hash_Tables.Generic_Formal_Keys; diff --git a/gcc/ada/libgnat/a-chtgfo.adb b/gcc/ada/libgnat/a-chtgfo.adb new file mode 100644 index 0000000..d688863 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgfo.adb @@ -0,0 +1,481 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2022, 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Hash_Tables.Generic_Formal_Operations is + + Checks : constant Boolean := Container_Checks'Enabled; + + ----------- + -- Clear -- + ----------- + + procedure Clear (HT : in out Hash_Table_Type) is + begin + HT.Length := 0; + HT.Free := -1; + HT.Buckets := [others => 0]; -- optimize this somehow ??? + end Clear; + + --------------------------- + -- Delete_Node_Sans_Free -- + --------------------------- + + procedure Delete_Node_Sans_Free + (HT : in out Hash_Table_Type; + X : Count_Type) + is + pragma Assert (X /= 0); + + Indx : Hash_Type; + Prev : Count_Type; + Curr : Count_Type; + + begin + if Checks and then HT.Length = 0 then + raise Program_Error with + "attempt to delete node from empty hashed container"; + end if; + + Indx := Index (HT, HT.Nodes (X)); + Prev := HT.Buckets (Indx); + + if Checks and then Prev = 0 then + raise Program_Error with + "attempt to delete node from empty hash bucket"; + end if; + + if Prev = X then + HT.Buckets (Indx) := Next (HT.Nodes (Prev)); + HT.Length := HT.Length - 1; + return; + end if; + + if Checks and then HT.Length = 1 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + loop + Curr := Next (HT.Nodes (Prev)); + + if Checks and then Curr = 0 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + if Curr = X then + Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr))); + HT.Length := HT.Length - 1; + return; + end if; + + Prev := Curr; + end loop; + end Delete_Node_Sans_Free; + + ----------- + -- First -- + ----------- + + function First (HT : Hash_Table_Type) return Count_Type is + Indx : Hash_Type; + + begin + if HT.Length = 0 then + return 0; + end if; + + Indx := HT.Buckets'First; + loop + if HT.Buckets (Indx) /= 0 then + return HT.Buckets (Indx); + end if; + + Indx := Indx + 1; + end loop; + end First; + + ---------- + -- Free -- + ---------- + + procedure Free + (HT : in out Hash_Table_Type; + X : Count_Type) + is + N : Nodes_Type renames HT.Nodes; + + begin + -- This subprogram "deallocates" a node by relinking the node off of the + -- active list and onto the free list. Previously it would flag index + -- value 0 as an error. The precondition was weakened, so that index + -- value 0 is now allowed, and this value is interpreted to mean "do + -- nothing". This makes its behavior analogous to the behavior of + -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add + -- special-case checks at the point of call. + + if X = 0 then + return; + end if; + + pragma Assert (X <= HT.Capacity); + + -- pragma Assert (N (X).Prev >= 0); -- node is active + -- Find a way to mark a node as active vs. inactive; we could + -- use a special value in Color_Type for this. ??? + + -- The hash table actually contains two data structures: a list for + -- the "active" nodes that contain elements that have been inserted + -- onto the container, and another for the "inactive" nodes of the free + -- store. + -- + -- We desire that merely declaring an object should have only minimal + -- cost; specially, we want to avoid having to initialize the free + -- store (to fill in the links), especially if the capacity is large. + -- + -- The head of the free list is indicated by Container.Free. If its + -- value is non-negative, then the free store has been initialized + -- in the "normal" way: Container.Free points to the head of the list + -- of free (inactive) nodes, and the value 0 means the free list is + -- empty. Each node on the free list has been initialized to point + -- to the next free node (via its Next component), and the value 0 + -- means that this is the last free node. + -- + -- If Container.Free is negative, then the links on the free store + -- have not been initialized. In this case the link values are + -- implied: the free store comprises the components of the node array + -- started with the absolute value of Container.Free, and continuing + -- until the end of the array (Nodes'Last). + -- + -- ??? + -- It might be possible to perform an optimization here. Suppose that + -- the free store can be represented as having two parts: one + -- comprising the non-contiguous inactive nodes linked together + -- in the normal way, and the other comprising the contiguous + -- inactive nodes (that are not linked together, at the end of the + -- nodes array). This would allow us to never have to initialize + -- the free store, except in a lazy way as nodes become inactive. + + -- When an element is deleted from the list container, its node + -- becomes inactive, and so we set its Next component to value of + -- the node's index (in the nodes array), to indicate that it is + -- now inactive. This provides a useful way to detect a dangling + -- cursor reference. ??? + + Set_Next (N (X), Next => X); -- Node is deallocated (not on active list) + + if HT.Free >= 0 then + -- The free store has previously been initialized. All we need to + -- do here is link the newly-free'd node onto the free list. + + Set_Next (N (X), HT.Free); + HT.Free := X; + + elsif X + 1 = abs HT.Free then + -- The free store has not been initialized, and the node becoming + -- inactive immediately precedes the start of the free store. All + -- we need to do is move the start of the free store back by one. + + HT.Free := HT.Free + 1; + + else + -- The free store has not been initialized, and the node becoming + -- inactive does not immediately precede the free store. Here we + -- first initialize the free store (meaning the links are given + -- values in the traditional way), and then link the newly-free'd + -- node onto the head of the free store. + + -- ??? + -- See the comments above for an optimization opportunity. If + -- the next link for a node on the free store is negative, then + -- this means the remaining nodes on the free store are + -- physically contiguous, starting as the absolute value of + -- that index value. + + HT.Free := abs HT.Free; + + if HT.Free > HT.Capacity then + HT.Free := 0; + + else + for I in HT.Free .. HT.Capacity - 1 loop + Set_Next (Node => N (I), Next => I + 1); + end loop; + + Set_Next (Node => N (HT.Capacity), Next => 0); + end if; + + Set_Next (Node => N (X), Next => HT.Free); + HT.Free := X; + end if; + end Free; + + ---------------------- + -- Generic_Allocate -- + ---------------------- + + procedure Generic_Allocate + (HT : in out Hash_Table_Type; + Node : out Count_Type) + is + N : Nodes_Type renames HT.Nodes; + + begin + if HT.Free >= 0 then + Node := HT.Free; + + -- We always perform the assignment first, before we + -- change container state, in order to defend against + -- exceptions duration assignment. + + Set_Element (N (Node)); + HT.Free := Next (N (Node)); + + else + -- A negative free store value means that the links of the nodes + -- in the free store have not been initialized. In this case, the + -- nodes are physically contiguous in the array, starting at the + -- index that is the absolute value of the Container.Free, and + -- continuing until the end of the array (Nodes'Last). + + Node := abs HT.Free; + + -- As above, we perform this assignment first, before modifying + -- any container state. + + Set_Element (N (Node)); + HT.Free := HT.Free - 1; + end if; + end Generic_Allocate; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal + (L, R : Hash_Table_Type) return Boolean + is + L_Index : Hash_Type; + L_Node : Count_Type; + + N : Count_Type; + + begin + if L.Length /= R.Length then + return False; + end if; + + if L.Length = 0 then + return True; + end if; + + -- Find the first node of hash table L + + L_Index := L.Buckets'First; + loop + L_Node := L.Buckets (L_Index); + exit when L_Node /= 0; + L_Index := L_Index + 1; + end loop; + + -- For each node of hash table L, search for an equivalent node in hash + -- table R. + + N := L.Length; + loop + if not Find (HT => R, Key => L.Nodes (L_Node)) then + return False; + end if; + + N := N - 1; + + L_Node := Next (L.Nodes (L_Node)); + + if L_Node = 0 then + + -- We have exhausted the nodes in this bucket + + if N = 0 then + return True; + end if; + + -- Find the next bucket + + loop + L_Index := L_Index + 1; + L_Node := L.Buckets (L_Index); + exit when L_Node /= 0; + end loop; + end if; + end loop; + end Generic_Equal; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration (HT : Hash_Table_Type) is + Node : Count_Type; + + begin + if HT.Length = 0 then + return; + end if; + + for Indx in HT.Buckets'Range loop + Node := HT.Buckets (Indx); + while Node /= 0 loop + Process (Node); + Node := Next (HT.Nodes (Node)); + end loop; + end loop; + end Generic_Iteration; + + ------------------ + -- Generic_Read -- + ------------------ + + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + HT : out Hash_Table_Type) + is + N : Count_Type'Base; + + begin + Clear (HT); + + Count_Type'Base'Read (Stream, N); + + if Checks and then N < 0 then + raise Program_Error with "stream appears to be corrupt"; + end if; + + if N = 0 then + return; + end if; + + if Checks and then N > HT.Capacity then + raise Capacity_Error with "too many elements in stream"; + end if; + + for J in 1 .. N loop + declare + Node : constant Count_Type := New_Node (Stream); + Indx : constant Hash_Type := Index (HT, HT.Nodes (Node)); + B : Count_Type renames HT.Buckets (Indx); + begin + Set_Next (HT.Nodes (Node), Next => B); + B := Node; + end; + + HT.Length := HT.Length + 1; + end loop; + end Generic_Read; + + ------------------- + -- Generic_Write -- + ------------------- + + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + HT : Hash_Table_Type) + is + procedure Write (Node : Count_Type); + pragma Inline (Write); + + procedure Write is new Generic_Iteration (Write); + + ----------- + -- Write -- + ----------- + + procedure Write (Node : Count_Type) is + begin + Write (Stream, HT.Nodes (Node)); + end Write; + + begin + Count_Type'Base'Write (Stream, HT.Length); + Write (HT); + end Generic_Write; + + ----------- + -- Index -- + ----------- + + function Index + (Buckets : Buckets_Type; + Node : Node_Type) return Hash_Type is + begin + return Buckets'First + Hash_Node (Node) mod Buckets'Length; + end Index; + + function Index + (HT : Hash_Table_Type; + Node : Node_Type) return Hash_Type is + begin + return Index (HT.Buckets, Node); + end Index; + + ---------- + -- Next -- + ---------- + + function Next + (HT : Hash_Table_Type; + Node : Count_Type) return Count_Type + is + Result : Count_Type; + First : Hash_Type; + + begin + Result := Next (HT.Nodes (Node)); + + if Result /= 0 then -- another node in same bucket + return Result; + end if; + + -- This was the last node in the bucket, so move to the next + -- bucket, and start searching for next node from there. + + First := Index (HT, HT.Nodes (Node)) + 1; + for Indx in First .. HT.Buckets'Last loop + Result := HT.Buckets (Indx); + + if Result /= 0 then -- bucket is not empty + return Result; + end if; + end loop; + + return 0; + end Next; + +end Ada.Containers.Hash_Tables.Generic_Formal_Operations; diff --git a/gcc/ada/libgnat/a-chtgfo.ads b/gcc/ada/libgnat/a-chtgfo.ads new file mode 100644 index 0000000..043b732 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgfo.ads @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2022, 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/>. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Hash_Table_Type is used to implement hashed containers. This package +-- declares hash-table operations that do not depend on keys. + +with Ada.Streams; + +generic + with package HT_Types is + new Generic_Formal_Hash_Table_Types (<>); + + use HT_Types; + + with function Hash_Node (Node : Node_Type) return Hash_Type; + + with function Next (Node : Node_Type) return Count_Type; + + with procedure Set_Next + (Node : in out Node_Type; + Next : Count_Type); + +package Ada.Containers.Hash_Tables.Generic_Formal_Operations is + pragma Pure; + + function Index + (Buckets : Buckets_Type; + Node : Node_Type) return Hash_Type; + pragma Inline (Index); + -- Uses the hash value of Node to compute its Buckets array index + + function Index + (HT : Hash_Table_Type; + Node : Node_Type) return Hash_Type; + pragma Inline (Index); + -- Uses the hash value of Node to compute its Hash_Table buckets array + -- index. + + generic + with function Find + (HT : Hash_Table_Type; + Key : Node_Type) return Boolean; + function Generic_Equal (L, R : Hash_Table_Type) return Boolean; + -- Used to implement hashed container equality. For each node in hash table + -- L, it calls Find to search for an equivalent item in hash table R. If + -- Find returns False for any node then Generic_Equal terminates + -- immediately and returns False. Otherwise if Find returns True for every + -- node then Generic_Equal returns True. + + procedure Clear (HT : in out Hash_Table_Type); + -- Empties the hash table HT + + procedure Delete_Node_Sans_Free + (HT : in out Hash_Table_Type; + X : Count_Type); + -- Removes node X from the hash table without deallocating the node + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (HT : in out Hash_Table_Type; + Node : out Count_Type); + -- Claim a node from the free store. Generic_Allocate first + -- calls Set_Element on the potential node, and then returns + -- the node's index as the value of the Node parameter. + + procedure Free + (HT : in out Hash_Table_Type; + X : Count_Type); + -- Return a node back to the free store, from where it had + -- been previously claimed via Generic_Allocate. + + function First (HT : Hash_Table_Type) return Count_Type; + -- Returns the head of the list in the first (lowest-index) non-empty + -- bucket. + + function Next + (HT : Hash_Table_Type; + Node : Count_Type) return Count_Type; + -- Returns the node that immediately follows Node. This corresponds to + -- either the next node in the same bucket, or (if Node is the last node in + -- its bucket) the head of the list in the first non-empty bucket that + -- follows. + + generic + with procedure Process (Node : Count_Type); + procedure Generic_Iteration (HT : Hash_Table_Type); + -- Calls Process for each node in hash table HT + + generic + use Ada.Streams; + with procedure Write + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + HT : Hash_Table_Type); + -- Used to implement the streaming attribute for hashed containers. It + -- calls Write for each node to write its value into Stream. + + generic + use Ada.Streams; + with function New_Node (Stream : not null access Root_Stream_Type'Class) + return Count_Type; + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + HT : out Hash_Table_Type); + -- Used to implement the streaming attribute for hashed containers. It + -- first clears hash table HT, then populates the hash table by calling + -- New_Node for each item in Stream. + +end Ada.Containers.Hash_Tables.Generic_Formal_Operations; diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb index 9a11f4c..b34df04 100644 --- a/gcc/ada/libgnat/a-cidlli.adb +++ b/gcc/ada/libgnat/a-cidlli.adb @@ -67,7 +67,7 @@ is Source : in out List; Position : Node_Access); - function Vet (Position : Cursor) return Boolean; + function Vet (Position : Cursor) return Boolean with Inline; -- Checks invariants of the cursor and its designated container, as a -- simple way of detecting dangling references (see operation Free for a -- description of the detection mechanism), returning True if all checks @@ -2103,6 +2103,10 @@ is function Vet (Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = null then return Position.Container = null; end if; diff --git a/gcc/ada/libgnat/a-cidlli.ads b/gcc/ada/libgnat/a-cidlli.ads index 35ca010..cc0c70c 100644 --- a/gcc/ada/libgnat/a-cidlli.ads +++ b/gcc/ada/libgnat/a-cidlli.ads @@ -368,10 +368,10 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased List'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cihama.adb b/gcc/ada/libgnat/a-cihama.adb index 4734e64..30a2f4d 100644 --- a/gcc/ada/libgnat/a-cihama.adb +++ b/gcc/ada/libgnat/a-cihama.adb @@ -85,7 +85,7 @@ is procedure Set_Next (Node : Node_Access; Next : Node_Access); pragma Inline (Set_Next); - function Vet (Position : Cursor) return Boolean; + function Vet (Position : Cursor) return Boolean with Inline; procedure Write_Node (Stream : not null access Root_Stream_Type'Class; @@ -1299,6 +1299,10 @@ is function Vet (Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = null then return Position.Container = null; end if; diff --git a/gcc/ada/libgnat/a-cihama.ads b/gcc/ada/libgnat/a-cihama.ads index 8a5f180..142c94e 100644 --- a/gcc/ada/libgnat/a-cihama.ads +++ b/gcc/ada/libgnat/a-cihama.ads @@ -440,10 +440,9 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cihase.adb b/gcc/ada/libgnat/a-cihase.adb index cb55bbb..0a9aabd 100644 --- a/gcc/ada/libgnat/a-cihase.adb +++ b/gcc/ada/libgnat/a-cihase.adb @@ -99,7 +99,7 @@ is procedure Set_Next (Node : Node_Access; Next : Node_Access); pragma Inline (Set_Next); - function Vet (Position : Cursor) return Boolean; + function Vet (Position : Cursor) return Boolean with Inline; procedure Write_Node (Stream : not null access Root_Stream_Type'Class; @@ -1932,6 +1932,10 @@ is function Vet (Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = null then return Position.Container = null; end if; @@ -2027,6 +2031,64 @@ is Element_Type'Output (Stream, Node.Element.all); end Write_Node; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + pragma Assert ((Position.Container = null) = (Position.Node = null), + "bad nullity in Has_Element"); + return Position.Container = Container'Unrestricted_Access; + end Has_Element; + + function Tampering_With_Cursors_Prohibited + (Container : Set) return Boolean + is + begin + return Is_Busy (Container.HT.TC); + end Tampering_With_Cursors_Prohibited; + + function Element (Container : Set; Position : Cursor) return Element_Type is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + return Element (Position); + end Element; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)) is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + Query_Element (Position, Process); + end Query_Element; + + function Next (Container : Set; Position : Cursor) return Cursor is + begin + if Checks and then + not (Position = No_Element or else Has_Element (Container, Position)) + then + raise Program_Error with "Position for wrong Container"; + end if; + + return Next (Position); + end Next; + + procedure Next (Container : Set; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + ------------------ + -- Generic_Keys -- + ------------------ + package body Generic_Keys is ----------------------- diff --git a/gcc/ada/libgnat/a-cihase.ads b/gcc/ada/libgnat/a-cihase.ads index cff713d..f0b0f15 100644 --- a/gcc/ada/libgnat/a-cihase.ads +++ b/gcc/ada/libgnat/a-cihase.ads @@ -355,6 +355,25 @@ is function Iterate (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean; + + function Tampering_With_Cursors_Prohibited (Container : Set) return Boolean; + + function Element (Container : Set; Position : Cursor) return Element_Type; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + function Next (Container : Set; Position : Cursor) return Cursor; + + procedure Next (Container : Set; Position : in out Cursor); + + ---------------- + generic type Key_Type (<>) is private; @@ -370,6 +389,9 @@ is -- Applies generic formal operation Key to the element of the node -- designated by Position. + function Key (Container : Set; Position : Cursor) return Key_Type is + (Key (Element (Container, Position))); + function Element (Container : Set; Key : Key_Type) return Element_Type; -- Searches (as per the key-based Find) for the node containing Key, and -- returns the associated element. @@ -567,10 +589,9 @@ private for Constant_Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cimutr.ads b/gcc/ada/libgnat/a-cimutr.ads index 2bb1208..8a39a5b 100644 --- a/gcc/ada/libgnat/a-cimutr.ads +++ b/gcc/ada/libgnat/a-cimutr.ads @@ -439,10 +439,7 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following function Pseudo_Reference (Container : aliased Tree'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-ciorma.ads b/gcc/ada/libgnat/a-ciorma.ads index e4fd90d..c240dcc 100644 --- a/gcc/ada/libgnat/a-ciorma.ads +++ b/gcc/ada/libgnat/a-ciorma.ads @@ -355,10 +355,10 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb index b23b252..d5502ea 100644 --- a/gcc/ada/libgnat/a-ciorse.adb +++ b/gcc/ada/libgnat/a-ciorse.adb @@ -721,6 +721,61 @@ is Deallocate (X); end Free; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean is + begin + pragma Assert + (Vet (Container.Tree, Position.Node), "bad cursor in Has_Element"); + pragma Assert ((Position.Container = null) = (Position.Node = null), + "bad nullity in Has_Element"); + return Position.Container = Container'Unrestricted_Access; + end Has_Element; + + function Tampering_With_Cursors_Prohibited + (Container : Set) return Boolean + is + begin + return Is_Busy (Container.Tree.TC); + end Tampering_With_Cursors_Prohibited; + + function Element (Container : Set; Position : Cursor) return Element_Type is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + return Element (Position); + end Element; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)) is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + Query_Element (Position, Process); + end Query_Element; + + function Next (Container : Set; Position : Cursor) return Cursor is + begin + if Checks and then + not (Position = No_Element or else Has_Element (Container, Position)) + then + raise Program_Error with "Position for wrong Container"; + end if; + + return Next (Position); + end Next; + + procedure Next (Container : Set; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + ------------------ -- Generic_Keys -- ------------------ diff --git a/gcc/ada/libgnat/a-ciorse.ads b/gcc/ada/libgnat/a-ciorse.ads index 13272e2..e40ebfa 100644 --- a/gcc/ada/libgnat/a-ciorse.ads +++ b/gcc/ada/libgnat/a-ciorse.ads @@ -238,6 +238,25 @@ is Start : Cursor) return Set_Iterator_Interfaces.Reversible_Iterator'class; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean; + + function Tampering_With_Cursors_Prohibited (Container : Set) return Boolean; + + function Element (Container : Set; Position : Cursor) return Element_Type; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + function Next (Container : Set; Position : Cursor) return Cursor; + + procedure Next (Container : Set; Position : in out Cursor); + + ---------------- + generic type Key_Type (<>) is private; @@ -251,6 +270,9 @@ is function Key (Position : Cursor) return Key_Type; + function Key (Container : Set; Position : Cursor) return Key_Type is + (Key (Element (Container, Position))); + function Element (Container : Set; Key : Key_Type) return Element_Type; procedure Replace @@ -432,10 +454,10 @@ private for Constant_Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-coboho.adb b/gcc/ada/libgnat/a-coboho.adb index db885b4..25d0777 100644 --- a/gcc/ada/libgnat/a-coboho.adb +++ b/gcc/ada/libgnat/a-coboho.adb @@ -25,7 +25,7 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -with Unchecked_Conversion; +with Ada.Unchecked_Conversion; with System.Put_Images; package body Ada.Containers.Bounded_Holders is @@ -54,7 +54,7 @@ package body Ada.Containers.Bounded_Holders is end Size_In_Storage_Elements; function Cast is new - Unchecked_Conversion (System.Address, Element_Access); + Ada.Unchecked_Conversion (System.Address, Element_Access); --------- -- "=" -- diff --git a/gcc/ada/libgnat/a-cobove.ads b/gcc/ada/libgnat/a-cobove.ads index 8e0f80f..6f4b118 100644 --- a/gcc/ada/libgnat/a-cobove.ads +++ b/gcc/ada/libgnat/a-cobove.ads @@ -511,10 +511,10 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Vector'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cofove.adb b/gcc/ada/libgnat/a-cofove.adb index 5f10f57..c921184 100644 --- a/gcc/ada/libgnat/a-cofove.adb +++ b/gcc/ada/libgnat/a-cofove.adb @@ -370,7 +370,7 @@ is function Element (Container : Vector; - Index : Index_Type) return Element_Type + Index : Extended_Index) return Element_Type is begin if Index > Container.Last then diff --git a/gcc/ada/libgnat/a-cofove.ads b/gcc/ada/libgnat/a-cofove.ads index edf9532..6413375 100644 --- a/gcc/ada/libgnat/a-cofove.ads +++ b/gcc/ada/libgnat/a-cofove.ads @@ -45,6 +45,8 @@ generic package Ada.Containers.Formal_Vectors with SPARK_Mode is + pragma Annotate (GNATprove, Always_Return, Formal_Vectors); + -- Contracts in this unit are meant for analysis only, not for run-time -- checking. @@ -263,7 +265,7 @@ is function Element (Container : Vector; - Index : Index_Type) return Element_Type + Index : Extended_Index) return Element_Type with Global => null, Pre => Index in First_Index (Container) .. Last_Index (Container), diff --git a/gcc/ada/libgnat/a-cofuba.adb b/gcc/ada/libgnat/a-cofuba.adb index 77c0301..68cf2ae 100644 --- a/gcc/ada/libgnat/a-cofuba.adb +++ b/gcc/ada/libgnat/a-cofuba.adb @@ -52,6 +52,24 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is -- Resize the underlying array if needed so that it can contain one more -- element. + function Elements (C : Container) return Element_Array_Access is + (C.Controlled_Base.Base.Elements) + with + Global => null, + Pre => + C.Controlled_Base.Base /= null + and then C.Controlled_Base.Base.Elements /= null; + + function Get + (C_E : Element_Array_Access; + I : Count_Type) + return Element_Access + is + (C_E (I).Ref.E_Access) + with + Global => null, + Pre => C_E /= null and then C_E (I).Ref /= null; + --------- -- "=" -- --------- @@ -61,9 +79,8 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is if C1.Length /= C2.Length then return False; end if; - for I in 1 .. C1.Length loop - if C1.Base.Elements (I).all /= C2.Base.Elements (I).all then + if Get (Elements (C1), I).all /= Get (Elements (C2), I).all then return False; end if; end loop; @@ -78,7 +95,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is function "<=" (C1 : Container; C2 : Container) return Boolean is begin for I in 1 .. C1.Length loop - if Find (C2, C1.Base.Elements (I)) = 0 then + if Find (C2, Get (Elements (C1), I)) = 0 then return False; end if; end loop; @@ -95,50 +112,138 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is I : Index_Type; E : Element_Type) return Container is + C_B : Array_Base_Access renames C.Controlled_Base.Base; begin - if To_Count (I) = C.Length + 1 and then C.Length = C.Base.Max_Length then - Resize (C.Base); - C.Base.Max_Length := C.Base.Max_Length + 1; - C.Base.Elements (C.Base.Max_Length) := new Element_Type'(E); + if To_Count (I) = C.Length + 1 and then C.Length = C_B.Max_Length then + Resize (C_B); + C_B.Max_Length := C_B.Max_Length + 1; + C_B.Elements (C_B.Max_Length) := Element_Init (E); - return Container'(Length => C.Base.Max_Length, Base => C.Base); + return Container'(Length => C_B.Max_Length, + Controlled_Base => C.Controlled_Base); else declare - A : constant Array_Base_Access := Content_Init (C.Length); + A : constant Array_Base_Controlled_Access := + Content_Init (C.Length); P : Count_Type := 0; begin - A.Max_Length := C.Length + 1; + A.Base.Max_Length := C.Length + 1; for J in 1 .. C.Length + 1 loop if J /= To_Count (I) then P := P + 1; - A.Elements (J) := C.Base.Elements (P); + A.Base.Elements (J) := C_B.Elements (P); else - A.Elements (J) := new Element_Type'(E); + A.Base.Elements (J) := Element_Init (E); end if; end loop; - return Container'(Length => A.Max_Length, - Base => A); + return Container'(Length => A.Base.Max_Length, + Controlled_Base => A); end; end if; end Add; + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Controlled_Base : in out Array_Base_Controlled_Access) is + C_B : Array_Base_Access renames Controlled_Base.Base; + begin + if C_B /= null then + C_B.Reference_Count := C_B.Reference_Count + 1; + end if; + end Adjust; + + procedure Adjust (Ctrl_E : in out Controlled_Element_Access) is + begin + if Ctrl_E.Ref /= null then + Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count + 1; + end if; + end Adjust; + ------------------ -- Content_Init -- ------------------ - function Content_Init (L : Count_Type := 0) return Array_Base_Access + function Content_Init + (L : Count_Type := 0) return Array_Base_Controlled_Access is Max_Init : constant Count_Type := 100; Size : constant Count_Type := (if L < Count_Type'Last - Max_Init then L + Max_Init else Count_Type'Last); + + -- The Access in the array will be initialized to null + Elements : constant Element_Array_Access := new Element_Array'(1 .. Size => <>); + B : constant Array_Base_Access := + new Array_Base'(Reference_Count => 1, + Max_Length => 0, + Elements => Elements); begin - return new Array_Base'(Max_Length => 0, Elements => Elements); + return (Ada.Finalization.Controlled with Base => B); end Content_Init; + ------------------ + -- Element_Init -- + ------------------ + + function Element_Init (E : Element_Type) return Controlled_Element_Access + is + Refcounted_E : constant Refcounted_Element_Access := + new Refcounted_Element'(Reference_Count => 1, + E_Access => new Element_Type'(E)); + begin + return (Ada.Finalization.Controlled with Ref => Refcounted_E); + end Element_Init; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Controlled_Base : in out Array_Base_Controlled_Access) + is + procedure Unchecked_Free_Base is new Ada.Unchecked_Deallocation + (Object => Array_Base, + Name => Array_Base_Access); + procedure Unchecked_Free_Array is new Ada.Unchecked_Deallocation + (Object => Element_Array, + Name => Element_Array_Access); + + C_B : Array_Base_Access renames Controlled_Base.Base; + begin + if C_B /= null then + C_B.Reference_Count := C_B.Reference_Count - 1; + if C_B.Reference_Count = 0 then + Unchecked_Free_Array (Controlled_Base.Base.Elements); + Unchecked_Free_Base (Controlled_Base.Base); + end if; + C_B := null; + end if; + end Finalize; + + procedure Finalize (Ctrl_E : in out Controlled_Element_Access) is + procedure Unchecked_Free_Ref is new Ada.Unchecked_Deallocation + (Object => Refcounted_Element, + Name => Refcounted_Element_Access); + + procedure Unchecked_Free_Element is new Ada.Unchecked_Deallocation + (Object => Element_Type, + Name => Element_Access); + + begin + if Ctrl_E.Ref /= null then + Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count - 1; + if Ctrl_E.Ref.Reference_Count = 0 then + Unchecked_Free_Element (Ctrl_E.Ref.E_Access); + Unchecked_Free_Ref (Ctrl_E.Ref); + end if; + Ctrl_E.Ref := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -146,7 +251,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is function Find (C : Container; E : access Element_Type) return Count_Type is begin for I in 1 .. C.Length loop - if C.Base.Elements (I).all = E.all then + if Get (Elements (C), I).all = E.all then return I; end if; end loop; @@ -162,7 +267,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is --------- function Get (C : Container; I : Index_Type) return Element_Type is - (C.Base.Elements (To_Count (I)).all); + (Get (Elements (C), To_Count (I)).all); ------------------ -- Intersection -- @@ -170,19 +275,19 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is function Intersection (C1 : Container; C2 : Container) return Container is L : constant Count_Type := Num_Overlaps (C1, C2); - A : constant Array_Base_Access := Content_Init (L); + A : constant Array_Base_Controlled_Access := Content_Init (L); P : Count_Type := 0; begin - A.Max_Length := L; + A.Base.Max_Length := L; for I in 1 .. C1.Length loop - if Find (C2, C1.Base.Elements (I)) > 0 then + if Find (C2, Get (Elements (C1), I)) > 0 then P := P + 1; - A.Elements (P) := C1.Base.Elements (I); + A.Base.Elements (P) := Elements (C1) (I); end if; end loop; - return Container'(Length => P, Base => A); + return Container'(Length => P, Controlled_Base => A); end Intersection; ------------ @@ -199,7 +304,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is begin for I in 1 .. C1.Length loop - if Find (C2, C1.Base.Elements (I)) > 0 then + if Find (C2, Get (Elements (C1), I)) > 0 then P := P + 1; end if; end loop; @@ -214,21 +319,23 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is function Remove (C : Container; I : Index_Type) return Container is begin if To_Count (I) = C.Length then - return Container'(Length => C.Length - 1, Base => C.Base); + return Container'(Length => C.Length - 1, + Controlled_Base => C.Controlled_Base); else declare - A : constant Array_Base_Access := Content_Init (C.Length - 1); + A : constant Array_Base_Controlled_Access + := Content_Init (C.Length - 1); P : Count_Type := 0; begin - A.Max_Length := C.Length - 1; + A.Base.Max_Length := C.Length - 1; for J in 1 .. C.Length loop if J /= To_Count (I) then P := P + 1; - A.Elements (P) := C.Base.Elements (J); + A.Base.Elements (P) := Elements (C) (J); end if; end loop; - return Container'(Length => C.Length - 1, Base => A); + return Container'(Length => C.Length - 1, Controlled_Base => A); end; end if; end Remove; @@ -277,13 +384,14 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is E : Element_Type) return Container is Result : constant Container := - Container'(Length => C.Length, - Base => Content_Init (C.Length)); + Container'(Length => C.Length, + Controlled_Base => Content_Init (C.Length)); + R_Base : Array_Base_Access renames Result.Controlled_Base.Base; begin - Result.Base.Max_Length := C.Length; - Result.Base.Elements (1 .. C.Length) := C.Base.Elements (1 .. C.Length); - Result.Base.Elements (To_Count (I)) := new Element_Type'(E); + R_Base.Max_Length := C.Length; + R_Base.Elements (1 .. C.Length) := Elements (C) (1 .. C.Length); + R_Base.Elements (To_Count (I)) := Element_Init (E); return Result; end Set; @@ -305,20 +413,19 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is declare L : constant Count_Type := Length (C1) - N + Length (C2); - A : constant Array_Base_Access := Content_Init (L); + A : constant Array_Base_Controlled_Access := Content_Init (L); P : Count_Type := Length (C1); - begin - A.Max_Length := L; - A.Elements (1 .. C1.Length) := C1.Base.Elements (1 .. C1.Length); + A.Base.Max_Length := L; + A.Base.Elements (1 .. C1.Length) := Elements (C1) (1 .. C1.Length); for I in 1 .. C2.Length loop - if Find (C1, C2.Base.Elements (I)) = 0 then + if Find (C1, Get (Elements (C2), I)) = 0 then P := P + 1; - A.Elements (P) := C2.Base.Elements (I); + A.Base.Elements (P) := Elements (C2) (I); end if; end loop; - return Container'(Length => L, Base => A); + return Container'(Length => L, Controlled_Base => A); end; end Union; diff --git a/gcc/ada/libgnat/a-cofuba.ads b/gcc/ada/libgnat/a-cofuba.ads index eacf845..8a99a43 100644 --- a/gcc/ada/libgnat/a-cofuba.ads +++ b/gcc/ada/libgnat/a-cofuba.ads @@ -34,6 +34,10 @@ pragma Ada_2012; +-- To allow reference counting on the base container + +private with Ada.Finalization; + private generic type Index_Type is (<>); -- To avoid Constraint_Error being raised at run time, Index_Type'Base @@ -98,33 +102,97 @@ package Ada.Containers.Functional_Base with SPARK_Mode => Off is private + -- Theoretically, each operation on a functional container implies the + -- creation of a new container i.e. the copy of the array itself and all + -- the elements in it. In the implementation, most of these copies are + -- avoided by sharing between the containers. + -- + -- A container stores its last used index. So, when adding an + -- element at the end of the container, the exact same array can be reused. + -- As a functionnal container cannot be modifed once created, there is no + -- risk of unwanted modifications. + -- + -- _1_2_3_ + -- S : end => [1, 2, 3] + -- | + -- |1|2|3|4|.|.| + -- | + -- Add (S, 4, 4) : end => [1, 2, 3, 4] + -- + -- The elements are also shared between containers as much as possible. For + -- example, when something is added in the middle, the array is changed but + -- the elementes are reused. + -- + -- _1_2_3_4_ + -- S : |1|2|3|4| => [1, 2, 3, 4] + -- | \ \ \ + -- Add (S, 2, 5) : |1|5|2|3|4| => [1, 5, 2, 3, 4] + -- + -- To make this sharing possible, both the elements and the arrays are + -- stored inside dynamically allocated access types which shall be + -- deallocated when they are no longer used. The memory is managed using + -- reference counting both at the array and at the element level. + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + type Reference_Count_Type is new Natural; + type Element_Access is access all Element_Type; + type Refcounted_Element is record + Reference_Count : Reference_Count_Type; + E_Access : Element_Access; + end record; + + type Refcounted_Element_Access is access Refcounted_Element; + + type Controlled_Element_Access is new Ada.Finalization.Controlled + with record + Ref : Refcounted_Element_Access := null; + end record; + + function Element_Init (E : Element_Type) return Controlled_Element_Access; + -- Use to initialize a refcounted element + type Element_Array is - array (Positive_Count_Type range <>) of Element_Access; + array (Positive_Count_Type range <>) of Controlled_Element_Access; type Element_Array_Access_Base is access Element_Array; - subtype Element_Array_Access is not null Element_Array_Access_Base; - - Empty_Element_Array_Access : constant Element_Array_Access := - new Element_Array'(1 .. 0 => null); + subtype Element_Array_Access is Element_Array_Access_Base; type Array_Base is record - Max_Length : Count_Type; - Elements : Element_Array_Access; + Reference_Count : Reference_Count_Type; + Max_Length : Count_Type; + Elements : Element_Array_Access; + end record; + + type Array_Base_Access is access Array_Base; + + type Array_Base_Controlled_Access is new Ada.Finalization.Controlled + with record + Base : Array_Base_Access; end record; - type Array_Base_Access is not null access Array_Base; + overriding procedure Adjust + (Controlled_Base : in out Array_Base_Controlled_Access); + + overriding procedure Finalize + (Controlled_Base : in out Array_Base_Controlled_Access); + + overriding procedure Adjust + (Ctrl_E : in out Controlled_Element_Access); + + overriding procedure Finalize + (Ctrl_E : in out Controlled_Element_Access); - function Content_Init (L : Count_Type := 0) return Array_Base_Access; + function Content_Init (L : Count_Type := 0) + return Array_Base_Controlled_Access; -- Used to initialize the content of an array base with length L type Container is record - Length : Count_Type := 0; - Base : Array_Base_Access := Content_Init; + Length : Count_Type := 0; + Controlled_Base : Array_Base_Controlled_Access := Content_Init; end record; end Ada.Containers.Functional_Base; diff --git a/gcc/ada/libgnat/a-cofuma.adb b/gcc/ada/libgnat/a-cofuma.adb index 080229d..f83b4d8 100644 --- a/gcc/ada/libgnat/a-cofuma.adb +++ b/gcc/ada/libgnat/a-cofuma.adb @@ -34,6 +34,9 @@ package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is use Key_Containers; use Element_Containers; + package Conversions is new Signed_Conversions (Int => Count_Type); + use Conversions; + --------- -- "=" -- --------- @@ -130,6 +133,13 @@ package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is return True; end Elements_Equal_Except; + --------------- + -- Empty_Map -- + --------------- + + function Empty_Map return Map is + ((others => <>)); + --------- -- Get -- --------- @@ -238,9 +248,9 @@ package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is -- Length -- ------------ - function Length (Container : Map) return Count_Type is + function Length (Container : Map) return Big_Natural is begin - return Length (Container.Elements); + return To_Big_Integer (Length (Container.Elements)); end Length; ------------ diff --git a/gcc/ada/libgnat/a-cofuma.ads b/gcc/ada/libgnat/a-cofuma.ads index 3f61b63..f863cdc 100644 --- a/gcc/ada/libgnat/a-cofuma.ads +++ b/gcc/ada/libgnat/a-cofuma.ads @@ -32,6 +32,9 @@ pragma Ada_2012; private with Ada.Containers.Functional_Base; +with Ada.Numerics.Big_Numbers.Big_Integers; +use Ada.Numerics.Big_Numbers.Big_Integers; + generic type Key_Type (<>) is private; type Element_Type (<>) is private; @@ -46,7 +49,10 @@ generic -- of equivalence over keys is needed, that is, Equivalent_Keys defines a -- key uniquely. -package Ada.Containers.Functional_Maps with SPARK_Mode is +package Ada.Containers.Functional_Maps with + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is type Map is private with Default_Initial_Condition => Is_Empty (Map) and Length (Map) = 0, @@ -97,7 +103,7 @@ package Ada.Containers.Functional_Maps with SPARK_Mode is (Equivalent_Keys (K, Key) = (Witness (Container, Key) = Witness (Container, K))))); - function Length (Container : Map) return Count_Type with + function Length (Container : Map) return Big_Natural with Global => null; -- Return the number of mappings in Container @@ -233,9 +239,7 @@ package Ada.Containers.Functional_Maps with SPARK_Mode is with Global => null, - Pre => - not Has_Key (Container, New_Key) - and Length (Container) < Count_Type'Last, + Pre => not Has_Key (Container, New_Key), Post => Length (Container) + 1 = Length (Add'Result) and Has_Key (Add'Result, New_Key) @@ -243,6 +247,14 @@ package Ada.Containers.Functional_Maps with SPARK_Mode is and Container <= Add'Result and Keys_Included_Except (Add'Result, Container, New_Key); + function Empty_Map return Map with + -- Return an empty Map + + Global => null, + Post => + Length (Empty_Map'Result) = 0 + and Is_Empty (Empty_Map'Result); + function Remove (Container : Map; Key : Key_Type) return Map diff --git a/gcc/ada/libgnat/a-cofuse.adb b/gcc/ada/libgnat/a-cofuse.adb index 0157988..bbb3f7e 100644 --- a/gcc/ada/libgnat/a-cofuse.adb +++ b/gcc/ada/libgnat/a-cofuse.adb @@ -34,6 +34,9 @@ pragma Ada_2012; package body Ada.Containers.Functional_Sets with SPARK_Mode => Off is use Containers; + package Conversions is new Signed_Conversions (Int => Count_Type); + use Conversions; + --------- -- "=" -- --------- @@ -63,6 +66,13 @@ package body Ada.Containers.Functional_Sets with SPARK_Mode => Off is function Contains (Container : Set; Item : Element_Type) return Boolean is (Find (Container.Content, Item) > 0); + --------------- + -- Empty_Set -- + --------------- + + function Empty_Set return Set is + ((others => <>)); + --------------------- -- Included_Except -- --------------------- @@ -128,8 +138,8 @@ package body Ada.Containers.Functional_Sets with SPARK_Mode => Off is -- Length -- ------------ - function Length (Container : Set) return Count_Type is - (Length (Container.Content)); + function Length (Container : Set) return Big_Natural is + (To_Big_Integer (Length (Container.Content))); ----------------- -- Not_In_Both -- @@ -154,8 +164,8 @@ package body Ada.Containers.Functional_Sets with SPARK_Mode => Off is -- Num_Overlaps -- ------------------ - function Num_Overlaps (Left : Set; Right : Set) return Count_Type is - (Num_Overlaps (Left.Content, Right.Content)); + function Num_Overlaps (Left : Set; Right : Set) return Big_Natural is + (To_Big_Integer (Num_Overlaps (Left.Content, Right.Content))); ------------ -- Remove -- diff --git a/gcc/ada/libgnat/a-cofuse.ads b/gcc/ada/libgnat/a-cofuse.ads index db88b9a..ce52f61 100644 --- a/gcc/ada/libgnat/a-cofuse.ads +++ b/gcc/ada/libgnat/a-cofuse.ads @@ -32,6 +32,9 @@ pragma Ada_2012; private with Ada.Containers.Functional_Base; +with Ada.Numerics.Big_Numbers.Big_Integers; +use Ada.Numerics.Big_Numbers.Big_Integers; + generic type Element_Type (<>) is private; @@ -44,7 +47,10 @@ generic -- of equivalence over elements is needed, that is, Equivalent_Elements -- defines an element uniquely. -package Ada.Containers.Functional_Sets with SPARK_Mode is +package Ada.Containers.Functional_Sets with + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is type Set is private with Default_Initial_Condition => Is_Empty (Set), @@ -79,7 +85,7 @@ package Ada.Containers.Functional_Sets with SPARK_Mode is (if (for some E of Container => Equivalent_Elements (E, Item)) then Contains'Result)); - function Length (Container : Set) return Count_Type with + function Length (Container : Set) return Big_Natural with Global => null; -- Return the number of elements in Container @@ -183,7 +189,7 @@ package Ada.Containers.Functional_Sets with SPARK_Mode is No_Overlap'Result = (for all Item of Left => not Contains (Right, Item)); - function Num_Overlaps (Left : Set; Right : Set) return Count_Type with + function Num_Overlaps (Left : Set; Right : Set) return Big_Natural with -- Number of elements that are both in Left and Right Global => null, @@ -206,15 +212,19 @@ package Ada.Containers.Functional_Sets with SPARK_Mode is -- Return a new set containing all the elements of Container plus E Global => null, - Pre => - not Contains (Container, Item) - and Length (Container) < Count_Type'Last, + Pre => not Contains (Container, Item), Post => Length (Add'Result) = Length (Container) + 1 and Contains (Add'Result, Item) and Container <= Add'Result and Included_Except (Add'Result, Container, Item); + function Empty_Set return Set with + -- Return a new empty set + + Global => null, + Post => Is_Empty (Empty_Set'Result); + function Remove (Container : Set; Item : Element_Type) return Set with -- Return a new set containing all the elements of Container except E @@ -239,9 +249,6 @@ package Ada.Containers.Functional_Sets with SPARK_Mode is -- Returns the union of Left and Right Global => null, - Pre => - Length (Left) - Num_Overlaps (Left, Right) <= - Count_Type'Last - Length (Right), Post => Length (Union'Result) = Length (Left) - Num_Overlaps (Left, Right) + Length (Right) diff --git a/gcc/ada/libgnat/a-cofuve.adb b/gcc/ada/libgnat/a-cofuve.adb index 06075b1..0d91da5 100644 --- a/gcc/ada/libgnat/a-cofuve.adb +++ b/gcc/ada/libgnat/a-cofuve.adb @@ -118,6 +118,13 @@ package body Ada.Containers.Functional_Vectors with SPARK_Mode => Off is return False; end Contains; + -------------------- + -- Empty_Sequence -- + -------------------- + + function Empty_Sequence return Sequence is + ((others => <>)); + ------------------ -- Equal_Except -- ------------------ diff --git a/gcc/ada/libgnat/a-cofuve.ads b/gcc/ada/libgnat/a-cofuve.ads index ce3a3a4..8622221 100644 --- a/gcc/ada/libgnat/a-cofuve.ads +++ b/gcc/ada/libgnat/a-cofuve.ads @@ -40,7 +40,10 @@ generic type Element_Type (<>) is private; with function "=" (Left, Right : Element_Type) return Boolean is <>; -package Ada.Containers.Functional_Vectors with SPARK_Mode is +package Ada.Containers.Functional_Vectors with + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is subtype Extended_Index is Index_Type'Base range Index_Type'Pred (Index_Type'First) .. Index_Type'Last; @@ -343,6 +346,12 @@ package Ada.Containers.Functional_Vectors with SPARK_Mode is -- i.e. it does not contain pointers that could be used to alias mutable -- data). + function Empty_Sequence return Sequence with + -- Return an empty Sequence + + Global => null, + Post => Length (Empty_Sequence'Result) = 0; + --------------------------- -- Iteration Primitives -- --------------------------- diff --git a/gcc/ada/libgnat/a-cohama.adb b/gcc/ada/libgnat/a-cohama.adb index 2fcf4c8..013e2cd 100644 --- a/gcc/ada/libgnat/a-cohama.adb +++ b/gcc/ada/libgnat/a-cohama.adb @@ -80,7 +80,7 @@ is procedure Set_Next (Node : Node_Access; Next : Node_Access); pragma Inline (Set_Next); - function Vet (Position : Cursor) return Boolean; + function Vet (Position : Cursor) return Boolean with Inline; procedure Write_Node (Stream : not null access Root_Stream_Type'Class; @@ -1156,6 +1156,10 @@ is function Vet (Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = null then return Position.Container = null; end if; diff --git a/gcc/ada/libgnat/a-cohama.ads b/gcc/ada/libgnat/a-cohama.ads index 96ac164..65949dc 100644 --- a/gcc/ada/libgnat/a-cohama.ads +++ b/gcc/ada/libgnat/a-cohama.ads @@ -543,10 +543,9 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cohase.adb b/gcc/ada/libgnat/a-cohase.adb index e9662cc..4656868 100644 --- a/gcc/ada/libgnat/a-cohase.adb +++ b/gcc/ada/libgnat/a-cohase.adb @@ -99,7 +99,7 @@ is procedure Set_Next (Node : Node_Access; Next : Node_Access); pragma Inline (Set_Next); - function Vet (Position : Cursor) return Boolean; + function Vet (Position : Cursor) return Boolean with Inline; procedure Write_Node (Stream : not null access Root_Stream_Type'Class; @@ -1749,6 +1749,10 @@ is function Vet (Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = null then return Position.Container = null; end if; @@ -1840,6 +1844,64 @@ is Element_Type'Write (Stream, Node.Element); end Write_Node; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + pragma Assert ((Position.Container = null) = (Position.Node = null), + "bad nullity in Has_Element"); + return Position.Container = Container'Unrestricted_Access; + end Has_Element; + + function Tampering_With_Cursors_Prohibited + (Container : Set) return Boolean + is + begin + return Is_Busy (Container.HT.TC); + end Tampering_With_Cursors_Prohibited; + + function Element (Container : Set; Position : Cursor) return Element_Type is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + return Element (Position); + end Element; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)) is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + Query_Element (Position, Process); + end Query_Element; + + function Next (Container : Set; Position : Cursor) return Cursor is + begin + if Checks and then + not (Position = No_Element or else Has_Element (Container, Position)) + then + raise Program_Error with "Position for wrong Container"; + end if; + + return Next (Position); + end Next; + + procedure Next (Container : Set; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + ------------------ + -- Generic_Keys -- + ------------------ + package body Generic_Keys is ----------------------- diff --git a/gcc/ada/libgnat/a-cohase.ads b/gcc/ada/libgnat/a-cohase.ads index ada212c..bd82092 100644 --- a/gcc/ada/libgnat/a-cohase.ads +++ b/gcc/ada/libgnat/a-cohase.ads @@ -367,6 +367,25 @@ is function Iterate (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean; + + function Tampering_With_Cursors_Prohibited (Container : Set) return Boolean; + + function Element (Container : Set; Position : Cursor) return Element_Type; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + function Next (Container : Set; Position : Cursor) return Cursor; + + procedure Next (Container : Set; Position : in out Cursor); + + ---------------- + generic type Key_Type (<>) is private; @@ -382,6 +401,9 @@ is -- Applies generic formal operation Key to the element of the node -- designated by Position. + function Key (Container : Set; Position : Cursor) return Key_Type is + (Key (Element (Container, Position))); + function Element (Container : Set; Key : Key_Type) return Element_Type; -- Searches (as per the key-based Find) for the node containing Key, and -- returns the associated element. @@ -601,10 +623,9 @@ private for Constant_Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-cohata.ads b/gcc/ada/libgnat/a-cohata.ads index 2c56321..b9f775f 100644 --- a/gcc/ada/libgnat/a-cohata.ads +++ b/gcc/ada/libgnat/a-cohata.ads @@ -79,4 +79,23 @@ package Ada.Containers.Hash_Tables is package Implementation is new Helpers.Generic_Implementation; end Generic_Bounded_Hash_Table_Types; + generic + type Node_Type is private; + package Generic_Formal_Hash_Table_Types is + + type Nodes_Type is array (Count_Type range <>) of Node_Type; + type Buckets_Type is array (Hash_Type range <>) of Count_Type; + + type Hash_Table_Type + (Capacity : Count_Type; + Modulus : Hash_Type) is + record + Length : Count_Type := 0; + Free : Count_Type'Base := -1; + Nodes : Nodes_Type (1 .. Capacity); + Buckets : Buckets_Type (1 .. Modulus) := [others => 0]; + end record; + + end Generic_Formal_Hash_Table_Types; + end Ada.Containers.Hash_Tables; diff --git a/gcc/ada/libgnat/a-coinve.ads b/gcc/ada/libgnat/a-coinve.ads index 840ef5a..a3bc206 100644 --- a/gcc/ada/libgnat/a-coinve.ads +++ b/gcc/ada/libgnat/a-coinve.ads @@ -512,10 +512,10 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Vector'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-comutr.ads b/gcc/ada/libgnat/a-comutr.ads index 9b04a4b..7094452 100644 --- a/gcc/ada/libgnat/a-comutr.ads +++ b/gcc/ada/libgnat/a-comutr.ads @@ -491,10 +491,7 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following function Pseudo_Reference (Container : aliased Tree'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-conhel.adb b/gcc/ada/libgnat/a-conhel.adb index b24be67..46f1bcc 100644 --- a/gcc/ada/libgnat/a-conhel.adb +++ b/gcc/ada/libgnat/a-conhel.adb @@ -36,8 +36,6 @@ package body Ada.Containers.Helpers is package body Generic_Implementation is - use type SAC.Atomic_Unsigned; - ------------ -- Adjust -- ------------ @@ -133,7 +131,7 @@ package body Ada.Containers.Helpers is procedure TC_Check (T_Counts : Tamper_Counts) is begin if T_Check then - if T_Counts.Busy > 0 then + if Is_Busy (T_Counts) then raise Program_Error with "attempt to tamper with cursors"; end if; @@ -144,7 +142,7 @@ package body Ada.Containers.Helpers is -- Thus if the busy count is zero, then the lock count -- must also be zero. - pragma Assert (T_Counts.Lock = 0); + pragma Assert (not Is_Locked (T_Counts)); end if; end TC_Check; @@ -154,7 +152,7 @@ package body Ada.Containers.Helpers is procedure TE_Check (T_Counts : Tamper_Counts) is begin - if T_Check and then T_Counts.Lock > 0 then + if T_Check and then Is_Locked (T_Counts) then raise Program_Error with "attempt to tamper with elements"; end if; diff --git a/gcc/ada/libgnat/a-conhel.ads b/gcc/ada/libgnat/a-conhel.ads index 47811f5..92e23d0 100644 --- a/gcc/ada/libgnat/a-conhel.ads +++ b/gcc/ada/libgnat/a-conhel.ads @@ -121,9 +121,31 @@ package Ada.Containers.Helpers is pragma Inline (TE_Check); -- Tampering-with-elements check - ----------------- - -- RAII Types -- - ----------------- + --------------------------------------- + -- Queries of busy and locked status -- + --------------------------------------- + + -- These are never called when tampering checks are suppressed. + + use type SAC.Atomic_Unsigned; + + pragma Warnings (Off); + -- Otherwise, the -gnatw.n switch triggers unwanted warnings on the + -- references to atomic variables below. + + function Is_Busy (T_Counts : Tamper_Counts) return Boolean is + (if T_Check then T_Counts.Busy > 0 else raise Program_Error); + pragma Inline (Is_Busy); + + function Is_Locked (T_Counts : Tamper_Counts) return Boolean is + (if T_Check then T_Counts.Lock > 0 else raise Program_Error); + pragma Inline (Is_Locked); + + pragma Warnings (On); + + ---------------- + -- RAII Types -- + ---------------- -- Initialize of With_Busy increments the Busy count, and Finalize -- decrements it. Thus, to prohibit tampering with elements within a diff --git a/gcc/ada/libgnat/a-convec.ads b/gcc/ada/libgnat/a-convec.ads index c024ce5..1005985 100644 --- a/gcc/ada/libgnat/a-convec.ads +++ b/gcc/ada/libgnat/a-convec.ads @@ -829,10 +829,13 @@ private for Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. + -- Three operations are used to optimize the expansion of "for ... of" + -- loops: the Next(Cursor) (or Previous) procedure in the visible part, + -- and the following Pseudo_Reference and Get_Element_Access functions. + -- See Exp_Ch5 for details, including the leading underscores here. + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Vector'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-coorma.ads b/gcc/ada/libgnat/a-coorma.ads index 7922e7b..1948e2a 100644 --- a/gcc/ada/libgnat/a-coorma.ads +++ b/gcc/ada/libgnat/a-coorma.ads @@ -357,10 +357,10 @@ private for Reference_Type'Write use Write; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Map'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb index 7998ee8..848022e 100644 --- a/gcc/ada/libgnat/a-coorse.adb +++ b/gcc/ada/libgnat/a-coorse.adb @@ -643,6 +643,61 @@ is end if; end Free; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean is + begin + pragma Assert + (Vet (Container.Tree, Position.Node), "bad cursor in Has_Element"); + pragma Assert ((Position.Container = null) = (Position.Node = null), + "bad nullity in Has_Element"); + return Position.Container = Container'Unrestricted_Access; + end Has_Element; + + function Tampering_With_Cursors_Prohibited + (Container : Set) return Boolean + is + begin + return Is_Busy (Container.Tree.TC); + end Tampering_With_Cursors_Prohibited; + + function Element (Container : Set; Position : Cursor) return Element_Type is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + return Element (Position); + end Element; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)) is + begin + if Checks and then not Has_Element (Container, Position) then + raise Program_Error with "Position for wrong Container"; + end if; + + Query_Element (Position, Process); + end Query_Element; + + function Next (Container : Set; Position : Cursor) return Cursor is + begin + if Checks and then + not (Position = No_Element or else Has_Element (Container, Position)) + then + raise Program_Error with "Position for wrong Container"; + end if; + + return Next (Position); + end Next; + + procedure Next (Container : Set; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + ------------------ -- Generic_Keys -- ------------------ diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads index 1833336..8888a8c 100644 --- a/gcc/ada/libgnat/a-coorse.ads +++ b/gcc/ada/libgnat/a-coorse.ads @@ -231,6 +231,25 @@ is Start : Cursor) return Set_Iterator_Interfaces.Reversible_Iterator'class; + -- Ada 2022 features: + + function Has_Element (Container : Set; Position : Cursor) return Boolean; + + function Tampering_With_Cursors_Prohibited (Container : Set) return Boolean; + + function Element (Container : Set; Position : Cursor) return Element_Type; + + procedure Query_Element + (Container : Set; + Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + function Next (Container : Set; Position : Cursor) return Cursor; + + procedure Next (Container : Set; Position : in out Cursor); + + ---------------- + generic type Key_Type (<>) is private; @@ -244,6 +263,9 @@ is function Key (Position : Cursor) return Key_Type; + function Key (Container : Set; Position : Cursor) return Key_Type is + (Key (Element (Container, Position))); + function Element (Container : Set; Key : Key_Type) return Element_Type; procedure Replace @@ -415,10 +437,10 @@ private for Constant_Reference_Type'Read use Read; - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. + -- See Ada.Containers.Vectors for documentation on the following + + procedure _Next (Position : in out Cursor) renames Next; + procedure _Previous (Position : in out Cursor) renames Previous; function Pseudo_Reference (Container : aliased Set'Class) return Reference_Control_Type; diff --git a/gcc/ada/libgnat/a-crbtgo.adb b/gcc/ada/libgnat/a-crbtgo.adb index 7757aad..d689b1c 100644 --- a/gcc/ada/libgnat/a-crbtgo.adb +++ b/gcc/ada/libgnat/a-crbtgo.adb @@ -1060,6 +1060,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Node = null then return True; end if; diff --git a/gcc/ada/libgnat/a-crbtgo.ads b/gcc/ada/libgnat/a-crbtgo.ads index fde9c45..609fe4b 100644 --- a/gcc/ada/libgnat/a-crbtgo.ads +++ b/gcc/ada/libgnat/a-crbtgo.ads @@ -61,7 +61,8 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is -- procedure Check_Invariant (Tree : Tree_Type); - function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean; + function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean + with Inline; -- Inspects Node to determine (to the extent possible) whether -- the node is valid; used to detect if the node is dangling. diff --git a/gcc/ada/libgnat/a-crdlli.adb b/gcc/ada/libgnat/a-crdlli.adb index a5fe431..bdb6475 100644 --- a/gcc/ada/libgnat/a-crdlli.adb +++ b/gcc/ada/libgnat/a-crdlli.adb @@ -51,7 +51,7 @@ package body Ada.Containers.Restricted_Doubly_Linked_Lists is Before : Count_Type; New_Node : Count_Type); - function Vet (Position : Cursor) return Boolean; + function Vet (Position : Cursor) return Boolean with Inline; --------- -- "=" -- @@ -1330,6 +1330,10 @@ package body Ada.Containers.Restricted_Doubly_Linked_Lists is function Vet (Position : Cursor) return Boolean is begin + if not Container_Checks'Enabled then + return True; + end if; + if Position.Node = 0 then return Position.Container = null; end if; diff --git a/gcc/ada/libgnat/a-direct.adb b/gcc/ada/libgnat/a-direct.adb index 4d7288e..7a65587 100644 --- a/gcc/ada/libgnat/a-direct.adb +++ b/gcc/ada/libgnat/a-direct.adb @@ -38,7 +38,6 @@ use Ada.Directories.Hierarchical_File_Names; with Ada.Strings.Fixed; with Ada.Strings.Maps; use Ada.Strings.Maps; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; -with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -1404,11 +1403,11 @@ package body Ada.Directories is if Error /= 0 then Search.State.Dir_Contents.Append (Directory_Entry_Type' - [Valid => True, + (Valid => True, Name => To_Unbounded_String (File_Name), Full_Name => To_Unbounded_String (Path), Attr_Error_Code => Error, - others => <>]); + others => <>)); -- Otherwise, if the file exists and matches the file kind -- Filter, add the file to the search results. We capture @@ -1445,14 +1444,14 @@ package body Ada.Directories is if Found then Search.State.Dir_Contents.Append (Directory_Entry_Type' - [Valid => True, + (Valid => True, Name => To_Unbounded_String (File_Name), Full_Name => To_Unbounded_String (Path), Attr_Error_Code => 0, Kind => Kind, Modification_Time => Modification_Time (Path), - Size => Size]); + Size => Size)); end if; end if; end; diff --git a/gcc/ada/libgnat/a-exstat.adb b/gcc/ada/libgnat/a-exstat.adb index a3f808e..acc2516 100644 --- a/gcc/ada/libgnat/a-exstat.adb +++ b/gcc/ada/libgnat/a-exstat.adb @@ -109,13 +109,6 @@ package body Stream_Attributes is Raise_Exception (Program_Error'Identity, "bad exception occurrence in stream input"); - - -- The following junk raise of Program_Error is required because - -- this is a No_Return procedure, and unfortunately Raise_Exception - -- can return (this particular call can't, but the back end is not - -- clever enough to know that). - - raise Program_Error; end Bad_EO; procedure Next_String is diff --git a/gcc/ada/libgnat/a-nagefl.ads b/gcc/ada/libgnat/a-nagefl.ads index ad2e5e3..dc2a0f4 100644 --- a/gcc/ada/libgnat/a-nagefl.ads +++ b/gcc/ada/libgnat/a-nagefl.ads @@ -31,10 +31,10 @@ ------------------------------------------------------------------------------ -- This package provides the basic computational interface for the generic --- elementary functions. The C library version interfaces with the routines --- in the C mathematical library. +-- elementary functions. --- This version here is for use with normal Unix math functions. +-- This version here delegates to interfaces that typically import as +-- intrinsics the expected math functions. with Ada.Numerics.Aux_Long_Long_Float; with Ada.Numerics.Aux_Long_Float; diff --git a/gcc/ada/libgnat/a-nallfl.ads b/gcc/ada/libgnat/a-nallfl.ads index db849da..cf08fce 100644 --- a/gcc/ada/libgnat/a-nallfl.ads +++ b/gcc/ada/libgnat/a-nallfl.ads @@ -5,7 +5,7 @@ -- A D A . N U M E R I C S . A U X . L O N G _ L O N G _ F L O A T -- -- -- -- S p e c -- --- (C Math Library Version, Long Long Float) -- +-- (Instrinsic Version, Long Long Float) -- -- -- -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- -- -- @@ -30,9 +30,12 @@ -- -- ------------------------------------------------------------------------------ --- This package provides the basic computational interface for the generic --- elementary functions. The C library version interfaces with the routines --- in the C mathematical library, and is thus quite portable. +-- This package provides the basic computational interface for the +-- generic elementary functions. With the intrinsic version, the +-- compiler can use its knowledge of the functions to select the most +-- suitable implementation. It is thus quite portable. These +-- interfaces are suitable for cases in which Long Long Float and C's +-- long double share the same representation. with Ada.Numerics.Aux_Linker_Options; pragma Warnings (Off, Ada.Numerics.Aux_Linker_Options); @@ -42,7 +45,7 @@ package Ada.Numerics.Aux_Long_Long_Float is subtype T is Long_Long_Float; - -- We import these functions directly from C. Note that we label them + -- We import these functions as intrinsics. Note that we label them -- all as pure functions, because indeed all of them are in fact pure. function Sin (X : T) return T with diff --git a/gcc/ada/libgnat/a-nalofl.ads b/gcc/ada/libgnat/a-nalofl.ads index e4e440b..86d1fc2 100644 --- a/gcc/ada/libgnat/a-nalofl.ads +++ b/gcc/ada/libgnat/a-nalofl.ads @@ -5,7 +5,7 @@ -- A D A . N U M E R I C S . A U X _ L O N G _ F L O A T -- -- -- -- S p e c -- --- (C Math Library Version, Long Float) -- +-- (Intrinsic Version, Long Float) -- -- -- -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- -- -- @@ -30,9 +30,12 @@ -- -- ------------------------------------------------------------------------------ --- This package provides the basic computational interface for the generic --- elementary functions. The C library version interfaces with the routines --- in the C mathematical library, and is thus quite portable. +-- This package provides the basic computational interface for the +-- generic elementary functions. With the intrinsic version, the +-- compiler can use its knowledge of the functions to select the most +-- suitable implementation. It is thus quite portable. These +-- interfaces are suitable for cases in which Long Float and C's +-- double share the same representation. with Ada.Numerics.Aux_Linker_Options; pragma Warnings (Off, Ada.Numerics.Aux_Linker_Options); @@ -42,7 +45,7 @@ package Ada.Numerics.Aux_Long_Float is subtype T is Long_Float; - -- We import these functions directly from C. Note that we label them + -- We import these functions as intrinsics. Note that we label them -- all as pure functions, because indeed all of them are in fact pure. function Sin (X : T) return T with diff --git a/gcc/ada/libgnat/a-nalofl__simd.ads b/gcc/ada/libgnat/a-nalofl__simd.ads new file mode 100644 index 0000000..34a798b --- /dev/null +++ b/gcc/ada/libgnat/a-nalofl__simd.ads @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X _ L O N G _ F L O A T -- +-- -- +-- S p e c -- +-- (Intrinsic/SIMD Version, Long Float) -- +-- -- +-- Copyright (C) 1992-2022, 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 the basic computational interface for the +-- generic elementary functions. With the intrinsic/SIMD version, the +-- compiler can use its knowledge of the functions to select the most +-- suitable implementation, including a vector implementation. These +-- interfaces are suitable for cases in which Long Float and C's +-- double share the same representation. + +with Ada.Numerics.Aux_Linker_Options; +pragma Warnings (Off, Ada.Numerics.Aux_Linker_Options); + +package Ada.Numerics.Aux_Long_Float is + pragma Pure; + + subtype T is Long_Float; + + -- We import these functions as intrinsics. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure. + + function Sin (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sin"; + pragma Machine_Attribute (Sin, "simd", "notinbranch"); + + function Cos (X : T) return T with + Import, Convention => Intrinsic, External_Name => "cos"; + pragma Machine_Attribute (Cos, "simd", "notinbranch"); + + function Tan (X : T) return T with + Import, Convention => Intrinsic, External_Name => "tan"; + + function Exp (X : T) return T with + Import, Convention => Intrinsic, External_Name => "exp"; + pragma Machine_Attribute (Exp, "simd", "notinbranch"); + + function Sqrt (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sqrt"; + + function Log (X : T) return T with + Import, Convention => Intrinsic, External_Name => "log"; + pragma Machine_Attribute (Log, "simd", "notinbranch"); + + function Acos (X : T) return T with + Import, Convention => Intrinsic, External_Name => "acos"; + + function Asin (X : T) return T with + Import, Convention => Intrinsic, External_Name => "asin"; + + function Atan (X : T) return T with + Import, Convention => Intrinsic, External_Name => "atan"; + + function Sinh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sinh"; + + function Cosh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "cosh"; + + function Tanh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "tanh"; + + function Pow (X, Y : T) return T with + Import, Convention => Intrinsic, External_Name => "pow"; + pragma Machine_Attribute (Pow, "simd", "notinbranch"); + +end Ada.Numerics.Aux_Long_Float; diff --git a/gcc/ada/libgnat/a-nbnbin.ads b/gcc/ada/libgnat/a-nbnbin.ads index 1ba10da..ffb96d4 100644 --- a/gcc/ada/libgnat/a-nbnbin.ads +++ b/gcc/ada/libgnat/a-nbnbin.ads @@ -21,6 +21,8 @@ private with System; package Ada.Numerics.Big_Numbers.Big_Integers with Preelaborate is + pragma Annotate (GNATprove, Always_Return, Big_Integers); + type Big_Integer is private with Integer_Literal => From_Universal_Image, Put_Image => Put_Image; diff --git a/gcc/ada/libgnat/a-nbnbre.ads b/gcc/ada/libgnat/a-nbnbre.ads index 4118d2b..350d049 100644 --- a/gcc/ada/libgnat/a-nbnbre.ads +++ b/gcc/ada/libgnat/a-nbnbre.ads @@ -20,6 +20,8 @@ with Ada.Strings.Text_Buffers; use Ada.Strings.Text_Buffers; package Ada.Numerics.Big_Numbers.Big_Reals with Preelaborate is + pragma Annotate (GNATprove, Always_Return, Big_Reals); + type Big_Real is private with Real_Literal => From_Universal_Image, Put_Image => Put_Image; diff --git a/gcc/ada/libgnat/a-ngcefu.adb b/gcc/ada/libgnat/a-ngcefu.adb index eccb560..56beb0f 100644 --- a/gcc/ada/libgnat/a-ngcefu.adb +++ b/gcc/ada/libgnat/a-ngcefu.adb @@ -225,7 +225,7 @@ package body Ada.Numerics.Generic_Complex_Elementary_Functions is elsif abs Re (X) > 1.0 / Epsilon or else abs Im (X) > 1.0 / Epsilon then - Xt := Complex_One / X; + Xt := Complex_One / X; if Re (X) < 0.0 then Set_Re (Xt, PI - Re (Xt)); @@ -442,7 +442,7 @@ package body Ada.Numerics.Generic_Complex_Elementary_Functions is if abs Re (X) < Square_Root_Epsilon and then abs Im (X) < Square_Root_Epsilon then - return Complex_One / X; + return Complex_One / X; elsif Im (X) > Log_Inverse_Epsilon_2 then return -Complex_I; @@ -463,7 +463,7 @@ package body Ada.Numerics.Generic_Complex_Elementary_Functions is if abs Re (X) < Square_Root_Epsilon and then abs Im (X) < Square_Root_Epsilon then - return Complex_One / X; + return Complex_One / X; elsif Re (X) > Log_Inverse_Epsilon_2 then return Complex_One; diff --git a/gcc/ada/libgnat/a-ngelfu.ads b/gcc/ada/libgnat/a-ngelfu.ads index c8a31bb..75783ef 100644 --- a/gcc/ada/libgnat/a-ngelfu.ads +++ b/gcc/ada/libgnat/a-ngelfu.ads @@ -40,6 +40,7 @@ package Ada.Numerics.Generic_Elementary_Functions with SPARK_Mode => On is pragma Pure; + pragma Annotate (GNATprove, Always_Return, Generic_Elementary_Functions); -- Preconditions in this unit are meant for analysis only, not for run-time -- checking, so that the expected exceptions are raised when calling diff --git a/gcc/ada/libgnat/a-nlelfu.ads b/gcc/ada/libgnat/a-nlelfu.ads index 10b33e9..b3afd1f 100644 --- a/gcc/ada/libgnat/a-nlelfu.ads +++ b/gcc/ada/libgnat/a-nlelfu.ads @@ -19,3 +19,4 @@ package Ada.Numerics.Long_Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Long_Float); pragma Pure (Long_Elementary_Functions); +pragma Annotate (GNATprove, Always_Return, Long_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nllefu.ads b/gcc/ada/libgnat/a-nllefu.ads index 7089fc3..e137c67 100644 --- a/gcc/ada/libgnat/a-nllefu.ads +++ b/gcc/ada/libgnat/a-nllefu.ads @@ -19,3 +19,4 @@ package Ada.Numerics.Long_Long_Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Long_Long_Float); pragma Pure (Long_Long_Elementary_Functions); +pragma Annotate (GNATprove, Always_Return, Long_Long_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nselfu.ads b/gcc/ada/libgnat/a-nselfu.ads index 10b04ac..6797efd 100644 --- a/gcc/ada/libgnat/a-nselfu.ads +++ b/gcc/ada/libgnat/a-nselfu.ads @@ -19,3 +19,4 @@ package Ada.Numerics.Short_Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Short_Float); pragma Pure (Short_Elementary_Functions); +pragma Annotate (GNATprove, Always_Return, Short_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nuaufl.ads b/gcc/ada/libgnat/a-nuaufl.ads index e38ebb5..0ee5dfc 100644 --- a/gcc/ada/libgnat/a-nuaufl.ads +++ b/gcc/ada/libgnat/a-nuaufl.ads @@ -5,7 +5,7 @@ -- A D A . N U M E R I C S . A U X _ F L O A T -- -- -- -- S p e c -- --- (C Math Library Version, Float) -- +-- (Intrinsic Version, Float) -- -- -- -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- -- -- @@ -30,9 +30,12 @@ -- -- ------------------------------------------------------------------------------ --- This package provides the basic computational interface for the generic --- elementary functions. The C library version interfaces with the routines --- in the C mathematical library, and is thus quite portable. +-- This package provides the basic computational interface for the +-- generic elementary functions. With the intrinsic version, the +-- compiler can use its knowledge of the functions to select the most +-- suitable implementation. It is thus quite portable. These +-- interfaces are suitable for cases in which Float and C's float +-- share the same representation. with Ada.Numerics.Aux_Linker_Options; pragma Warnings (Off, Ada.Numerics.Aux_Linker_Options); @@ -42,7 +45,7 @@ package Ada.Numerics.Aux_Float is subtype T is Float; - -- We import these functions directly from C. Note that we label them + -- We import these functions as intrinsics. Note that we label them -- all as pure functions, because indeed all of them are in fact pure. function Sin (X : T) return T with diff --git a/gcc/ada/libgnat/a-nuaufl__simd.ads b/gcc/ada/libgnat/a-nuaufl__simd.ads new file mode 100644 index 0000000..0f335ac --- /dev/null +++ b/gcc/ada/libgnat/a-nuaufl__simd.ads @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X _ F L O A T -- +-- -- +-- S p e c -- +-- (Intrinsic/SIMD Version, Float) -- +-- -- +-- Copyright (C) 1992-2022, 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 the basic computational interface for the +-- generic elementary functions. With the intrinsic/SIMD version, the +-- compiler can use its knowledge of the functions to select the most +-- suitable implementation, including a vector implementation. These +-- interfaces are suitable for cases in which Float and C's float +-- share the same representation. + +with Ada.Numerics.Aux_Linker_Options; +pragma Warnings (Off, Ada.Numerics.Aux_Linker_Options); + +package Ada.Numerics.Aux_Float is + pragma Pure; + + subtype T is Float; + + -- We import these functions as intrinsics. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure. + + function Sin (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sinf"; + pragma Machine_Attribute (Sin, "simd", "notinbranch"); + + function Cos (X : T) return T with + Import, Convention => Intrinsic, External_Name => "cosf"; + pragma Machine_Attribute (Cos, "simd", "notinbranch"); + + function Tan (X : T) return T with + Import, Convention => Intrinsic, External_Name => "tanf"; + + function Exp (X : T) return T with + Import, Convention => Intrinsic, External_Name => "expf"; + pragma Machine_Attribute (Exp, "simd", "notinbranch"); + + function Sqrt (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sqrtf"; + + function Log (X : T) return T with + Import, Convention => Intrinsic, External_Name => "logf"; + pragma Machine_Attribute (Log, "simd", "notinbranch"); + + function Acos (X : T) return T with + Import, Convention => Intrinsic, External_Name => "acosf"; + + function Asin (X : T) return T with + Import, Convention => Intrinsic, External_Name => "asinf"; + + function Atan (X : T) return T with + Import, Convention => Intrinsic, External_Name => "atanf"; + + function Sinh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "sinhf"; + + function Cosh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "coshf"; + + function Tanh (X : T) return T with + Import, Convention => Intrinsic, External_Name => "tanhf"; + + function Pow (X, Y : T) return T with + Import, Convention => Intrinsic, External_Name => "powf"; + pragma Machine_Attribute (Pow, "simd", "notinbranch"); + +end Ada.Numerics.Aux_Float; diff --git a/gcc/ada/libgnat/a-nuelfu.ads b/gcc/ada/libgnat/a-nuelfu.ads index 149939b..d4fe745 100644 --- a/gcc/ada/libgnat/a-nuelfu.ads +++ b/gcc/ada/libgnat/a-nuelfu.ads @@ -19,3 +19,4 @@ package Ada.Numerics.Elementary_Functions is new Ada.Numerics.Generic_Elementary_Functions (Float); pragma Pure (Elementary_Functions); +pragma Annotate (GNATprove, Always_Return, Elementary_Functions); diff --git a/gcc/ada/libgnat/a-rbtgbo.adb b/gcc/ada/libgnat/a-rbtgbo.adb index c077788..0c3f25f 100644 --- a/gcc/ada/libgnat/a-rbtgbo.adb +++ b/gcc/ada/libgnat/a-rbtgbo.adb @@ -1038,8 +1038,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is Nodes : Nodes_Type renames Tree.Nodes; Node : Node_Type renames Nodes (Index); - begin + if not Container_Checks'Enabled then + return True; + end if; + if Parent (Node) = Index or else Left (Node) = Index or else Right (Node) = Index diff --git a/gcc/ada/libgnat/a-rbtgbo.ads b/gcc/ada/libgnat/a-rbtgbo.ads index 97c0ee0..b3e0106 100644 --- a/gcc/ada/libgnat/a-rbtgbo.ads +++ b/gcc/ada/libgnat/a-rbtgbo.ads @@ -70,7 +70,8 @@ package Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is function Max (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type; -- Returns the largest-valued node of the subtree rooted at Node - function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean; + function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean + with Inline; -- Inspects Node to determine (to the extent possible) whether -- the node is valid; used to detect if the node is dangling. diff --git a/gcc/ada/libgnat/a-stbubo.adb b/gcc/ada/libgnat/a-stbubo.adb index c1c73da..3e941b8 100644 --- a/gcc/ada/libgnat/a-stbubo.adb +++ b/gcc/ada/libgnat/a-stbubo.adb @@ -91,9 +91,9 @@ package body Ada.Strings.Text_Buffers.Bounded is -- forget to add corresponding assignment statement below. Dummy : array (1 .. 0) of Buffer_Type (0) := [others => - [Max_Characters => 0, Chars => <>, Indentation => <>, + (Max_Characters => 0, Chars => <>, Indentation => <>, Indent_Pending => <>, UTF_8_Length => <>, UTF_8_Column => <>, - All_7_Bits => <>, All_8_Bits => <>, Truncated => <>]]; + All_7_Bits => <>, All_8_Bits => <>, Truncated => <>)]; begin Buffer.Indentation := Defaulted.Indentation; Buffer.Indent_Pending := Defaulted.Indent_Pending; diff --git a/gcc/ada/libgnat/a-stbuun.adb b/gcc/ada/libgnat/a-stbuun.adb index e9ea528..eabcad1 100644 --- a/gcc/ada/libgnat/a-stbuun.adb +++ b/gcc/ada/libgnat/a-stbuun.adb @@ -104,9 +104,9 @@ package body Ada.Strings.Text_Buffers.Unbounded is -- forget to add corresponding assignment statement below. Dummy : array (1 .. 0) of Buffer_Type := [others => - [Indentation => <>, Indent_Pending => <>, UTF_8_Length => <>, + (Indentation => <>, Indent_Pending => <>, UTF_8_Length => <>, UTF_8_Column => <>, All_7_Bits => <>, All_8_Bits => <>, - List => <>, Last_Used => <>]]; + List => <>, Last_Used => <>)]; begin Buffer.Indentation := Defaulted.Indentation; Buffer.Indent_Pending := Defaulted.Indent_Pending; diff --git a/gcc/ada/libgnat/a-strbou.ads b/gcc/ada/libgnat/a-strbou.ads index a9ee3b2..678c345 100644 --- a/gcc/ada/libgnat/a-strbou.ads +++ b/gcc/ada/libgnat/a-strbou.ads @@ -49,6 +49,7 @@ with Ada.Strings.Search; package Ada.Strings.Bounded with SPARK_Mode is pragma Preelaborate; + pragma Annotate (GNATprove, Always_Return, Bounded); generic Max : Positive; @@ -68,6 +69,7 @@ package Ada.Strings.Bounded with SPARK_Mode is Post => Ignore, Contract_Cases => Ignore, Ghost => Ignore); + pragma Annotate (GNATprove, Always_Return, Generic_Bounded_Length); Max_Length : constant Positive := Max; @@ -1898,7 +1900,7 @@ package Ada.Strings.Bounded with SPARK_Mode is -- some characters of Source are remaining at the left. and then - (if New_Item'Length > Max_Length then + (if New_Item'Length >= Max_Length then -- New_Item covers all Max_Length characters @@ -1984,7 +1986,7 @@ package Ada.Strings.Bounded with SPARK_Mode is -- some characters of Source are remaining at the left. and then - (if New_Item'Length > Max_Length then + (if New_Item'Length >= Max_Length then -- New_Item covers all Max_Length characters diff --git a/gcc/ada/libgnat/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb index 7475254..a04bf9a 100644 --- a/gcc/ada/libgnat/a-strfix.adb +++ b/gcc/ada/libgnat/a-strfix.adb @@ -628,6 +628,11 @@ package body Ada.Strings.Fixed with SPARK_Mode is (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) := diff --git a/gcc/ada/libgnat/a-strfix.ads b/gcc/ada/libgnat/a-strfix.ads index 0d6c5d0..dee64ab 100644 --- a/gcc/ada/libgnat/a-strfix.ads +++ b/gcc/ada/libgnat/a-strfix.ads @@ -63,7 +63,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- The Move procedure copies characters from Source to Target. If Source -- has the same length as Target, then the effect is to assign Source to -- Target. If Source is shorter than Target then: @@ -168,7 +169,8 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); pragma Ada_05 (Index); function Index @@ -231,7 +233,8 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); pragma Ada_05 (Index); -- Each Index function searches, starting from From, for a slice of @@ -300,7 +303,8 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); function Index (Source : String; @@ -355,7 +359,8 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Index'Result = 0), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- If Going = Forward, returns: -- @@ -408,7 +413,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (J < Index'Result) = (Going = Forward) then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (J), Set)))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); function Index (Source : String; @@ -464,7 +470,8 @@ package Ada.Strings.Fixed with SPARK_Mode is or else (J > From) = (Going = Forward)) then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (J), Set)))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); pragma Ada_05 (Index); -- Index searches for the first or last occurrence of any of a set of -- characters (when Test=Inside), or any of the complement of a set of @@ -524,7 +531,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (J = From or else (J > From) = (Going = Forward)) then Source (J) = ' '))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); pragma Ada_05 (Index_Non_Blank); -- Returns Index (Source, Maps.To_Set(Space), From, Outside, Going) @@ -562,7 +570,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (J < Index_Non_Blank'Result) = (Going = Forward) then Source (J) = ' '))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns Index (Source, Maps.To_Set(Space), Outside, Going) function Count @@ -570,16 +579,18 @@ package Ada.Strings.Fixed with SPARK_Mode is Pattern : String; Mapping : Maps.Character_Mapping := Maps.Identity) return Natural with - Pre => Pattern'Length /= 0, - Global => null; + Pre => Pattern'Length /= 0, + Global => null, + Annotate => (GNATprove, Always_Return); function Count (Source : String; Pattern : String; Mapping : Maps.Character_Mapping_Function) return Natural with - Pre => Pattern'Length /= 0 and then Mapping /= null, - Global => null; + Pre => Pattern'Length /= 0 and then Mapping /= null, + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns the maximum number of nonoverlapping slices of Source that match -- Pattern with respect to Mapping. If Pattern is the null string then @@ -589,7 +600,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (Source : String; Set : Maps.Character_Set) return Natural with - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns the number of occurrences in Source of characters that are in -- Set. @@ -647,7 +659,8 @@ package Ada.Strings.Fixed with SPARK_Mode is then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (Last + 1), Set))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); pragma Ada_2012 (Find_Token); -- If Source is not the null string and From is not in Source'Range, then -- Index_Error is raised. Otherwise, First is set to the index of the first @@ -709,7 +722,8 @@ package Ada.Strings.Fixed with SPARK_Mode is then (Test = Inside) /= Ada.Strings.Maps.Is_In (Source (Last + 1), Set))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Equivalent to Find_Token (Source, Set, Source'First, Test, First, Last) ------------------------------------ @@ -738,7 +752,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (for all J in Source'Range => Translate'Result (J - Source'First + 1) = Mapping (Source (J))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); function Translate (Source : String; @@ -761,7 +776,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (for all J in Source'Range => Translate'Result (J - Source'First + 1) = Ada.Strings.Maps.Value (Mapping, Source (J))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns the string S whose length is Source'Length and such that S (I) -- is the character to which Mapping maps the corresponding element of @@ -771,27 +787,29 @@ package Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Mapping : Maps.Character_Mapping_Function) with - Pre => Mapping /= null, - Post => + Pre => Mapping /= null, + Post => -- Each character in Source after the call is the translation of the -- character at the same position before the call, through Mapping. (for all J in Source'Range => Source (J) = Mapping (Source'Old (J))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); procedure Translate (Source : in out String; Mapping : Maps.Character_Mapping) with - Post => + Post => -- Each character in Source after the call is the translation of the -- character at the same position before the call, through Mapping. (for all J in Source'Range => Source (J) = Ada.Strings.Maps.Value (Mapping, Source'Old (J))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Equivalent to Source := Translate(Source, Mapping) @@ -884,7 +902,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (Low - Source'First + By'Length + 1 .. Replace_Slice'Result'Last) = Source (Low .. Source'Last))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- If Low > Source'Last + 1, or High < Source'First - 1, then Index_Error -- is propagated. Otherwise: -- @@ -904,7 +923,7 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Left; Pad : Character := Space) with - Pre => + Pre => Low - 1 <= Source'Last and then High >= Source'First - 1 and then (if High >= Low @@ -916,7 +935,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Replace_Slice (Source, Low, High, By), @@ -962,7 +982,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (Before - Source'First + New_Item'Length + 1 .. Insert'Result'Last) = Source (Before .. Source'Last)), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Propagates Index_Error if Before is not in -- Source'First .. Source'Last + 1; otherwise, returns -- Source (Source'First .. Before - 1) @@ -974,13 +995,14 @@ package Ada.Strings.Fixed with SPARK_Mode is New_Item : String; Drop : Truncation := Error) with - Pre => + Pre => Before - 1 in Source'First - 1 .. Source'Last and then Source'Length <= Natural'Last - New_Item'Length, -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to Move (Insert (Source, Before, New_Item), Source, Drop) function Overwrite @@ -988,13 +1010,13 @@ package Ada.Strings.Fixed with SPARK_Mode is Position : Positive; New_Item : String) return String with - Pre => + Pre => Position - 1 in Source'First - 1 .. Source'Last and then (if Position - Source'First >= Source'Length - New_Item'Length then Position - Source'First <= Natural'Last - New_Item'Length), - Post => + Post => -- Lower bound of the returned string is 1 @@ -1029,7 +1051,8 @@ package Ada.Strings.Fixed with SPARK_Mode is (Position - Source'First + New_Item'Length + 1 .. Overwrite'Result'Last) = Source (Position + New_Item'Length .. Source'Last)), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Propagates Index_Error if Position is not in -- Source'First .. Source'Last + 1; otherwise, returns the string obtained -- from Source by consecutively replacing characters starting at Position @@ -1043,7 +1066,7 @@ package Ada.Strings.Fixed with SPARK_Mode is New_Item : String; Drop : Truncation := Right) with - Pre => + Pre => Position - 1 in Source'First - 1 .. Source'Last and then (if Position - Source'First >= Source'Length - New_Item'Length @@ -1051,7 +1074,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to Move(Overwrite(Source, Position, New_Item), Source, Drop) function Delete @@ -1099,7 +1123,8 @@ package Ada.Strings.Fixed with SPARK_Mode is others => Delete'Result'Length = Source'Length and then Delete'Result = Source), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- If From <= Through, the returned string is -- Replace_Slice(Source, From, Through, ""); otherwise, it is Source with -- lower bound 1. @@ -1111,13 +1136,14 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Left; Pad : Character := Space) with - Pre => (if From <= Through - then (From in Source'Range - and then Through <= Source'Last)), + Pre => (if From <= Through + then (From in Source'Range + and then Through <= Source'Last)), -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Delete (Source, From, Through), @@ -1131,7 +1157,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (Source : String; Side : Trim_End) return String with - Post => + Post => -- Lower bound of the returned string is 1 @@ -1156,7 +1182,8 @@ package Ada.Strings.Fixed with SPARK_Mode is else Index_Non_Blank (Source, Backward)); begin Trim'Result = Source (Low .. High))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns the string obtained by removing from Source all leading Space -- characters (if Side = Left), all trailing Space characters (if -- Side = Right), or all leading and trailing Space characters (if @@ -1171,7 +1198,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Trim (Source, Side), Source, Justify=>Justify, Pad=>Pad). @@ -1208,7 +1236,8 @@ package Ada.Strings.Fixed with SPARK_Mode is Index (Source, Right, Outside, Backward); begin Trim'Result = Source (Low .. High))), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns the string obtained by removing from Source all leading -- characters in Left and all trailing characters in Right. @@ -1222,7 +1251,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Trim (Source, Left, Right), @@ -1259,7 +1289,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then Head'Result (Source'Length + 1 .. Count) = [1 .. Count - Source'Length => Pad]), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns a string of length Count. If Count <= Source'Length, the string -- comprises the first Count characters of Source. Otherwise, its contents -- are Source concatenated with Count - Source'Length Pad characters. @@ -1273,7 +1304,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Head (Source, Count, Pad), @@ -1322,7 +1354,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then Tail'Result (Count - Source'Length + 1 .. Tail'Result'Last) = Source)), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- Returns a string of length Count. If Count <= Source'Length, the string -- comprises the last Count characters of Source. Otherwise, its contents -- are Count-Source'Length Pad characters concatenated with Source. @@ -1336,7 +1369,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Incomplete contract - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); -- Equivalent to: -- -- Move (Tail (Source, Count, Pad), @@ -1350,7 +1384,7 @@ package Ada.Strings.Fixed with SPARK_Mode is (Left : Natural; Right : Character) return String with - Post => + Post => -- Lower bound of the returned string is 1 @@ -1363,7 +1397,8 @@ package Ada.Strings.Fixed with SPARK_Mode is -- All characters of the returned string are Right and then (for all C of "*"'Result => C = Right), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); function "*" (Left : Natural; @@ -1386,7 +1421,8 @@ package Ada.Strings.Fixed with SPARK_Mode is and then (for all K in "*"'Result'Range => "*"'Result (K) = Right (Right'First + (K - 1) mod Right'Length)), - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); -- These functions replicate a character or string a specified number of -- times. The first function returns a string whose length is Left and each diff --git a/gcc/ada/libgnat/a-strmap.ads b/gcc/ada/libgnat/a-strmap.ads index 476f772..1f22883 100644 --- a/gcc/ada/libgnat/a-strmap.ads +++ b/gcc/ada/libgnat/a-strmap.ads @@ -54,6 +54,8 @@ is pragma Pure; -- In accordance with Ada 2005 AI-362 + pragma Annotate (GNATprove, Always_Return, Maps); + -------------------------------- -- Character Set Declarations -- -------------------------------- diff --git a/gcc/ada/libgnat/a-strsea.ads b/gcc/ada/libgnat/a-strsea.ads index 157c6f3..22a0492 100644 --- a/gcc/ada/libgnat/a-strsea.ads +++ b/gcc/ada/libgnat/a-strsea.ads @@ -52,6 +52,7 @@ with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function; package Ada.Strings.Search with SPARK_Mode is pragma Preelaborate; + pragma Annotate (GNATprove, Always_Return, Search); -- The ghost function Match tells whether the slice of Source starting at -- From and of length Pattern'Length matches with Pattern with respect to diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb index 2c1b459..e301564 100644 --- a/gcc/ada/libgnat/a-strsup.adb +++ b/gcc/ada/libgnat/a-strsup.adb @@ -1150,6 +1150,14 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Result.Data (Position .. Position - 1 + New_Item'Length) := Super_String_Data (New_Item); Result.Current_Length := Source.Current_Length; + pragma Assert + (String'(Super_Slice (Result, 1, Position - 1)) = + Super_Slice (Source, 1, Position - 1)); + pragma Assert + (Super_Slice (Result, + Position, Position - 1 + New_Item'Length) = + New_Item); + return Result; elsif Position - 1 <= Max_Length - New_Item'Length then @@ -1157,6 +1165,14 @@ package body Ada.Strings.Superbounded with SPARK_Mode is Result.Data (Position .. Position - 1 + New_Item'Length) := Super_String_Data (New_Item); Result.Current_Length := Position - 1 + New_Item'Length; + pragma Assert + (String'(Super_Slice (Result, 1, Position - 1)) = + Super_Slice (Source, 1, Position - 1)); + pragma Assert + (Super_Slice (Result, + Position, Position - 1 + New_Item'Length) = + New_Item); + return Result; else @@ -1189,6 +1205,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is end case; Result.Current_Length := Max_Length; + pragma Assert (Super_Length (Result) = Source.Max_Length); return Result; end if; end Super_Overwrite; @@ -1226,7 +1243,7 @@ package body Ada.Strings.Superbounded with SPARK_Mode is (New_Item (New_Item'First .. New_Item'Last - Droplen)); when Strings.Left => - if New_Item'Length > Max_Length then + if New_Item'Length >= Max_Length then Source.Data (1 .. Max_Length) := Super_String_Data (New_Item (New_Item'Last - Max_Length + 1 .. New_Item'Last)); diff --git a/gcc/ada/libgnat/a-strsup.ads b/gcc/ada/libgnat/a-strsup.ads index 19e333c..416fa7b 100644 --- a/gcc/ada/libgnat/a-strsup.ads +++ b/gcc/ada/libgnat/a-strsup.ads @@ -2000,7 +2000,7 @@ package Ada.Strings.Superbounded with SPARK_Mode is -- Source are remaining at the left. and then - (if New_Item'Length > Source.Max_Length then + (if New_Item'Length >= Source.Max_Length then -- New_Item covers all Max_Length characters @@ -2089,7 +2089,7 @@ package Ada.Strings.Superbounded with SPARK_Mode is -- Source are remaining at the left. and then - (if New_Item'Length > Source.Max_Length then + (if New_Item'Length >= Source.Max_Length then -- New_Item covers all Max_Length characters diff --git a/gcc/ada/libgnat/a-strunb.adb b/gcc/ada/libgnat/a-strunb.adb index e97ee3d..f8e880e 100644 --- a/gcc/ada/libgnat/a-strunb.adb +++ b/gcc/ada/libgnat/a-strunb.adb @@ -721,7 +721,7 @@ package body Ada.Strings.Unbounded is Realloc_For_Chunk (Source, New_Item'Length); Source.Reference - (Before + New_Item'Length .. Source.Last + New_Item'Length) := + (Before + New_Item'Length .. Source.Last + New_Item'Length) := Source.Reference (Before .. Source.Last); Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; diff --git a/gcc/ada/libgnat/a-strunb.ads b/gcc/ada/libgnat/a-strunb.ads index 37c9466..6997594 100644 --- a/gcc/ada/libgnat/a-strunb.ads +++ b/gcc/ada/libgnat/a-strunb.ads @@ -57,6 +57,7 @@ package Ada.Strings.Unbounded with Initial_Condition => Length (Null_Unbounded_String) = 0 is pragma Preelaborate; + pragma Annotate (GNATprove, Always_Return, Unbounded); type Unbounded_String is private with Default_Initial_Condition => Length (Unbounded_String) = 0; diff --git a/gcc/ada/libgnat/a-strunb__shared.ads b/gcc/ada/libgnat/a-strunb__shared.ads index 8d00d0b..e5be454 100644 --- a/gcc/ada/libgnat/a-strunb__shared.ads +++ b/gcc/ada/libgnat/a-strunb__shared.ads @@ -86,6 +86,7 @@ package Ada.Strings.Unbounded with Initial_Condition => Length (Null_Unbounded_String) = 0 is pragma Preelaborate; + pragma Annotate (GNATprove, Always_Return, Unbounded); type Unbounded_String is private with Default_Initial_Condition => Length (Unbounded_String) = 0; diff --git a/gcc/ada/libgnat/a-stuten.ads b/gcc/ada/libgnat/a-stuten.ads index 209c84a..618f5b0 100644 --- a/gcc/ada/libgnat/a-stuten.ads +++ b/gcc/ada/libgnat/a-stuten.ads @@ -36,8 +36,8 @@ -- UTF encoded strings. Note: this package is consistent with Ada 95, and may -- be used in Ada 95 or Ada 2005 mode. +with Ada.Unchecked_Conversion; with Interfaces; -with Unchecked_Conversion; package Ada.Strings.UTF_Encoding is pragma Pure (UTF_Encoding); @@ -106,13 +106,13 @@ package Ada.Strings.UTF_Encoding is private function To_Unsigned_8 is new - Unchecked_Conversion (Character, Interfaces.Unsigned_8); + Ada.Unchecked_Conversion (Character, Interfaces.Unsigned_8); function To_Unsigned_16 is new - Unchecked_Conversion (Wide_Character, Interfaces.Unsigned_16); + Ada.Unchecked_Conversion (Wide_Character, Interfaces.Unsigned_16); function To_Unsigned_32 is new - Unchecked_Conversion (Wide_Wide_Character, Interfaces.Unsigned_32); + Ada.Unchecked_Conversion (Wide_Wide_Character, Interfaces.Unsigned_32); subtype UTF_XE_Encoding is Encoding_Scheme range UTF_16BE .. UTF_16LE; -- Subtype containing only UTF_16BE and UTF_16LE entries diff --git a/gcc/ada/libgnat/a-stwiun.adb b/gcc/ada/libgnat/a-stwiun.adb index 76fc2ea..8773a62 100644 --- a/gcc/ada/libgnat/a-stwiun.adb +++ b/gcc/ada/libgnat/a-stwiun.adb @@ -718,7 +718,7 @@ package body Ada.Strings.Wide_Unbounded is Realloc_For_Chunk (Source, New_Item'Length); Source.Reference - (Before + New_Item'Length .. Source.Last + New_Item'Length) := + (Before + New_Item'Length .. Source.Last + New_Item'Length) := Source.Reference (Before .. Source.Last); Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; diff --git a/gcc/ada/libgnat/a-stzbou.ads b/gcc/ada/libgnat/a-stzbou.ads index 73d52dd..e316d66 100644 --- a/gcc/ada/libgnat/a-stzbou.ads +++ b/gcc/ada/libgnat/a-stzbou.ads @@ -493,11 +493,11 @@ package Ada.Strings.Wide_Wide_Bounded is -- the Wide_Wide_Superbounded package. Null_Bounded_Wide_Wide_String : constant Bounded_Wide_Wide_String := - [Max_Length => Max_Length, + (Max_Length => Max_Length, Current_Length => 0, Data => [1 .. Max_Length => - Wide_Wide_Superbounded.Wide_Wide_NUL]]; + Wide_Wide_Superbounded.Wide_Wide_NUL]); pragma Inline (To_Bounded_Wide_Wide_String); diff --git a/gcc/ada/libgnat/a-stzunb.adb b/gcc/ada/libgnat/a-stzunb.adb index 34cbc32..a92714c 100644 --- a/gcc/ada/libgnat/a-stzunb.adb +++ b/gcc/ada/libgnat/a-stzunb.adb @@ -726,7 +726,7 @@ package body Ada.Strings.Wide_Wide_Unbounded is Realloc_For_Chunk (Source, New_Item'Length); Source.Reference - (Before + New_Item'Length .. Source.Last + New_Item'Length) := + (Before + New_Item'Length .. Source.Last + New_Item'Length) := Source.Reference (Before .. Source.Last); Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; diff --git a/gcc/ada/libgnat/a-swmwco.ads b/gcc/ada/libgnat/a-swmwco.ads index f58424a..ed37718 100644 --- a/gcc/ada/libgnat/a-swmwco.ads +++ b/gcc/ada/libgnat/a-swmwco.ads @@ -66,27 +66,27 @@ private subtype WC is Wide_Character; Control_Ranges : aliased constant Wide_Character_Ranges := - [ (W.NUL, W.US), - (W.DEL, W.APC)]; + [(W.NUL, W.US), + (W.DEL, W.APC)]; Control_Set : constant Wide_Character_Set := (AF.Controlled with Control_Ranges'Unrestricted_Access); Graphic_Ranges : aliased constant Wide_Character_Ranges := - [ (W.Space, W.Tilde), - (WC'Val (256), WC'Last)]; + [(W.Space, W.Tilde), + (WC'Val (256), WC'Last)]; Graphic_Set : constant Wide_Character_Set := (AF.Controlled with Graphic_Ranges'Unrestricted_Access); Letter_Ranges : aliased constant Wide_Character_Ranges := - [ ('A', 'Z'), - (W.LC_A, W.LC_Z), - (W.UC_A_Grave, W.UC_O_Diaeresis), - (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), - (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)]; + [('A', 'Z'), + (W.LC_A, W.LC_Z), + (W.UC_A_Grave, W.UC_O_Diaeresis), + (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), + (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)]; Letter_Set : constant Wide_Character_Set := (AF.Controlled with @@ -126,7 +126,7 @@ private Basic_Ranges'Unrestricted_Access); Decimal_Digit_Ranges : aliased constant Wide_Character_Ranges := - [ ('0', '9')]; + [('0', '9')]; Decimal_Digit_Set : constant Wide_Character_Set := (AF.Controlled with @@ -167,21 +167,21 @@ private Special_Graphic_Ranges'Unrestricted_Access); ISO_646_Ranges : aliased constant Wide_Character_Ranges := - [ (W.NUL, W.DEL)]; + [(W.NUL, W.DEL)]; ISO_646_Set : constant Wide_Character_Set := (AF.Controlled with ISO_646_Ranges'Unrestricted_Access); Character_Ranges : aliased constant Wide_Character_Ranges := - [ (W.NUL, WC'Val (255))]; + [(W.NUL, WC'Val (255))]; Character_Set : constant Wide_Character_Set := (AF.Controlled with Character_Ranges'Unrestricted_Access); Lower_Case_Mapping : aliased constant Wide_Character_Mapping_Values := - [Length => 56, + (Length => 56, Domain => "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & @@ -247,14 +247,14 @@ private W.LC_U_Circumflex & W.LC_U_Diaeresis & W.LC_Y_Acute & - W.LC_Icelandic_Thorn]; + W.LC_Icelandic_Thorn); Lower_Case_Map : constant Wide_Character_Mapping := (AF.Controlled with Map => Lower_Case_Mapping'Unrestricted_Access); Upper_Case_Mapping : aliased constant Wide_Character_Mapping_Values := - [Length => 56, + (Length => 56, Domain => "abcdefghijklmnopqrstuvwxyz" & @@ -320,14 +320,14 @@ private W.UC_U_Circumflex & W.UC_U_Diaeresis & W.UC_Y_Acute & - W.UC_Icelandic_Thorn]; + W.UC_Icelandic_Thorn); Upper_Case_Map : constant Wide_Character_Mapping := (AF.Controlled with Upper_Case_Mapping'Unrestricted_Access); Basic_Mapping : aliased constant Wide_Character_Mapping_Values := - [Length => 55, + (Length => 55, Domain => W.UC_A_Grave & @@ -441,7 +441,7 @@ private 'u' & -- LC_U_Circumflex 'u' & -- LC_U_Diaeresis 'y' & -- LC_Y_Acute - 'y']; -- LC_Y_Diaeresis + 'y'); -- LC_Y_Diaeresis Basic_Map : constant Wide_Character_Mapping := (AF.Controlled with diff --git a/gcc/ada/libgnat/a-szmzco.ads b/gcc/ada/libgnat/a-szmzco.ads index 4d6eece..e8de549 100644 --- a/gcc/ada/libgnat/a-szmzco.ads +++ b/gcc/ada/libgnat/a-szmzco.ads @@ -66,27 +66,27 @@ private subtype WC is Wide_Wide_Character; Control_Ranges : aliased constant Wide_Wide_Character_Ranges := - [ (W.NUL, W.US), - (W.DEL, W.APC)]; + [(W.NUL, W.US), + (W.DEL, W.APC)]; Control_Set : constant Wide_Wide_Character_Set := (AF.Controlled with Control_Ranges'Unrestricted_Access); Graphic_Ranges : aliased constant Wide_Wide_Character_Ranges := - [ (W.Space, W.Tilde), - (WC'Val (256), WC'Last)]; + [(W.Space, W.Tilde), + (WC'Val (256), WC'Last)]; Graphic_Set : constant Wide_Wide_Character_Set := (AF.Controlled with Graphic_Ranges'Unrestricted_Access); Letter_Ranges : aliased constant Wide_Wide_Character_Ranges := - [ ('A', 'Z'), - (W.LC_A, W.LC_Z), - (W.UC_A_Grave, W.UC_O_Diaeresis), - (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), - (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)]; + [('A', 'Z'), + (W.LC_A, W.LC_Z), + (W.UC_A_Grave, W.UC_O_Diaeresis), + (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), + (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)]; Letter_Set : constant Wide_Wide_Character_Set := (AF.Controlled with @@ -126,7 +126,7 @@ private Basic_Ranges'Unrestricted_Access); Decimal_Digit_Ranges : aliased constant Wide_Wide_Character_Ranges := - [ ('0', '9')]; + [('0', '9')]; Decimal_Digit_Set : constant Wide_Wide_Character_Set := (AF.Controlled with @@ -167,21 +167,21 @@ private Special_Graphic_Ranges'Unrestricted_Access); ISO_646_Ranges : aliased constant Wide_Wide_Character_Ranges := - [ (W.NUL, W.DEL)]; + [(W.NUL, W.DEL)]; ISO_646_Set : constant Wide_Wide_Character_Set := (AF.Controlled with ISO_646_Ranges'Unrestricted_Access); Character_Ranges : aliased constant Wide_Wide_Character_Ranges := - [ (W.NUL, WC'Val (255))]; + [(W.NUL, WC'Val (255))]; Character_Set : constant Wide_Wide_Character_Set := (AF.Controlled with Character_Ranges'Unrestricted_Access); Lower_Case_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := - [Length => 56, + (Length => 56, Domain => "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & @@ -247,14 +247,14 @@ private W.LC_U_Circumflex & W.LC_U_Diaeresis & W.LC_Y_Acute & - W.LC_Icelandic_Thorn]; + W.LC_Icelandic_Thorn); Lower_Case_Map : constant Wide_Wide_Character_Mapping := (AF.Controlled with Map => Lower_Case_Mapping'Unrestricted_Access); Upper_Case_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := - [Length => 56, + (Length => 56, Domain => "abcdefghijklmnopqrstuvwxyz" & @@ -320,14 +320,14 @@ private W.UC_U_Circumflex & W.UC_U_Diaeresis & W.UC_Y_Acute & - W.UC_Icelandic_Thorn]; + W.UC_Icelandic_Thorn); Upper_Case_Map : constant Wide_Wide_Character_Mapping := (AF.Controlled with Upper_Case_Mapping'Unrestricted_Access); Basic_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := - [Length => 55, + (Length => 55, Domain => W.UC_A_Grave & @@ -441,7 +441,7 @@ private 'u' & -- LC_U_Circumflex 'u' & -- LC_U_Diaeresis 'y' & -- LC_Y_Acute - 'y']; -- LC_Y_Diaeresis + 'y'); -- LC_Y_Diaeresis Basic_Map : constant Wide_Wide_Character_Mapping := (AF.Controlled with diff --git a/gcc/ada/libgnat/a-textio.ads b/gcc/ada/libgnat/a-textio.ads index 7c2ec10..447023d 100644 --- a/gcc/ada/libgnat/a-textio.ads +++ b/gcc/ada/libgnat/a-textio.ads @@ -101,14 +101,15 @@ is Name : String := ""; Form : String := "") with - Pre => not Is_Open (File), - Post => + Pre => not Is_Open (File), + Post => Is_Open (File) and then Ada.Text_IO.Mode (File) = Mode and then (if Mode /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Open (File : in out File_Type; @@ -116,54 +117,63 @@ is Name : String; Form : String := "") with - Pre => not Is_Open (File), - Post => + Pre => not Is_Open (File), + Post => Is_Open (File) and then Ada.Text_IO.Mode (File) = Mode and then (if Mode /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Close (File : in out File_Type) with - Pre => Is_Open (File), - Post => not Is_Open (File), - Global => (In_Out => File_System); + Pre => Is_Open (File), + Post => not Is_Open (File), + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Delete (File : in out File_Type) with - Pre => Is_Open (File), - Post => not Is_Open (File), - Global => (In_Out => File_System); + Pre => Is_Open (File), + Post => not Is_Open (File), + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Reset (File : in out File_Type; Mode : File_Mode) with - Pre => Is_Open (File), - Post => + Pre => Is_Open (File), + Post => Is_Open (File) and then Ada.Text_IO.Mode (File) = Mode and then (if Mode /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Reset (File : in out File_Type) with - Pre => Is_Open (File), - Post => + Pre => Is_Open (File), + Post => Is_Open (File) and Mode (File)'Old = Mode (File) and (if Mode (File) /= In_File then (Line_Length (File) = 0 and then Page_Length (File) = 0)), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function Mode (File : File_Type) return File_Mode with - Pre => Is_Open (File), - Global => null; + Pre => Is_Open (File), + Global => null, + Annotate => (GNATprove, Always_Return); function Name (File : File_Type) return String with - Pre => Is_Open (File), - Global => null; + Pre => Is_Open (File), + Global => null, + Annotate => (GNATprove, Always_Return); function Form (File : File_Type) return String with - Pre => Is_Open (File), - Global => null; + Pre => Is_Open (File), + Global => null, + Annotate => (GNATprove, Always_Return); function Is_Open (File : File_Type) return Boolean with - Global => null; + Global => null, + Annotate => (GNATprove, Always_Return); ------------------------------------------------------ -- Control of default input, output and error files -- @@ -199,120 +209,142 @@ is -- an oversight, and was intended to be IN, see AI95-00057. procedure Flush (File : File_Type) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Flush with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); -------------------------------------------- -- Specification of line and page lengths -- -------------------------------------------- procedure Set_Line_Length (File : File_Type; To : Count) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File) = To and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Line_Length (To : Count) with - Post => + Post => Line_Length = To and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Page_Length (File : File_Type; To : Count) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Page_Length (File) = To and Line_Length (File)'Old = Line_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Page_Length (To : Count) with - Post => + Post => Page_Length = To and Line_Length'Old = Line_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function Line_Length (File : File_Type) return Count with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) /= In_File, + Global => (Input => File_System); function Line_Length return Count with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Page_Length (File : File_Type) return Count with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) /= In_File, + Global => (Input => File_System); function Page_Length return Count with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); ------------------------------------ -- Column, Line, and Page Control -- ------------------------------------ procedure New_Line (File : File_Type; Spacing : Positive_Count := 1) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure New_Line (Spacing : Positive_Count := 1) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Skip_Line (Spacing : Positive_Count := 1) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function End_Of_Line (File : File_Type) return Boolean with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function End_Of_Line return Boolean with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); procedure New_Page (File : File_Type) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure New_Page with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Skip_Page (File : File_Type) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Skip_Page with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function End_Of_Page (File : File_Type) return Boolean with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function End_Of_Page return Boolean with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function End_Of_File (File : File_Type) return Boolean with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function End_Of_File return Boolean with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); procedure Set_Col (File : File_Type; To : Positive_Count) with Pre => @@ -325,13 +357,15 @@ is Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), others => True), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Col (To : Positive_Count) with - Pre => Line_Length = 0 or To <= Line_Length, - Post => + Pre => Line_Length = 0 or To <= Line_Length, + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Line (File : File_Type; To : Positive_Count) with Pre => @@ -344,149 +378,173 @@ is Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), others => True), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Set_Line (To : Positive_Count) with - Pre => Page_Length = 0 or To <= Page_Length, - Post => + Pre => Page_Length = 0 or To <= Page_Length, + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function Col (File : File_Type) return Positive_Count with - Pre => Is_Open (File), - Global => (Input => File_System); + Pre => Is_Open (File), + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Col return Positive_Count with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Line (File : File_Type) return Positive_Count with - Pre => Is_Open (File), - Global => (Input => File_System); + Pre => Is_Open (File), + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Line return Positive_Count with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Page (File : File_Type) return Positive_Count with - Pre => Is_Open (File), - Global => (Input => File_System); + Pre => Is_Open (File), + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); function Page return Positive_Count with - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); ---------------------------- -- Character Input-Output -- ---------------------------- procedure Get (File : File_Type; Item : out Character) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Character) with Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; Item : Character) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Put (Item : Character) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Look_Ahead (File : File_Type; Item : out Character; End_Of_Line : out Boolean) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (Input => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); procedure Look_Ahead (Item : out Character; End_Of_Line : out Boolean) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (Input => File_System); + Global => (Input => File_System), + Annotate => (GNATprove, Always_Return); procedure Get_Immediate (File : File_Type; Item : out Character) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get_Immediate (Item : out Character) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get_Immediate (File : File_Type; Item : out Character; Available : out Boolean) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get_Immediate (Item : out Character; Available : out Boolean) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); ------------------------- -- String Input-Output -- ------------------------- procedure Get (File : File_Type; Item : out String) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out String) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; Item : String) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Put (Item : String) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Get_Line (File : File_Type; Item : out String; Last : out Natural) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Post => (if Item'Length > 0 then Last in Item'First - 1 .. Item'Last + Pre => Is_Open (File) and then Mode (File) = In_File, + Post => (if Item'Length > 0 then Last in Item'First - 1 .. Item'Last else Last = Item'First - 1), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get_Line (Item : out String; Last : out Natural) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length and (if Item'Length > 0 then Last in Item'First - 1 .. Item'Last else Last = Item'First - 1), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); function Get_Line (File : File_Type) return String with SPARK_Mode => Off; pragma Ada_05 (Get_Line); @@ -498,19 +556,21 @@ is (File : File_Type; Item : String) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); procedure Put_Line (Item : String) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Always_Return); --------------------------------------- -- Generic packages for Input-Output -- diff --git a/gcc/ada/libgnat/a-tideio.ads b/gcc/ada/libgnat/a-tideio.ads index c5be496..4a2536d 100644 --- a/gcc/ada/libgnat/a-tideio.ads +++ b/gcc/ada/libgnat/a-tideio.ads @@ -54,17 +54,19 @@ package Ada.Text_IO.Decimal_IO is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -73,11 +75,12 @@ package Ada.Text_IO.Decimal_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Num; @@ -85,17 +88,19 @@ package Ada.Text_IO.Decimal_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; @@ -103,7 +108,8 @@ package Ada.Text_IO.Decimal_IO is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tienio.ads b/gcc/ada/libgnat/a-tienio.ads index fb80abd..aac90f7 100644 --- a/gcc/ada/libgnat/a-tienio.ads +++ b/gcc/ada/libgnat/a-tienio.ads @@ -29,13 +29,15 @@ package Ada.Text_IO.Enumeration_IO is Default_Setting : Type_Set := Upper_Case; procedure Get (File : File_Type; Item : out Enum) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Enum) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -43,34 +45,38 @@ package Ada.Text_IO.Enumeration_IO is Width : Field := Default_Width; Set : Type_Set := Default_Setting) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Enum; Width : Field := Default_Width; Set : Type_Set := Default_Setting) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Enum; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; Item : Enum; Set : Type_Set := Default_Setting) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); end Ada.Text_IO.Enumeration_IO; diff --git a/gcc/ada/libgnat/a-tifiio.ads b/gcc/ada/libgnat/a-tifiio.ads index 8a3886d..bbf8e90 100644 --- a/gcc/ada/libgnat/a-tifiio.ads +++ b/gcc/ada/libgnat/a-tifiio.ads @@ -34,17 +34,19 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -53,11 +55,12 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Num; @@ -65,17 +68,19 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; @@ -83,7 +88,8 @@ package Ada.Text_IO.Fixed_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tiflio.ads b/gcc/ada/libgnat/a-tiflio.ads index 2760b0f..032c6b2 100644 --- a/gcc/ada/libgnat/a-tiflio.ads +++ b/gcc/ada/libgnat/a-tiflio.ads @@ -54,17 +54,19 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -73,11 +75,12 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Num; @@ -85,17 +88,19 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; @@ -103,7 +108,8 @@ package Ada.Text_IO.Float_IO with SPARK_Mode => On is Aft : Field := Default_Aft; Exp : Field := Default_Exp) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tiinio.ads b/gcc/ada/libgnat/a-tiinio.ads index 77efd46..491bc2f 100644 --- a/gcc/ada/libgnat/a-tiinio.ads +++ b/gcc/ada/libgnat/a-tiinio.ads @@ -53,17 +53,19 @@ package Ada.Text_IO.Integer_IO is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -71,35 +73,39 @@ package Ada.Text_IO.Integer_IO is Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Num; Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; Item : Num; Base : Number_Base := Default_Base) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-timoio.ads b/gcc/ada/libgnat/a-timoio.ads index 8c28a0a..67ff7c6 100644 --- a/gcc/ada/libgnat/a-timoio.ads +++ b/gcc/ada/libgnat/a-timoio.ads @@ -53,17 +53,19 @@ package Ada.Text_IO.Modular_IO is Item : out Num; Width : Field := 0) with - Pre => Is_Open (File) and then Mode (File) = In_File, - Global => (In_Out => File_System); + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (Item : out Num; Width : Field := 0) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (File : File_Type; @@ -71,35 +73,39 @@ package Ada.Text_IO.Modular_IO is Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Pre => Is_Open (File) and then Mode (File) /= In_File, - Post => + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => Line_Length (File)'Old = Line_Length (File) and Page_Length (File)'Old = Page_Length (File), - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Put (Item : Num; Width : Field := Default_Width; Base : Number_Base := Default_Base) with - Post => + Post => Line_Length'Old = Line_Length and Page_Length'Old = Page_Length, - Global => (In_Out => File_System); + Global => (In_Out => File_System), + Annotate => (GNATprove, Might_Not_Return); procedure Get (From : String; Item : out Num; Last : out Positive) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); procedure Put (To : out String; Item : Num; Base : Number_Base := Default_Base) with - Global => null; + Global => null, + Annotate => (GNATprove, Might_Not_Return); private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-wtedit.adb b/gcc/ada/libgnat/a-wtedit.adb index 64bb989..9b9f702 100644 --- a/gcc/ada/libgnat/a-wtedit.adb +++ b/gcc/ada/libgnat/a-wtedit.adb @@ -246,8 +246,8 @@ package body Ada.Wide_Text_IO.Editing is else Count := Count * 10 - + Character'Pos (Picture (Last)) - - Character'Pos ('0'); + + Character'Pos (Picture (Last)) - + Character'Pos ('0'); end if; Last := Last + 1; diff --git a/gcc/ada/libgnat/a-ztenau.adb b/gcc/ada/libgnat/a-ztenau.adb index b03ad8f..d66e547 100644 --- a/gcc/ada/libgnat/a-ztenau.adb +++ b/gcc/ada/libgnat/a-ztenau.adb @@ -306,8 +306,6 @@ package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is and then not Is_Letter (To_Character (WC)) and then - not Is_Letter (To_Character (WC)) - and then (WC /= '_' or else From (Stop - 1) = '_'); Stop := Stop + 1; diff --git a/gcc/ada/libgnat/g-alleve.adb b/gcc/ada/libgnat/g-alleve.adb index 0dba029..4db442c 100644 --- a/gcc/ada/libgnat/g-alleve.adb +++ b/gcc/ada/libgnat/g-alleve.adb @@ -3779,7 +3779,7 @@ package body GNAT.Altivec.Low_Level_Vectors is return D; end Saturate; - -- Start of processing for vpksxus + -- Start of processing for vpksxus begin for J in 0 .. N - 1 loop diff --git a/gcc/ada/libgnat/g-awk.adb b/gcc/ada/libgnat/g-awk.adb index 1c88785..9b2e127 100644 --- a/gcc/ada/libgnat/g-awk.adb +++ b/gcc/ada/libgnat/g-awk.adb @@ -1211,7 +1211,6 @@ package body GNAT.AWK is Exceptions.Raise_Exception (E, '[' & Filename & ':' & Line & "] " & Message); - raise Constraint_Error; -- to please GNAT as this is a No_Return proc end Raise_With_Info; --------------- diff --git a/gcc/ada/libgnat/g-binsea.adb b/gcc/ada/libgnat/g-binsea.adb new file mode 100644 index 0000000..fcf0185 --- /dev/null +++ b/gcc/ada/libgnat/g-binsea.adb @@ -0,0 +1,123 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- GNAT.BINARY_SEARCH -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2022, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +package body GNAT.Binary_Search is + + function Index + (First, Last, Start : Index_Type; + Element : Element_Type) return Index_Type'Base is + begin + if Leftmost then + declare + function Before + (Index : Index_Type; Element : Element_Type) return Boolean + is (Before (Get (Index), Element)) with Inline_Always; + + function Find is new Binary_Search.Leftmost + (Index_Type, Element_Type, Before); + begin + return Find (First, Last, Start, Element); + end; + + else + declare + function Before + (Element : Element_Type; Index : Index_Type) return Boolean + is (Before (Element, Get (Index))) with Inline_Always; + + function Find is new Rightmost (Index_Type, Element_Type, Before); + begin + return Find (First, Last, Start, Element); + end; + end if; + end Index; + + -------------- + -- Leftmost -- + -------------- + + function Leftmost + (First, Last, Start : Index_Type; + Element : Element_Type) return Index_Type'Base + is + L : Index_Type := First; + R : Index_Type := Index_Type'Succ (Last); + M : Index_Type := Start; + begin + if First <= Last then + loop + if Before (M, Element) then + L := Index_Type'Succ (M); + else + R := M; + end if; + + exit when L >= R; + + M := Index_Type'Val + (Index_Type'Pos (L) + + (Index_Type'Pos (R) - Index_Type'Pos (L)) / 2); + end loop; + end if; + + return L; + end Leftmost; + + --------------- + -- Rightmost -- + --------------- + + function Rightmost + (First, Last, Start : Index_Type; + Element : Element_Type) return Index_Type'Base + is + L : Index_Type := First; + R : Index_Type := Index_Type'Succ (Last); + M : Index_Type := Start; + begin + if First > Last then + return Last; + else + loop + if Before (Element, M) then + R := M; + else + L := Index_Type'Succ (M); + end if; + + exit when L >= R; + + M := Index_Type'Val + (Index_Type'Pos (L) + + (Index_Type'Pos (R) - Index_Type'Pos (L)) / 2); + end loop; + end if; + + return Index_Type'Pred (R); + end Rightmost; + +end GNAT.Binary_Search; diff --git a/gcc/ada/libgnat/g-binsea.ads b/gcc/ada/libgnat/g-binsea.ads new file mode 100644 index 0000000..372b830 --- /dev/null +++ b/gcc/ada/libgnat/g-binsea.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- GNAT.BINARY_SEARCH -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- 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/>. -- +------------------------------------------------------------------------------ + +-- Allow binary search of a sorted array (or of an array-like container; +-- the generic does not reference the array directly). + +package GNAT.Binary_Search is + + generic + type Index_Type is (<>); + type Element_Type (<>) is private; + with function Get (Index : Index_Type) return Element_Type; + with function Before (Left, Right : Element_Type) return Boolean; + Leftmost : Boolean := True; + function Index + (First, Last, Start : Index_Type; + Element : Element_Type) return Index_Type'Base; + -- Search for element in sorted container. Function Before should return + -- True when Left and Right are in the container's sort order and not + -- equal. Function Get returns the container element indexed by Index; + -- Index will be in the range First .. Last. If there is at least one index + -- value in the range First .. Last for which Get would return Element, + -- then the Leftmost generic parameter indicates whether the least (if + -- Leftmost is True) or the greatest (if Leftmost is False) such index + -- value is returned. If no such index value exists, then Leftmost + -- determines whether to return the greater (if Leftmost is True) or the + -- smaller (if Leftmost is False) of the two index values between which + -- Element could be inserted. If First > Last (so that a null range is + -- being searched), some Index_Type'Base value will be returned. + -- Start is the index for the first probe of the binary search. It can + -- improve speed of many search operations when user can guess the most + -- likely values. If you do not know what value should be used there, use + -- (First + Last) / 2. + + generic + type Index_Type is (<>); + type Element_Type (<>) is private; + with function Before + (Index : Index_Type; Element : Element_Type) return Boolean; + function Leftmost + (First, Last, Start : Index_Type; + Element : Element_Type) return Index_Type'Base + with Pre => First > Last -- Empty array + or else (Start in First .. Last + and then ( -- To prevent overflow in function result + Index_Type'Base'Last > Last + or else not Before (Last, Element))); + -- Leftmost returns the result described for Index in the case where the + -- Leftmost parameter is True, with Index_Type values mapped to + -- Element_Type values via Get as needed. + + generic + type Index_Type is (<>); + type Element_Type (<>) is private; + with function Before + (Element : Element_Type; Index : Index_Type) return Boolean; + function Rightmost + (First, Last, Start : Index_Type; + Element : Element_Type) return Index_Type'Base + with Pre => First > Last -- Empty array + or else (Start in First .. Last + and then ( -- To prevent overflow in function result + Index_Type'Base'First < First + or else not Before (Element, First))); + -- Rightmost returns the result described for Index in the case where the + -- Leftmost parameter is False, with Index_Type values mapped to + -- Element_Type values via Get as needed. + +end GNAT.Binary_Search; diff --git a/gcc/ada/libgnat/g-debpoo.adb b/gcc/ada/libgnat/g-debpoo.adb index ecab282..6e0cf10 100644 --- a/gcc/ada/libgnat/g-debpoo.adb +++ b/gcc/ada/libgnat/g-debpoo.adb @@ -791,7 +791,7 @@ package body GNAT.Debug_Pools is declare Block_Number : constant Integer_Address := - Int_Storage / Memory_Chunk_Size; + Int_Storage / Memory_Chunk_Size; Ptr : constant Validity_Bits_Ref := Validy_Htable.Get (Block_Number); Offset : constant Integer_Address := @@ -844,7 +844,7 @@ package body GNAT.Debug_Pools is procedure Set_Valid (Storage : System.Address; Value : Boolean) is Int_Storage : constant Integer_Address := To_Integer (Storage); Block_Number : constant Integer_Address := - Int_Storage / Memory_Chunk_Size; + Int_Storage / Memory_Chunk_Size; Ptr : Validity_Bits_Ref := Validy_Htable.Get (Block_Number); Offset : constant Integer_Address := (Int_Storage - (Block_Number * Memory_Chunk_Size)) / diff --git a/gcc/ada/libgnat/g-debpoo.ads b/gcc/ada/libgnat/g-debpoo.ads index bf21369..e3df752 100644 --- a/gcc/ada/libgnat/g-debpoo.ads +++ b/gcc/ada/libgnat/g-debpoo.ads @@ -123,7 +123,8 @@ package GNAT.Debug_Pools is -- traces that are output to indicate locations of actions for error -- conditions such as bad allocations. If set to zero, the debug pool -- will not try to compute backtraces. This is more efficient but gives - -- less information on problem locations + -- less information on problem locations (and in particular, this + -- disables the tracking of the biggest users of memory). -- -- Maximum_Logically_Freed_Memory: maximum amount of memory (bytes) -- that should be kept before starting to physically deallocate some. @@ -275,8 +276,12 @@ package GNAT.Debug_Pools is Size : Positive; Report : Report_Type := All_Reports); -- Dump information about memory usage. - -- Size is the number of the biggest memory users we want to show. Report - -- indicates which sorting order is used in the report. + -- Size is the number of the biggest memory users we want to show + -- (requires that the Debug_Pool has been configured with Stack_Trace_Depth + -- greater than zero). Also, for efficiency reasons, tracebacks with + -- a memory allocation below 1_000 bytes are not shown in the "biggest + -- memory users" part of the report. + -- Report indicates which sorting order is used in the report. procedure Dump_Stdout (Pool : Debug_Pool; diff --git a/gcc/ada/libgnat/g-decstr.adb b/gcc/ada/libgnat/g-decstr.adb index 7cac94d..04c73a5 100644 --- a/gcc/ada/libgnat/g-decstr.adb +++ b/gcc/ada/libgnat/g-decstr.adb @@ -4,7 +4,7 @@ -- -- -- G N A T . D E C O D E _ S T R I N G -- -- -- --- S p e c -- +-- B o d y -- -- -- -- Copyright (C) 2007-2022, AdaCore -- -- -- diff --git a/gcc/ada/libgnat/g-dyntab.ads b/gcc/ada/libgnat/g-dyntab.ads index 7cad735..1cf4877 100644 --- a/gcc/ada/libgnat/g-dyntab.ads +++ b/gcc/ada/libgnat/g-dyntab.ads @@ -82,10 +82,6 @@ package GNAT.Dynamic_Tables is -- freely (expensive reallocation occurs only at major granularity -- chunks controlled by the allocation parameters). - -- Note: we do not make the table components aliased, since this would - -- restrict the use of table for discriminated types. If it is necessary - -- to take the access of a table element, use Unrestricted_Access. - -- WARNING: On HPPA, the virtual addressing approach used in this unit is -- incompatible with the indexing instructions on the HPPA. So when using -- this unit, compile your application with -mdisable-indexing. @@ -120,9 +116,10 @@ package GNAT.Dynamic_Tables is -- freely (expensive reallocation occurs only at major granularity -- chunks controlled by the allocation parameters). - -- Note: we do not make the table components aliased, since this would - -- restrict the use of table for discriminated types. If it is necessary - -- to take the access of a table element, use Unrestricted_Access. + -- Note: For backward compatibility we do not make the table components + -- aliased, since for Ada 95 this would have restricted the use of tables + -- for discriminated types. If it is necessary to take the access of a + -- table element, use Unrestricted_Access. type Table_Type is array (Valid_Table_Index_Type range <>) of Table_Component_Type; diff --git a/gcc/ada/libgnat/g-expect.adb b/gcc/ada/libgnat/g-expect.adb index e43ef4f..56554c0 100644 --- a/gcc/ada/libgnat/g-expect.adb +++ b/gcc/ada/libgnat/g-expect.adb @@ -96,7 +96,7 @@ package body GNAT.Expect is procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); pragma Import (C, Dup2); - procedure Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer); + procedure Kill (Pid : Process_Id; Sig_Num : Integer); pragma Import (C, Kill, "__gnat_kill"); -- if Close is set to 1 all OS resources used by the Pid must be freed @@ -222,6 +222,10 @@ package body GNAT.Expect is Next_Filter : Filter_List; begin + if Descriptor.Pid > 0 then -- see comment in Send_Signal + Kill (Descriptor.Pid, Sig_Num => 9); + end if; + Close_Input (Descriptor); if Descriptor.Error_Fd /= Descriptor.Output_Fd @@ -234,12 +238,6 @@ package body GNAT.Expect is Close (Descriptor.Output_Fd); end if; - -- ??? Should have timeouts for different signals - - if Descriptor.Pid > 0 then -- see comment in Send_Signal - Kill (Descriptor.Pid, Sig_Num => 9, Close => 0); - end if; - GNAT.OS_Lib.Free (Descriptor.Buffer); Descriptor.Buffer_Size := 0; @@ -1349,7 +1347,7 @@ package body GNAT.Expect is -- started; we don't want to kill ourself in that case. if Descriptor.Pid > 0 then - Kill (Descriptor.Pid, Signal, Close => 1); + Kill (Descriptor.Pid, Signal); -- ??? Need to check process status here else raise Invalid_Process; diff --git a/gcc/ada/libgnat/g-exptty.adb b/gcc/ada/libgnat/g-exptty.adb index 20f3a1a..c21ad98 100644 --- a/gcc/ada/libgnat/g-exptty.adb +++ b/gcc/ada/libgnat/g-exptty.adb @@ -4,7 +4,7 @@ -- -- -- G N A T . E X P E C T . T T Y -- -- -- --- S p e c -- +-- B o d y -- -- -- -- Copyright (C) 2000-2022, AdaCore -- -- -- diff --git a/gcc/ada/libgnat/g-forstr.adb b/gcc/ada/libgnat/g-forstr.adb index 8ce8d1c..8821de6 100644 --- a/gcc/ada/libgnat/g-forstr.adb +++ b/gcc/ada/libgnat/g-forstr.adb @@ -58,7 +58,7 @@ package body GNAT.Formatted_String is type Sign_Kind is (Neg, Zero, Pos); - subtype Is_Number is F_Kind range Decimal_Int .. Decimal_Float; + subtype Is_Number is F_Kind range Decimal_Int .. Shortest_Decimal_Float_Up; type F_Sign is (If_Neg, Forced, Space) with Default_Value => If_Neg; diff --git a/gcc/ada/libgnat/g-gfmafu.ads b/gcc/ada/libgnat/g-gfmafu.ads new file mode 100644 index 0000000..410a37c --- /dev/null +++ b/gcc/ada/libgnat/g-gfmafu.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . G E N E R I C _ F A S T _ M A T H _ F U N C T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Aux_Generic_Float; + +generic package GNAT.Generic_Fast_Math_Functions + renames Ada.Numerics.Aux_Generic_Float; diff --git a/gcc/ada/libgnat/g-sercom__linux.adb b/gcc/ada/libgnat/g-sercom__linux.adb index a2a64b1..73bbb69 100644 --- a/gcc/ada/libgnat/g-sercom__linux.adb +++ b/gcc/ada/libgnat/g-sercom__linux.adb @@ -382,6 +382,7 @@ package body GNAT.Serial_Communications is begin if Port.H /= -1 then Res := close (int (Port.H)); + Port.H := -1; end if; end Close; diff --git a/gcc/ada/libgnat/g-sercom__mingw.adb b/gcc/ada/libgnat/g-sercom__mingw.adb index aea78ae..d3301bd 100644 --- a/gcc/ada/libgnat/g-sercom__mingw.adb +++ b/gcc/ada/libgnat/g-sercom__mingw.adb @@ -70,6 +70,7 @@ package body GNAT.Serial_Communications is begin if Port.H /= -1 then Success := CloseHandle (HANDLE (Port.H)); + Port.H := -1; if Success = Win32.FALSE then Raise_Error ("error closing the port"); diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb index 12abb68..86ce3b8 100644 --- a/gcc/ada/libgnat/g-socket.adb +++ b/gcc/ada/libgnat/g-socket.adb @@ -191,12 +191,14 @@ package body GNAT.Sockets is else Value); -- Removes dot at the end of error message - procedure Raise_Host_Error (H_Error : Integer; Name : String); + procedure Raise_Host_Error (H_Error : Integer; Name : String) + with No_Return; -- Raise Host_Error exception with message describing error code (note -- hstrerror seems to be obsolete) from h_errno. Name is the name -- or address that was being looked up. - procedure Raise_GAI_Error (RC : C.int; Name : String); + procedure Raise_GAI_Error (RC : C.int; Name : String) + with No_Return; -- Raise Host_Error with exception message in case of errors in -- getaddrinfo and getnameinfo. @@ -1034,7 +1036,6 @@ package body GNAT.Sockets is R : C.int; Iter : Addrinfo_Access; - Found : Boolean; function To_Array return Address_Info_Array; -- Convert taken from OS addrinfo list A into Address_Info_Array @@ -1044,8 +1045,6 @@ package body GNAT.Sockets is -------------- function To_Array return Address_Info_Array is - Result : Address_Info_Array (1 .. 8); - procedure Unsupported; -- Calls Unknown callback if defiend @@ -1064,6 +1063,9 @@ package body GNAT.Sockets is end if; end Unsupported; + Found : Boolean; + Result : Address_Info_Array (1 .. 8); + -- Start of processing for To_Array begin @@ -1085,8 +1087,8 @@ package body GNAT.Sockets is if Result (J).Addr.Family = Family_Unspec then Unsupported; else + Found := False; for M in Modes'Range loop - Found := False; if Modes (M) = Iter.ai_socktype then Result (J).Mode := M; Found := True; diff --git a/gcc/ada/libgnat/g-socket.ads b/gcc/ada/libgnat/g-socket.ads index 41ede44..cfc47be 100644 --- a/gcc/ada/libgnat/g-socket.ads +++ b/gcc/ada/libgnat/g-socket.ads @@ -1593,7 +1593,7 @@ private Wait_For_A_Full_Reception : constant Request_Flag_Type := 4; Send_End_Of_Record : constant Request_Flag_Type := 8; - procedure Raise_Socket_Error (Error : Integer); + procedure Raise_Socket_Error (Error : Integer) with No_Return; -- Raise Socket_Error with an exception message describing the error code -- from errno. diff --git a/gcc/ada/libgnat/g-socpol.adb b/gcc/ada/libgnat/g-socpol.adb index fd27211..601e0c22 100644 --- a/gcc/ada/libgnat/g-socpol.adb +++ b/gcc/ada/libgnat/g-socpol.adb @@ -4,7 +4,7 @@ -- -- -- G N A T . S O C K E T S . P O L L -- -- -- --- S p e c -- +-- B o d y -- -- -- -- Copyright (C) 2020-2022, AdaCore -- -- -- diff --git a/gcc/ada/libgnat/g-socthi.adb b/gcc/ada/libgnat/g-socthi.adb index e70b85b..f5a3df9 100644 --- a/gcc/ada/libgnat/g-socthi.adb +++ b/gcc/ada/libgnat/g-socthi.adb @@ -187,7 +187,9 @@ package body GNAT.Sockets.Thin is return Res; end if; - declare + pragma Warnings (Off, "unreachable code"); + declare -- unreachable if Thread_Blocking_IO is statically True + pragma Warnings (On, "unreachable code"); WSet : aliased Fd_Set; Now : aliased Timeval; diff --git a/gcc/ada/libgnat/g-socthi__vxworks.adb b/gcc/ada/libgnat/g-socthi__vxworks.adb index aeae52d..32973b4 100644 --- a/gcc/ada/libgnat/g-socthi__vxworks.adb +++ b/gcc/ada/libgnat/g-socthi__vxworks.adb @@ -190,7 +190,9 @@ package body GNAT.Sockets.Thin is return Res; end if; - declare + pragma Warnings (Off, "unreachable code"); + declare -- unreachable if Thread_Blocking_IO is statically True + pragma Warnings (On, "unreachable code"); WSet : aliased Fd_Set; Now : aliased Timeval; begin diff --git a/gcc/ada/libgnat/g-spipat.adb b/gcc/ada/libgnat/g-spipat.adb index 6ecbd1b..9fb55bc 100644 --- a/gcc/ada/libgnat/g-spipat.adb +++ b/gcc/ada/libgnat/g-spipat.adb @@ -3961,7 +3961,7 @@ package body GNAT.Spitbol.Patterns is -- Any (one character case) - when PC_Any_CH => + when PC_Any_CH | PC_Char => if Cursor < Length and then Subject (Cursor + 1) = Node.Char then @@ -4103,9 +4103,10 @@ package body GNAT.Spitbol.Patterns is Pop_Region; goto Succeed; - -- Assign on match. This node sets up for the eventual assignment + -- Write/assign on match. This node sets up for the eventual write + -- or assignment. - when PC_Assign_OnM => + when PC_Assign_OnM | PC_Write_OnM => Stack (Stack_Base - 1).Node := Node; Push (CP_Assign'Access); Pop_Region; @@ -4144,9 +4145,9 @@ package body GNAT.Spitbol.Patterns is Push (Node); goto Succeed; - -- Break (one character case) + -- Break & BreakX (one character case) - when PC_Break_CH => + when PC_Break_CH | PC_BreakX_CH => while Cursor < Length loop if Subject (Cursor + 1) = Node.Char then goto Succeed; @@ -4157,9 +4158,9 @@ package body GNAT.Spitbol.Patterns is goto Fail; - -- Break (character set case) + -- Break & BreakX (character set case) - when PC_Break_CS => + when PC_Break_CS | PC_BreakX_CS => while Cursor < Length loop if Is_In (Subject (Cursor + 1), Node.CS) then goto Succeed; @@ -4170,9 +4171,9 @@ package body GNAT.Spitbol.Patterns is goto Fail; - -- Break (string function case) + -- Break & BreakX (string function case) - when PC_Break_VF => declare + when PC_Break_VF | PC_BreakX_VF => declare U : constant VString := Node.VF.all; S : Big_String_Access; L : Natural; @@ -4191,77 +4192,9 @@ package body GNAT.Spitbol.Patterns is goto Fail; end; - -- Break (string pointer case) + -- Break & BreakX (string pointer case) - when PC_Break_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- BreakX (one character case) - - when PC_BreakX_CH => - while Cursor < Length loop - if Subject (Cursor + 1) = Node.Char then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- BreakX (character set case) - - when PC_BreakX_CS => - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), Node.CS) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- BreakX (string function case) - - when PC_BreakX_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- BreakX (string pointer case) - - when PC_BreakX_VP => declare + when PC_Break_VP | PC_BreakX_VP => declare U : constant VString := Node.VP.all; S : Big_String_Access; L : Natural; @@ -4288,18 +4221,6 @@ package body GNAT.Spitbol.Patterns is Cursor := Cursor + 1; goto Succeed; - -- Character (one character string) - - when PC_Char => - if Cursor < Length - and then Subject (Cursor + 1) = Node.Char - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - -- End of Pattern when PC_EOP => @@ -4941,15 +4862,6 @@ package body GNAT.Spitbol.Patterns is Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); Pop_Region; goto Succeed; - - -- Write on match. This node sets up for the eventual write - - when PC_Write_OnM => - Stack (Stack_Base - 1).Node := Node; - Push (CP_Assign'Access); - Pop_Region; - Assign_OnM := True; - goto Succeed; end case; -- We are NOT allowed to fall though this case statement, since every @@ -5445,20 +5357,10 @@ package body GNAT.Spitbol.Patterns is goto Fail; end if; - -- Arbno_S (simple Arbno initialize). This is the node that - -- initiates the match of a simple Arbno structure. - - when PC_Arbno_S => - Dout (Img (Node) & - "setting up Arbno alternative " & Img (Node.Alt)); - Push (Node.Alt); - Node := Node.Pthen; - goto Match; - - -- Arbno_X (Arbno initialize). This is the node that initiates - -- the match of a complex Arbno structure. + -- Arbno_S/X (simple and complex Arbno initialize). This is the node + -- that initiates the match of a simple or complex Arbno structure. - when PC_Arbno_X => + when PC_Arbno_S | PC_Arbno_X => Dout (Img (Node) & "setting up Arbno alternative " & Img (Node.Alt)); Push (Node.Alt); diff --git a/gcc/ada/libgnat/g-sthcso.adb b/gcc/ada/libgnat/g-sthcso.adb index f045c02..fd99eeb 100644 --- a/gcc/ada/libgnat/g-sthcso.adb +++ b/gcc/ada/libgnat/g-sthcso.adb @@ -41,7 +41,12 @@ function C_Socketpair Protocol : C.int; Fds : not null access Fd_Pair) return C.int is + -- This use type clause is not required on all platforms + -- using this implementation. So we suppress the warning + -- for the platforms that already use this type. + pragma Warnings (Off, "use clause for type *"); use type C.char_array; + pragma Warnings (On, "use clause for type *"); L_Sock, C_Sock, P_Sock : C.int := Failure; -- Listening socket, client socket and peer socket diff --git a/gcc/ada/libgnat/i-c.ads b/gcc/ada/libgnat/i-c.ads index 2023b75..7013902 100644 --- a/gcc/ada/libgnat/i-c.ads +++ b/gcc/ada/libgnat/i-c.ads @@ -29,6 +29,8 @@ with System.Parameters; package Interfaces.C with SPARK_Mode, Pure is + pragma Annotate (GNATprove, Always_Return, C); + -- Each of the types declared in Interfaces.C is C-compatible. -- The types int, short, long, unsigned, ptrdiff_t, size_t, double, diff --git a/gcc/ada/libgnat/i-cstrin.adb b/gcc/ada/libgnat/i-cstrin.adb index e2f0f21..67cceb2 100644 --- a/gcc/ada/libgnat/i-cstrin.adb +++ b/gcc/ada/libgnat/i-cstrin.adb @@ -34,7 +34,9 @@ with System.Storage_Elements; use System.Storage_Elements; with Ada.Unchecked_Conversion; -package body Interfaces.C.Strings is +package body Interfaces.C.Strings with + SPARK_Mode => Off +is -- Note that the type chars_ptr has a pragma No_Strict_Aliasing in the -- spec, to prevent any assumptions about aliasing for values of this type, diff --git a/gcc/ada/libgnat/i-cstrin.ads b/gcc/ada/libgnat/i-cstrin.ads index 5c1b259..12fa301 100644 --- a/gcc/ada/libgnat/i-cstrin.ads +++ b/gcc/ada/libgnat/i-cstrin.ads @@ -33,7 +33,19 @@ -- -- ------------------------------------------------------------------------------ -package Interfaces.C.Strings 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. These preconditions +-- protect from Dereference_Error and Update_Error, but not from +-- Storage_Error. + +pragma Assertion_Policy (Pre => Ignore); + +package Interfaces.C.Strings with + SPARK_Mode => On, + Abstract_State => (C_Memory), + Initializes => (C_Memory) +is pragma Preelaborate; type char_array_access is access all char_array; @@ -53,47 +65,85 @@ package Interfaces.C.Strings is function To_Chars_Ptr (Item : char_array_access; - Nul_Check : Boolean := False) return chars_ptr; - - function New_Char_Array (Chars : char_array) return chars_ptr; - - function New_String (Str : String) return chars_ptr; - - procedure Free (Item : in out chars_ptr); + Nul_Check : Boolean := False) return chars_ptr + with + SPARK_Mode => Off; + + function New_Char_Array (Chars : char_array) return chars_ptr with + Volatile_Function, + Post => New_Char_Array'Result /= Null_Ptr, + Global => (Input => C_Memory); + + function New_String (Str : String) return chars_ptr with + Volatile_Function, + Post => New_String'Result /= Null_Ptr, + Global => (Input => C_Memory); + + procedure Free (Item : in out chars_ptr) with + SPARK_Mode => Off; -- When deallocation is prohibited (eg: cert runtimes) this routine -- will raise Program_Error Dereference_Error : exception; - function Value (Item : chars_ptr) return char_array; + function Value (Item : chars_ptr) return char_array with + Pre => Item /= Null_Ptr, + Global => (Input => C_Memory); function Value (Item : chars_ptr; - Length : size_t) return char_array; + Length : size_t) return char_array + with + Pre => Item /= Null_Ptr, + Global => (Input => C_Memory); - function Value (Item : chars_ptr) return String; + function Value (Item : chars_ptr) return String with + Pre => Item /= Null_Ptr, + Global => (Input => C_Memory); function Value (Item : chars_ptr; - Length : size_t) return String; + Length : size_t) return String + with + Pre => Item /= Null_Ptr, + Global => (Input => C_Memory); - function Strlen (Item : chars_ptr) return size_t; + function Strlen (Item : chars_ptr) return size_t with + Pre => Item /= Null_Ptr, + Global => (Input => C_Memory); procedure Update (Item : chars_ptr; Offset : size_t; Chars : char_array; - Check : Boolean := True); + Check : Boolean := True) + with + Pre => + Item /= Null_Ptr + and then + (if Check then + Strlen (Item) <= size_t'Last - Offset + and then Strlen (Item) + Offset <= Chars'Length), + Global => (In_Out => C_Memory); procedure Update (Item : chars_ptr; Offset : size_t; Str : String; - Check : Boolean := True); + Check : Boolean := True) + with + Pre => + Item /= Null_Ptr + and then + (if Check then + Strlen (Item) <= size_t'Last - Offset + and then Strlen (Item) + Offset <= Str'Length), + Global => (In_Out => C_Memory); Update_Error : exception; private + pragma SPARK_Mode (Off); type chars_ptr is access all Character; for chars_ptr'Size use System.Parameters.ptr_bits; diff --git a/gcc/ada/libgnat/interfac.ads b/gcc/ada/libgnat/interfac.ads index b12ced8..b269869 100644 --- a/gcc/ada/libgnat/interfac.ads +++ b/gcc/ada/libgnat/interfac.ads @@ -38,6 +38,7 @@ package Interfaces is pragma No_Elaboration_Code_All; pragma Pure; + pragma Annotate (GNATprove, Always_Return, Interfaces); -- All identifiers in this unit are implementation defined diff --git a/gcc/ada/libgnat/interfac__2020.ads b/gcc/ada/libgnat/interfac__2020.ads index 579e8b4..becd180 100644 --- a/gcc/ada/libgnat/interfac__2020.ads +++ b/gcc/ada/libgnat/interfac__2020.ads @@ -38,6 +38,7 @@ package Interfaces is pragma No_Elaboration_Code_All; pragma Pure; + pragma Annotate (GNATprove, Always_Return, Interfaces); -- All identifiers in this unit are implementation defined diff --git a/gcc/ada/libgnat/s-aridou.adb b/gcc/ada/libgnat/s-aridou.adb index 0fefb6b..b40e4c3 100644 --- a/gcc/ada/libgnat/s-aridou.adb +++ b/gcc/ada/libgnat/s-aridou.adb @@ -30,6 +30,7 @@ ------------------------------------------------------------------------------ with Ada.Unchecked_Conversion; +with System.SPARK.Cut_Operations; use System.SPARK.Cut_Operations; package body System.Arith_Double with SPARK_Mode @@ -133,7 +134,7 @@ is Post => Big_2xx'Result > 0; -- 2**N as a big integer - function Big3 (X1, X2, X3 : Single_Uns) return Big_Integer is + 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))) @@ -161,7 +162,7 @@ is function To_Neg_Int (A : Double_Uns) return Double_Int with - Annotate => (GNATprove, Terminating), + Annotate => (GNATprove, Always_Return), Pre => In_Double_Int_Range (-Big (A)), Post => Big (To_Neg_Int'Result) = -Big (A); -- Convert to negative integer equivalent. If the input is in the range @@ -171,7 +172,7 @@ is function To_Pos_Int (A : Double_Uns) return Double_Int with - Annotate => (GNATprove, Terminating), + Annotate => (GNATprove, Always_Return), Pre => In_Double_Int_Range (Big (A)), Post => Big (To_Pos_Int'Result) = Big (A); -- Convert to positive integer equivalent. If the input is in the range @@ -208,19 +209,12 @@ is Ghost, Post => abs (X * Y) = abs X * abs Y; - 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) + procedure Lemma_Abs_Range (X : 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; + 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 @@ -246,6 +240,12 @@ is 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) @@ -289,6 +289,11 @@ is Pre => A * S = B * S + R and then S /= 0, Post => A = B + R / S; + 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, @@ -309,6 +314,20 @@ is 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, @@ -419,6 +438,26 @@ is 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 >= 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_Div (X, Y : Big_Integer) with Ghost, @@ -436,6 +475,12 @@ is 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, @@ -494,6 +539,13 @@ is 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, @@ -549,6 +601,7 @@ is 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_Bounded_Powers_Of_2_Increasing (M, N : Natural) is null; @@ -565,9 +618,11 @@ is 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_Eq (A, B, S, R : Big_Integer) 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; @@ -585,6 +640,7 @@ is 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_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; @@ -820,6 +876,23 @@ is 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, @@ -836,7 +909,13 @@ is 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_R and then Big (Q) = Big_Q; + 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. @@ -847,6 +926,7 @@ is 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 -- @@ -924,13 +1004,24 @@ is 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; @@ -938,10 +1029,14 @@ is 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; @@ -970,6 +1065,7 @@ is Lemma_Mult_Distribution (Big_2xxSingle, Big (Double_Uns (Hi (T2))), Big (Double_Uns (Lo (T2)))); + Lemma_Double_Big_2xxSingle; pragma Assert (Mult = Big_2xxDouble * Big (Double_Uns (Hi (T2))) + Big_2xxSingle * Big (Double_Uns (Lo (T2))) @@ -996,15 +1092,30 @@ is 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; @@ -1069,6 +1180,7 @@ is end if; pragma Assert (abs Big_Q = Big (Qu)); + Prove_Sign_Quotient; -- Set final signs (RM 4.5.5(27-30)) @@ -1144,6 +1256,30 @@ is 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 -- ------------------------ @@ -1157,6 +1293,19 @@ is = 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 -- ------------------------------ @@ -1223,6 +1372,19 @@ is + 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 -- ------------------- @@ -1247,6 +1409,7 @@ is 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 @@ -1300,15 +1463,78 @@ is 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_Div_Pow2 (X : Double_Uns; I : Natural) is + Div1 : constant Double_Uns := Double_Uns'(2) ** I; + Div2 : constant Double_Uns := Double_Uns'(2); + Left : constant Double_Uns := X / Div1 / Div2; + begin + pragma Assert (Left = X / (Div1 * Div2)); + pragma Assert (Div1 * Div2 = Double_Uns'(2) ** (I + 1)); + end Lemma_Div_Pow2; + XX : Double_Uns := X; + begin for J in 1 .. Shift loop - XX := Shift_Right (XX, 1); + 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); @@ -1359,6 +1585,8 @@ is 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); @@ -1527,10 +1755,14 @@ is 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; @@ -1544,7 +1776,7 @@ is 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))); + Big (Double_Uns'(Xlo * Yhi))); pragma Assert (Mult = Big_2xxSingle * Big (T2) + Big (T1)); Lemma_Add_Commutation (T2, Hi (T1)); pragma Assert @@ -1575,6 +1807,7 @@ is "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 @@ -1585,6 +1818,7 @@ is "Intentional Unsigned->Signed conversion"); else Prove_Neg_Int; + Lemma_Abs_Range (Big (X) * Big (Y)); return To_Neg_Int (T2); end if; end if; @@ -1660,6 +1894,31 @@ is 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; + + 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, + Pre => Scale < Double_Size; + -- Local lemmas procedure Prove_Dividend_Scaling @@ -1667,24 +1926,19 @@ is Ghost, Pre => D'Initialized and then Scale <= Single_Size - and then Mult = - Big_2xxSingle - * Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4))) + 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 => Mult * Big_2xx (Scale) = - Big_2xxSingle - * Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T1) or - Hi (T2))) - + Big_2xxSingle * Big (Double_Uns (Lo (T2) or - Hi (T3))) - + Big (Double_Uns (Lo (T3))); + 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. @@ -1868,56 +2122,154 @@ is ---------------------------- 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_Hi_Lo (D (1) & D (2), D (1), D (2)); - pragma Assert (Mult * Big_2xx (Scale) = - Big_2xxSingle - * Big_2xxSingle * Big_2xx (Scale) * Big (D (1) & D (2)) - + Big_2xxSingle * Big_2xx (Scale) * Big (Double_Uns (D (3))) - + Big_2xx (Scale) * Big (Double_Uns (D (4)))); - pragma Assert (Big_2xx (Scale) > 0); + 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_Mult_Commutation (2 ** Scale, D (1) & D (2), T1); + 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 - Big_D12 : constant Big_Integer := - Big_2xx (Scale) * Big (D (1) & D (2)); - Big_T1 : constant Big_Integer := Big (T1); + Two_xx_Scale : constant Double_Uns := Double_Uns'(2 ** Scale); + D12 : constant Double_Uns := D (1) & D (2); begin - pragma Assert (Big_D12 = Big_T1); - pragma Assert (Big_2xxSingle * Big_2xxSingle * Big_D12 - = Big_2xxSingle * Big_2xxSingle * Big_T1); + 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); - declare - Big_D3 : constant Big_Integer := - Big_2xx (Scale) * Big (Double_Uns (D (3))); - Big_T2 : constant Big_Integer := Big (T2); - begin - pragma Assert (Big_D3 = Big_T2); - pragma Assert (Big_2xxSingle * Big_D3 = Big_2xxSingle * Big_T2); - end; + 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); - declare - Big_D4 : constant Big_Integer := - Big_2xx (Scale) * Big (Double_Uns (D (4))); - Big_T3 : constant Big_Integer := Big (T3); - begin - pragma Assert (Big_D4 = Big_T3); - end; - pragma Assert (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big_2xxSingle * Big (T1) - + Big_2xxSingle * Big (T2) - + Big (T3)); + pragma Assert (Big_D4 = Big_T3); + pragma Assert + (By (Is_Scaled_Mult_Decomposition (0, Big_T1, Big_T2, Big_T3), + By (Big_2xxSingle * Big_2xxSingle * Big_D12 = + Big_2xxSingle * Big_2xxSingle * Big_T1, + Big_D12 = Big_T1) + and then + By (Big_2xxSingle * Big_D3 = Big_2xxSingle * Big_T2, + Big_D3 = Big_T2) + and then + Big_D4 = 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)))); + pragma Assert + (By (Is_Scaled_Mult_Decomposition + (Big (Double_Uns (Hi (T1))), + Big (Double_Uns (Lo (T1))) + Big (Double_Uns (Hi (T2))), + Big (Double_Uns (Lo (T2))) + Big (Double_Uns (Hi (T3))), + Big (Double_Uns (Lo (T3)))), + -- Start from stating equality between the expanded values of + -- the right-hand side in the known and desired assertions over + -- Is_Scaled_Mult_Decomposition. + By (Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * + Big (Double_Uns (Hi (T1))) + + Big_2xxSingle * Big_2xxSingle * + (Big (Double_Uns (Lo (T1))) + Big (Double_Uns (Hi (T2)))) + + Big_2xxSingle * + (Big (Double_Uns (Lo (T2))) + Big (Double_Uns (Hi (T3)))) + + Big (Double_Uns (Lo (T3))) = + Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * 0 + + Big_2xxSingle * Big_2xxSingle * Big_T1 + + Big_2xxSingle * Big_T2 + + Big_T3, + -- Now list all known equalities that contribute + Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * + Big (Double_Uns (Hi (T1))) + + Big_2xxSingle * Big_2xxSingle * + (Big (Double_Uns (Lo (T1))) + Big (Double_Uns (Hi (T2)))) + + Big_2xxSingle * + (Big (Double_Uns (Lo (T2))) + Big (Double_Uns (Hi (T3)))) + + Big (Double_Uns (Lo (T3))) = + Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * + Big (Double_Uns (Hi (T1))) + + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T1))) + + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) + + Big_2xxSingle * Big (Double_Uns (Lo (T2))) + + Big_2xxSingle * Big (Double_Uns (Hi (T3))) + + Big (Double_Uns (Lo (T3))) + and then + By (Big_2xxSingle * Big_2xxSingle * Big (T1) + = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (Hi (T1))) + + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T1))), + Big_2xxSingle * Big_2xxSingle * Big (T1) + = Big_2xxSingle * Big_2xxSingle + * (Big_2xxSingle * Big (Double_Uns (Hi (T1))) + + Big (Double_Uns (Lo (T1))))) + and then + By (Big_2xxSingle * Big (T2) + = Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) + + Big_2xxSingle * Big (Double_Uns (Lo (T2))), + Big_2xxSingle * Big (T2) + = Big_2xxSingle * (Big_2xxSingle * Big (Double_Uns (Hi (T2))) + + Big (Double_Uns (Lo (T2))))) + and then + Big (T3) = Big_2xxSingle * Big (Double_Uns (Hi (T3))) + + Big (Double_Uns (Lo (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)); + pragma Assert + (By (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)))), + By (Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (Lo (T1) or Hi (T2))) = + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T1))) + + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))), + Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (Lo (T1)) + Double_Uns (Hi (T2))) = + Big_2xxSingle * Big_2xxSingle + * (Big (Double_Uns (Lo (T1))) + Big (Double_Uns (Hi (T2))))) + and then + Big_2xxSingle * Big (Double_Uns (Lo (T2) or Hi (T3))) = + Big_2xxSingle * Big (Double_Uns (Lo (T2))) + + Big_2xxSingle * Big (Double_Uns (Hi (T3))))); end Prove_Dividend_Scaling; -------------------------- @@ -1944,6 +2296,23 @@ is 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)))); + pragma Assert + (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) + + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T3))) + = Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (S1))); + pragma Assert (Big (Double_Uns (Q)) * Big (Zu) = + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (S1)) + + Big_2xxSingle * Big (Double_Uns (S2)) + + Big (Double_Uns (S3))); + pragma Assert + (By (Big (Double_Uns (Q)) * Big (Zu) = Big3 (S1, S2, S3), + Big3 (S1, S2, S3) = + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (S1)) + + Big_2xxSingle * Big (Double_Uns (S2)) + + Big (Double_Uns (S3)))); end Prove_Multiplication; ----------------------------- @@ -2072,16 +2441,24 @@ is Lemma_Div_Definition (T1, Zlo, T1 / Zlo, T1 rem Zlo); pragma Assert (Double_Uns (Lo (T1 rem Zlo)) = T1 rem 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 (Mult = Big (Double_Uns (Zlo)) * (Big_2xxSingle * Big (T1 / Zlo) + Big (T2 / Zlo)) + Big (Ru)); + pragma Assert (Big_2xxSingle * Big (Double_Uns (D (2))) + + Big (Double_Uns (D (3))) + < Big_2xxSingle * (Big (Double_Uns (D (2))) + 1)); 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_Div_Lt (Big (T2), Big_2xxSingle, Big (Double_Uns (Zlo))); Lemma_Div_Commutation (T2, Double_Uns (Zlo)); Lemma_Lo_Is_Ident (T2 / Zlo); @@ -2119,24 +2496,58 @@ is Lemma_Abs_Commutation (X); Lemma_Abs_Commutation (Y); Lemma_Mult_Decomposition (Mult, Xu, Yu, Xhi, Xlo, Yhi, Ylo); + pragma Assert + (Is_Mult_Decomposition + (D1 => 0, + D2 => Big (Double_Uns'(Xhi * Yhi)), + D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (Double_Uns'(Xlo * Yhi)), + D4 => Big (Double_Uns'(Xlo * Ylo)))); T1 := Xlo * Ylo; D (4) := Lo (T1); D (3) := Hi (T1); Lemma_Hi_Lo (T1, D (3), D (4)); + pragma Assert + (Is_Mult_Decomposition + (D1 => 0, + D2 => Big (Double_Uns'(Xhi * Yhi)), + D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (Double_Uns'(Xlo * Yhi)) + + Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4))))); if Yhi /= 0 then T1 := Xlo * Yhi; Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); + pragma Assert + (Is_Mult_Decomposition + (D1 => 0, + D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (Hi (T1))), + D3 => Big (Double_Uns'(Xhi * Ylo)) + 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'(Xhi * Yhi)) + Big (Double_Uns (Hi (T1))), + D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (T2), + D4 => Big (Double_Uns (D (4))))); Lemma_Mult_Distribution (Big_2xxSingle, Big (Double_Uns (D (3))), Big (Double_Uns (Lo (T1)))); Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); + pragma Assert + (Is_Mult_Decomposition + (D1 => 0, + D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (Hi (T1))) + + Big (Double_Uns (Hi (T2))), + D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (Double_Uns (Lo (T2))), + D4 => Big (Double_Uns (D (4))))); D (3) := Lo (T2); D (2) := Hi (T1) + Hi (T2); @@ -2146,31 +2557,131 @@ is 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'(Xhi * Yhi)) + Big (Double_Uns (D (2))), + D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4))))); if Xhi /= 0 then T1 := Xhi * Ylo; Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); + pragma Assert + (By (Is_Mult_Decomposition + (D1 => 0, + D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))) + + Big (Double_Uns (Hi (T1))), + D3 => Big (Double_Uns (Lo (T1))) + Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4)))), + (By (Big_2xxSingle * Big (T1) = + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T1))) + + Big_2xxSingle * Big (Double_Uns (Lo (T1))), + Big_2xxSingle * Big (T1) = + Big_2xxSingle * (Big_2xxSingle * Big (Double_Uns (Hi (T1))) + + Big (Double_Uns (Lo (T1)))))))); T2 := D (3) + Lo (T1); + Lemma_Add_Commutation (Double_Uns (D (3)), Lo (T1)); + pragma Assert + (Is_Mult_Decomposition + (D1 => 0, + D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))) + + Big (Double_Uns (Hi (T1))), + D3 => Big (T2), + D4 => Big (Double_Uns (D (4))))); Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); + pragma Assert + (By (Is_Mult_Decomposition + (D1 => 0, + D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))) + + Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))), + D3 => Big (Double_Uns (Lo (T2))), + D4 => Big (Double_Uns (D (4)))), + By (Big_2xxSingle * Big (T2) = + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) + + Big_2xxSingle * Big (Double_Uns (Lo (T2))), + Big_2xxSingle * + (Big_2xxSingle * Big (Double_Uns (Hi (T2))) + + Big (Double_Uns (Lo (T2)))) + = Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T2))) + + Big_2xxSingle * Big (Double_Uns (Lo (T2)))))); D (3) := Lo (T2); T3 := D (2) + Hi (T1); + Lemma_Add_Commutation (Double_Uns (D (2)), Hi (T1)); + pragma Assert + (Is_Mult_Decomposition + (D1 => 0, + D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (T3) + + Big (Double_Uns (Hi (T2))), + D3 => Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4))))); Lemma_Add_Commutation (T3, Hi (T2)); T3 := T3 + Hi (T2); T2 := Double_Uns'(Xhi * Yhi); + pragma Assert + (Is_Mult_Decomposition + (D1 => 0, + D2 => Big (T2) + Big (T3), + D3 => Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4))))); Lemma_Hi_Lo (T2, Hi (T2), Lo (T2)); - Lemma_Add_Commutation (T3, Lo (T2)); + pragma Assert + (By (Is_Mult_Decomposition + (D1 => Big (Double_Uns (Hi (T2))), + D2 => Big (Double_Uns (Lo (T2))) + Big (T3), + D3 => Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4)))), + By (Big_2xxSingle * Big_2xxSingle * Big (T2) = + Big_2xxSingle * Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (Hi (T2))) + + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T2))), + Big_2xxSingle * Big_2xxSingle * + (Big_2xxSingle * Big (Double_Uns (Hi (T2))) + + Big (Double_Uns (Lo (T2)))) + = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (Hi (T2))) + + Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (Lo (T2)))))); T1 := T3 + Lo (T2); D (2) := Lo (T1); - Lemma_Hi_Lo (T1, Hi (T1), D (2)); + Lemma_Add_Commutation (T3, Lo (T2)); + pragma Assert + (Is_Mult_Decomposition + (D1 => Big (Double_Uns (Hi (T2))), + D2 => Big (T1), + D3 => Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4))))); + Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); + pragma Assert + (By (Is_Mult_Decomposition + (D1 => Big (Double_Uns (Hi (T2))) + Big (Double_Uns (Hi (T1))), + D2 => Big (Double_Uns (D (2))), + D3 => Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4)))), + By (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T1))) = + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))), + D (2) = Lo (T1)) + and then + By (Big_2xxSingle * Big_2xxSingle * Big (T1) = + Big_2xxSingle * Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (Hi (T1))) + + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Lo (T1))), + Big_2xxSingle * Big_2xxSingle * + (Big_2xxSingle * Big (Double_Uns (Hi (T1))) + + Big (Double_Uns (Lo (T1)))) + = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (Hi (T1))) + + Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (Lo (T1)))))); D (1) := Hi (T2) + Hi (T1); @@ -2181,32 +2692,71 @@ is (Big (Double_Uns (Hi (T2))) + Big (Double_Uns (Hi (T1))) = Big (Double_Uns (D (1)))); - pragma Assert (Mult = - Big_2xxSingle - * Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); - + pragma Assert + (By (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)))), + Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * + Big (Double_Uns (D (1))) + = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * + (Big (Double_Uns (Hi (T2)) + Double_Uns (Hi (T1)))))); else D (1) := 0; - end if; - pragma Assert (Mult = - Big_2xxSingle - * Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); + pragma Assert + (By (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)))), + Big (Double_Uns'(Xhi * Yhi)) = 0 + and then Big (Double_Uns'(Xhi * Ylo)) = 0 + and then Big (Double_Uns (D (1))) = 0)); + end if; + pragma Assert + (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 + (By (Is_Mult_Decomposition + (D1 => 0, + D2 => 0, + D3 => Big (Double_Uns'(Xhi * Ylo)) + Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4)))), + Big (Double_Uns'(Xhi * Yhi)) = 0 + and then Big (Double_Uns'(Xlo * Yhi)) = 0)); + if Xhi /= 0 then T1 := Xhi * Ylo; Lemma_Hi_Lo (T1, Hi (T1), Lo (T1)); + pragma Assert + (By (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)))), + Big_2xxSingle * Big (Double_Uns'(Xhi * Ylo)) = + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (Hi (T1))) + + Big_2xxSingle * Big (Double_Uns (Lo (T1))))); T2 := D (3) + Lo (T1); + Lemma_Add_Commutation (Double_Uns (Lo (T1)), D (3)); + pragma Assert + (By (Is_Mult_Decomposition + (D1 => 0, + D2 => Big (Double_Uns (Hi (T1))), + D3 => Big (T2), + D4 => Big (Double_Uns (D (4)))), + Big_2xxSingle * Big (T2) = + Big_2xxSingle * + (Big (Double_Uns (Lo (T1))) + Big (Double_Uns (D (3)))))); Lemma_Mult_Distribution (Big_2xxSingle, Big (Double_Uns (D (3))), Big (Double_Uns (Lo (T1)))); @@ -2221,28 +2771,32 @@ is pragma Assert (Big (Double_Uns (Hi (T1))) + Big (Double_Uns (Hi (T2))) = Big (Double_Uns (D (2)))); - pragma Assert (Mult = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); + 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 (Mult = - Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); + pragma Assert + (By (Is_Mult_Decomposition + (D1 => 0, + D2 => Big (Double_Uns (D (2))), + D3 => Big (Double_Uns (D (3))), + D4 => Big (Double_Uns (D (4)))), + Big (Double_Uns'(Xhi * Ylo)) = 0 + and then Big (Double_Uns (D (2))) = 0)); end if; D (1) := 0; end if; - pragma Assert (Mult = - Big_2xxSingle - * Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); + pragma Assert (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. @@ -2294,6 +2848,9 @@ is -- First normalize the divisor so that it has the leading bit on. -- We do this by finding the appropriate left shift amount. + Lemma_Lt_Commutation (D (1) & D (2), Zu); + pragma Assert (Mult < Big_2xxDouble * Big (Zu)); + Shift := Single_Size; Mask := Single_Uns'Last; Scale := 0; @@ -2366,6 +2923,8 @@ is procedure Prove_Shift_Progress is null; begin + pragma Assert (Mask = Shift_Left (Single_Uns'Last, + Single_Size - Shift_Prev)); Prove_Power; Shift := Shift / 2; @@ -2442,17 +3001,49 @@ is D (3) := Lo (T2) or Hi (T3); D (4) := Lo (T3); - pragma Assert (Mult * Big_2xx (Scale) = - Big_2xxSingle - * Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) - + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); - Lemma_Substitution (Big_2xxDouble * Big (Zu), Big_2xxDouble, Big (Zu), - Big (Double_Uns'(abs Z)) * Big_2xx (Scale), 0); - Lemma_Lt_Mult (Mult, Big_2xxDouble * Big (Double_Uns'(abs Z)), - Big_2xx (Scale), Big_2xxDouble * Big (Zu)); - Lemma_Div_Lt (Mult * Big_2xx (Scale), Big (Zu), Big_2xxDouble); + pragma Assert (Big (Double_Uns (Hi (T1))) = Big (Double_Uns (D (1)))); + pragma Assert + (Big_2xxSingle * Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (Hi (T1))) + = Big_2xxSingle * Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (D (1)))); + + pragma Assert + (Is_Scaled_Mult_Decomposition + (Big (Double_Uns (D (1))), + Big (Double_Uns (D (2))), + Big (Double_Uns (D (3))), + Big (Double_Uns (D (4))))); + pragma Assert + (By (Is_Scaled_Mult_Decomposition + (0, + 0, + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) + + Big_2xxSingle * Big (Double_Uns (D (2))) + + Big (Double_Uns (D (3))), + Big (Double_Uns (D (4)))), + Big_2xxSingle * + (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) + + Big_2xxSingle * Big (Double_Uns (D (2))) + + Big (Double_Uns (D (3)))) + + Big (Double_Uns (D (4))) = + Big_2xxSingle * + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) + + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) + + Big_2xxSingle * Big (Double_Uns (D (3))) + + Big (Double_Uns (D (4))) + and then + (By (Mult * Big_2xx (Scale) = + Big_2xxSingle * + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) + + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) + + Big_2xxSingle * Big (Double_Uns (D (3))) + + Big (Double_Uns (D (4))), + Is_Scaled_Mult_Decomposition + (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))) @@ -2460,6 +3051,46 @@ is + Big (Double_Uns (D (3))), Big3 (D (1), D (2), D (3)), Big (Double_Uns (D (4)))); + Lemma_Substitution (Big_2xxDouble * Big (Zu), Big_2xxDouble, Big (Zu), + Big (Double_Uns'(abs Z)) * Big_2xx (Scale), 0); + Lemma_Lt_Mult (Mult, Big_2xxDouble * Big (Double_Uns'(abs Z)), + Big_2xx (Scale), Big_2xxDouble * Big (Zu)); + Lemma_Div_Lt (Mult * Big_2xx (Scale), Big (Zu), Big_2xxDouble); + Lemma_Concat_Definition (D (1), D (2)); + Lemma_Double_Big_2xxSingle; + pragma Assert + (Big_2xxSingle * + (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) + + Big_2xxSingle * Big (Double_Uns (D (2))) + + Big (Double_Uns (D (3)))) + + Big (Double_Uns (D (4))) + = Big_2xxSingle * Big_2xxSingle * + (Big_2xxSingle * Big (Double_Uns (D (1))) + + Big (Double_Uns (D (2)))) + + Big_2xxSingle * Big (Double_Uns (D (3))) + + Big (Double_Uns (D (4)))); + pragma Assert + (By (Is_Scaled_Mult_Decomposition + (0, + Big_2xxSingle * Big (Double_Uns (D (1))) + + Big (Double_Uns (D (2))), + 0, + Big_2xxSingle * Big (Double_Uns (D (3))) + + Big (Double_Uns (D (4)))), + Big_2xxSingle * Big_2xxSingle * + (Big_2xxSingle * Big (Double_Uns (D (1))) + + Big (Double_Uns (D (2)))) = + Big_2xxSingle * + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1))) + + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))))); + 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 (Big (D (1) & D (2)) < Big (Zu)); -- Loop to compute quotient digits, runs twice for Qd (1) and Qd (2) @@ -2506,6 +3137,21 @@ is elsif D (J) = Zhi then Qd (J) := Single_Uns'Last; + Lemma_Concat_Definition (D (J), D (J + 1)); + pragma Assert (Big_2xxSingle > Big (Double_Uns (D (J + 2)))); + pragma Assert (Big3 (D (J), D (J + 1), 0) + Big_2xxSingle + > Big3 (D (J), D (J + 1), D (J + 2))); + 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))); @@ -2556,6 +3202,8 @@ is pragma Loop_Invariant (Qd (J)'Initialized); 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); @@ -2571,11 +3219,20 @@ is (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); Lemma_Substitution (Big3 (S1, S2, S3), Big (Zu), Big (Double_Uns (Qd (J))) - 1, Big (Double_Uns (Qd (J) - 1)), 0); - Qd (J) := Qd (J) - 1; + declare + Prev : constant Single_Uns := Qd (J) - 1 with Ghost; + begin + Qd (J) := Qd (J) - 1; + + pragma Assert (Qd (J) = Prev); + end; pragma Assert (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu)); @@ -2593,8 +3250,7 @@ is pragma Assert (Big3 (D (J), D (J + 1), D (J + 2)) < Big (Zu)); if D (J) > 0 then - pragma Assert - (Big_2xxSingle * Big_2xxSingle = Big_2xxDouble); + Lemma_Double_Big_2xxSingle; pragma Assert (Big3 (D (J), D (J + 1), D (J + 2)) = Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (J))) @@ -2604,9 +3260,22 @@ is Big_2xxDouble * Big (Double_Uns (D (J))) + Big_2xxSingle * Big (Double_Uns (D (J + 1))) + Big (Double_Uns (D (J + 2)))); + pragma Assert (Big_2xxSingle >= 0); + pragma Assert (Big (Double_Uns (D (J + 1))) >= 0); + pragma Assert + (Big_2xxSingle * Big (Double_Uns (D (J + 1))) >= 0); + pragma Assert + (Big_2xxSingle * Big (Double_Uns (D (J + 1))) + + Big (Double_Uns (D (J + 2))) >= 0); pragma Assert (Big3 (D (J), D (J + 1), D (J + 2)) >= Big_2xxDouble * 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); @@ -2972,6 +3641,7 @@ is 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)); diff --git a/gcc/ada/libgnat/s-aridou.ads b/gcc/ada/libgnat/s-aridou.ads index 815865f..29e13a5 100644 --- a/gcc/ada/libgnat/s-aridou.ads +++ b/gcc/ada/libgnat/s-aridou.ads @@ -34,7 +34,6 @@ -- or intermediate results are longer than the result type. with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; generic @@ -67,20 +66,27 @@ is Contract_Cases => Ignore, Ghost => Ignore); - package Signed_Conversion is new Signed_Conversions (Int => Double_Int); + 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; + 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; - package Unsigned_Conversion is new Unsigned_Conversions (Int => Double_Uns); + 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; function In_Double_Int_Range (Arg : Big_Integer) return Boolean is - (In_Range (Arg, Big (Double_Int'First), Big (Double_Int'Last))) + (BI_Ghost.In_Range (Arg, Big (Double_Int'First), Big (Double_Int'Last))) with Ghost; function Add_With_Ovflo_Check (X, Y : Double_Int) return Double_Int diff --git a/gcc/ada/libgnat/s-arit32.adb b/gcc/ada/libgnat/s-arit32.adb index baec78a..c3d9f6a 100644 --- a/gcc/ada/libgnat/s-arit32.adb +++ b/gcc/ada/libgnat/s-arit32.adb @@ -104,7 +104,7 @@ is function To_Neg_Int (A : Uns32) return Int32 with - Annotate => (GNATprove, Terminating), + Annotate => (GNATprove, Always_Return), Pre => In_Int32_Range (-Big (A)), Post => Big (To_Neg_Int'Result) = -Big (A); -- Convert to negative integer equivalent. If the input is in the range @@ -114,7 +114,7 @@ is function To_Pos_Int (A : Uns32) return Int32 with - Annotate => (GNATprove, Terminating), + Annotate => (GNATprove, Always_Return), Pre => In_Int32_Range (Big (A)), Post => Big (To_Pos_Int'Result) = Big (A); -- Convert to positive integer equivalent. If the input is in the range @@ -474,6 +474,7 @@ is 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))); @@ -508,7 +509,6 @@ is Lemma_Abs_Div_Commutation (Big (X) * Big (Y), Big (Z)); Lemma_Abs_Rem_Commutation (Big (X) * Big (Y), Big (Z)); - Lemma_Abs_Mult_Commutation (Big (X), Big (Y)); Lemma_Abs_Commutation (X); Lemma_Abs_Commutation (Y); Lemma_Abs_Commutation (Z); @@ -541,8 +541,10 @@ is end if; end if; + pragma Assert (In_Int32_Range (Big_Q)); pragma Assert (Big (Qu) = abs Big_Q); pragma Assert (Big (Ru) = abs Big_R); + Prove_Sign_R; -- Set final signs (RM 4.5.5(27-30)) @@ -563,7 +565,6 @@ is Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); end if; - Prove_Sign_R; Prove_Signs; end Scaled_Divide32; diff --git a/gcc/ada/libgnat/s-atacco.ads b/gcc/ada/libgnat/s-atacco.ads index 736210d..a928d47 100644 --- a/gcc/ada/libgnat/s-atacco.ads +++ b/gcc/ada/libgnat/s-atacco.ads @@ -54,8 +54,12 @@ package System.Address_To_Access_Conversions is -- optimizations that may cause unexpected results based on the assumption -- of no strict aliasing. - function To_Pointer (Value : Address) return Object_Pointer; - function To_Address (Value : Object_Pointer) return Address; + function To_Pointer (Value : Address) return Object_Pointer with + Global => null, + Annotate => (GNATprove, Always_Return); + function To_Address (Value : Object_Pointer) return Address with + SPARK_Mode => Off, + Annotate => (GNATprove, Always_Return); pragma Import (Intrinsic, To_Pointer); pragma Import (Intrinsic, To_Address); diff --git a/gcc/ada/libgnat/s-bignum.adb b/gcc/ada/libgnat/s-bignum.adb index 9377102..93f2229 100644 --- a/gcc/ada/libgnat/s-bignum.adb +++ b/gcc/ada/libgnat/s-bignum.adb @@ -29,7 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Unchecked_Conversion; with System.Generic_Bignums; with System.Secondary_Stack; use System.Secondary_Stack; with System.Shared_Bignums; use System.Shared_Bignums; diff --git a/gcc/ada/libgnat/s-conca2.adb b/gcc/ada/libgnat/s-conca2.adb index 49982f5..2a263ca 100644 --- a/gcc/ada/libgnat/s-conca2.adb +++ b/gcc/ada/libgnat/s-conca2.adb @@ -46,26 +46,8 @@ package body System.Concat_2 is R (F .. L) := S1; F := L + 1; - L := R'Last; + L := F + S2'Length - 1; R (F .. L) := S2; end Str_Concat_2; - ------------------------- - -- Str_Concat_Bounds_2 -- - ------------------------- - - procedure Str_Concat_Bounds_2 - (Lo, Hi : out Natural; - S1, S2 : String) - is - begin - if S1 = "" then - Lo := S2'First; - Hi := S2'Last; - else - Lo := S1'First; - Hi := S1'Last + S2'Length; - end if; - end Str_Concat_Bounds_2; - end System.Concat_2; diff --git a/gcc/ada/libgnat/s-conca2.ads b/gcc/ada/libgnat/s-conca2.ads index f9c7393..450435a 100644 --- a/gcc/ada/libgnat/s-conca2.ads +++ b/gcc/ada/libgnat/s-conca2.ads @@ -36,15 +36,8 @@ package System.Concat_2 is procedure Str_Concat_2 (R : out String; S1, S2 : String); -- Performs the operation R := S1 & S2. The bounds of R are known to be - -- correct (usually set by a call to the Str_Concat_Bounds_2 procedure - -- below), so no bounds checks are required, and it is known that none of + -- sufficient so no bound checks are required, and it is known that none of -- the input operands overlaps R. No assumptions can be made about the -- lower bounds of any of the operands. - procedure Str_Concat_Bounds_2 - (Lo, Hi : out Natural; - S1, S2 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the two - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_2; diff --git a/gcc/ada/libgnat/s-conca3.adb b/gcc/ada/libgnat/s-conca3.adb index d607082..ddba832 100644 --- a/gcc/ada/libgnat/s-conca3.adb +++ b/gcc/ada/libgnat/s-conca3.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_2; - package body System.Concat_3 is pragma Suppress (All_Checks); @@ -52,25 +50,8 @@ package body System.Concat_3 is R (F .. L) := S2; F := L + 1; - L := R'Last; + L := F + S3'Length - 1; R (F .. L) := S3; end Str_Concat_3; - ------------------------- - -- Str_Concat_Bounds_3 -- - ------------------------- - - procedure Str_Concat_Bounds_3 - (Lo, Hi : out Natural; - S1, S2, S3 : String) - is - begin - System.Concat_2.Str_Concat_Bounds_2 (Lo, Hi, S2, S3); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_3; - end System.Concat_3; diff --git a/gcc/ada/libgnat/s-conca3.ads b/gcc/ada/libgnat/s-conca3.ads index d7282ff..2ff3abc 100644 --- a/gcc/ada/libgnat/s-conca3.ads +++ b/gcc/ada/libgnat/s-conca3.ads @@ -36,15 +36,8 @@ package System.Concat_3 is procedure Str_Concat_3 (R : out String; S1, S2, S3 : String); -- Performs the operation R := S1 & S2 & S3. The bounds of R are known to - -- be correct (usually set by a call to the Str_Concat_Bounds_3 procedure - -- below), so no bounds checks are required, and it is known that none of - -- the input operands overlaps R. No assumptions can be made about the + -- be sufficient so no bound checks are required, and it is known that none + -- of the input operands overlaps R. No assumptions can be made about the -- lower bounds of any of the operands. - procedure Str_Concat_Bounds_3 - (Lo, Hi : out Natural; - S1, S2, S3 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the three - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_3; diff --git a/gcc/ada/libgnat/s-conca4.adb b/gcc/ada/libgnat/s-conca4.adb index 694033a..e1c7e92 100644 --- a/gcc/ada/libgnat/s-conca4.adb +++ b/gcc/ada/libgnat/s-conca4.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_3; - package body System.Concat_4 is pragma Suppress (All_Checks); @@ -56,25 +54,8 @@ package body System.Concat_4 is R (F .. L) := S3; F := L + 1; - L := R'Last; + L := F + S4'Length - 1; R (F .. L) := S4; end Str_Concat_4; - ------------------------- - -- Str_Concat_Bounds_4 -- - ------------------------- - - procedure Str_Concat_Bounds_4 - (Lo, Hi : out Natural; - S1, S2, S3, S4 : String) - is - begin - System.Concat_3.Str_Concat_Bounds_3 (Lo, Hi, S2, S3, S4); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_4; - end System.Concat_4; diff --git a/gcc/ada/libgnat/s-conca4.ads b/gcc/ada/libgnat/s-conca4.ads index 88b464d..ecc3108 100644 --- a/gcc/ada/libgnat/s-conca4.ads +++ b/gcc/ada/libgnat/s-conca4.ads @@ -36,15 +36,8 @@ package System.Concat_4 is procedure Str_Concat_4 (R : out String; S1, S2, S3, S4 : String); -- Performs the operation R := S1 & S2 & S3 & S4. The bounds - -- of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_5 procedure below), so no bounds checks are required, + -- of R are known to be sufficient so no bound checks are required, -- and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_4 - (Lo, Hi : out Natural; - S1, S2, S3, S4 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the four - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_4; diff --git a/gcc/ada/libgnat/s-conca5.adb b/gcc/ada/libgnat/s-conca5.adb index f611260..2283747 100644 --- a/gcc/ada/libgnat/s-conca5.adb +++ b/gcc/ada/libgnat/s-conca5.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_4; - package body System.Concat_5 is pragma Suppress (All_Checks); @@ -60,25 +58,8 @@ package body System.Concat_5 is R (F .. L) := S4; F := L + 1; - L := R'Last; + L := F + S5'Length - 1; R (F .. L) := S5; end Str_Concat_5; - ------------------------- - -- Str_Concat_Bounds_5 -- - ------------------------- - - procedure Str_Concat_Bounds_5 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5 : String) - is - begin - System.Concat_4.Str_Concat_Bounds_4 (Lo, Hi, S2, S3, S4, S5); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_5; - end System.Concat_5; diff --git a/gcc/ada/libgnat/s-conca5.ads b/gcc/ada/libgnat/s-conca5.ads index f6b8988..be7aace 100644 --- a/gcc/ada/libgnat/s-conca5.ads +++ b/gcc/ada/libgnat/s-conca5.ads @@ -36,15 +36,8 @@ package System.Concat_5 is procedure Str_Concat_5 (R : out String; S1, S2, S3, S4, S5 : String); -- Performs the operation R := S1 & S2 & S3 & S4 & S5. The bounds - -- of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_5 procedure below), so no bounds checks are required, + -- of R are known to be sufficient so no bound checks are required, -- and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_5 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the five - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_5; diff --git a/gcc/ada/libgnat/s-conca6.adb b/gcc/ada/libgnat/s-conca6.adb index 66b767f..b574d04 100644 --- a/gcc/ada/libgnat/s-conca6.adb +++ b/gcc/ada/libgnat/s-conca6.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_5; - package body System.Concat_6 is pragma Suppress (All_Checks); @@ -64,25 +62,8 @@ package body System.Concat_6 is R (F .. L) := S5; F := L + 1; - L := R'Last; + L := F + S6'Length - 1; R (F .. L) := S6; end Str_Concat_6; - ------------------------- - -- Str_Concat_Bounds_6 -- - ------------------------- - - procedure Str_Concat_Bounds_6 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6 : String) - is - begin - System.Concat_5.Str_Concat_Bounds_5 (Lo, Hi, S2, S3, S4, S5, S6); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_6; - end System.Concat_6; diff --git a/gcc/ada/libgnat/s-conca6.ads b/gcc/ada/libgnat/s-conca6.ads index e753251..2aac3d0 100644 --- a/gcc/ada/libgnat/s-conca6.ads +++ b/gcc/ada/libgnat/s-conca6.ads @@ -36,15 +36,8 @@ package System.Concat_6 is procedure Str_Concat_6 (R : out String; S1, S2, S3, S4, S5, S6 : String); -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6. The - -- bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_6 procedure below), so no bounds checks are required, + -- bounds of R are known to be sufficient so no bound checks are required, -- and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_6 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the six - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_6; diff --git a/gcc/ada/libgnat/s-conca7.adb b/gcc/ada/libgnat/s-conca7.adb index 0250887..e624b5c 100644 --- a/gcc/ada/libgnat/s-conca7.adb +++ b/gcc/ada/libgnat/s-conca7.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_6; - package body System.Concat_7 is pragma Suppress (All_Checks); @@ -71,25 +69,8 @@ package body System.Concat_7 is R (F .. L) := S6; F := L + 1; - L := R'Last; + L := F + S7'Length - 1; R (F .. L) := S7; end Str_Concat_7; - ------------------------- - -- Str_Concat_Bounds_7 -- - ------------------------- - - procedure Str_Concat_Bounds_7 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7 : String) - is - begin - System.Concat_6.Str_Concat_Bounds_6 (Lo, Hi, S2, S3, S4, S5, S6, S7); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_7; - end System.Concat_7; diff --git a/gcc/ada/libgnat/s-conca7.ads b/gcc/ada/libgnat/s-conca7.ads index c130ddf..7554995 100644 --- a/gcc/ada/libgnat/s-conca7.ads +++ b/gcc/ada/libgnat/s-conca7.ads @@ -38,15 +38,8 @@ package System.Concat_7 is (R : out String; S1, S2, S3, S4, S5, S6, S7 : String); -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7. The - -- bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_8 procedure below), so no bounds checks are required, + -- bounds of R are known to be sufficient so no bound checks are required, -- and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_7 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the seven - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_7; diff --git a/gcc/ada/libgnat/s-conca8.adb b/gcc/ada/libgnat/s-conca8.adb index d6ee36c..98b2e59 100644 --- a/gcc/ada/libgnat/s-conca8.adb +++ b/gcc/ada/libgnat/s-conca8.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_7; - package body System.Concat_8 is pragma Suppress (All_Checks); @@ -75,26 +73,8 @@ package body System.Concat_8 is R (F .. L) := S7; F := L + 1; - L := R'Last; + L := F + S8'Length - 1; R (F .. L) := S8; end Str_Concat_8; - ------------------------- - -- Str_Concat_Bounds_8 -- - ------------------------- - - procedure Str_Concat_Bounds_8 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8 : String) - is - begin - System.Concat_7.Str_Concat_Bounds_7 - (Lo, Hi, S2, S3, S4, S5, S6, S7, S8); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_8; - end System.Concat_8; diff --git a/gcc/ada/libgnat/s-conca8.ads b/gcc/ada/libgnat/s-conca8.ads index dda35c1..a249154 100644 --- a/gcc/ada/libgnat/s-conca8.ads +++ b/gcc/ada/libgnat/s-conca8.ads @@ -38,15 +38,8 @@ package System.Concat_8 is (R : out String; S1, S2, S3, S4, S5, S6, S7, S8 : String); -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7 & S8. - -- The bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_8 procedure below), so no bounds checks are required, - -- and it is known that none of the input operands overlaps R. No + -- The bounds of R are known to be sufficient so no bound checks are + -- required and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_8 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the eight - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_8; diff --git a/gcc/ada/libgnat/s-conca9.adb b/gcc/ada/libgnat/s-conca9.adb index bfe228e..08860f5 100644 --- a/gcc/ada/libgnat/s-conca9.adb +++ b/gcc/ada/libgnat/s-conca9.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.Concat_8; - package body System.Concat_9 is pragma Suppress (All_Checks); @@ -79,26 +77,8 @@ package body System.Concat_9 is R (F .. L) := S8; F := L + 1; - L := R'Last; + L := F + S9'Length - 1; R (F .. L) := S9; end Str_Concat_9; - ------------------------- - -- Str_Concat_Bounds_9 -- - ------------------------- - - procedure Str_Concat_Bounds_9 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8, S9 : String) - is - begin - System.Concat_8.Str_Concat_Bounds_8 - (Lo, Hi, S2, S3, S4, S5, S6, S7, S8, S9); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_9; - end System.Concat_9; diff --git a/gcc/ada/libgnat/s-conca9.ads b/gcc/ada/libgnat/s-conca9.ads index 7737a1e..39560ff 100644 --- a/gcc/ada/libgnat/s-conca9.ads +++ b/gcc/ada/libgnat/s-conca9.ads @@ -38,15 +38,8 @@ package System.Concat_9 is (R : out String; S1, S2, S3, S4, S5, S6, S7, S8, S9 : String); -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7 & S8 & S9. - -- The bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_9 procedure below), so no bounds checks are required, - -- and it is known that none of the input operands overlaps R. No + -- The bounds of R are known to be sufficient so no bound checks are + -- required, and it is known that none of the input operands overlaps R. No -- assumptions can be made about the lower bounds of any of the operands. - procedure Str_Concat_Bounds_9 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8, S9 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the nine - -- given strings, following the rules in the RM regarding null operands. - end System.Concat_9; diff --git a/gcc/ada/libgnat/s-dourea.adb b/gcc/ada/libgnat/s-dourea.adb index a6cf2a1..4f378d6 100644 --- a/gcc/ada/libgnat/s-dourea.adb +++ b/gcc/ada/libgnat/s-dourea.adb @@ -178,6 +178,12 @@ package body System.Double_Real is P, R : Double_T; begin + if Is_Infinity (B) or else Is_Zero (B) then + return (A.Hi / B, 0.0); + end if; + pragma Annotate (CodePeer, Intentional, "test always false", + "code deals with infinity"); + Q1 := A.Hi / B; -- Compute R = A - B * Q1 @@ -196,6 +202,12 @@ package body System.Double_Real is R, S : Double_T; begin + if Is_Infinity (B.Hi) or else Is_Zero (B.Hi) then + return (A.Hi / B.Hi, 0.0); + end if; + pragma Annotate (CodePeer, Intentional, "test always false", + "code deals with infinity"); + Q1 := A.Hi / B.Hi; R := A - B * Q1; diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb index 788be41..e1e55f3 100644 --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -44,7 +44,7 @@ with System.Storage_Elements; use System.Storage_Elements; package body System.Dwarf_Lines is - SSU : constant := System.Storage_Unit; + subtype Offset is Object_Reader.Offset; function Get_Load_Displacement (C : Dwarf_Context) return Storage_Offset; -- Return the displacement between the load address present in the binary @@ -76,14 +76,16 @@ package body System.Dwarf_Lines is -- Read an entry format array, as specified by 6.2.4.1 procedure Read_Aranges_Entry - (C : in out Dwarf_Context; - Start : out Address; - Len : out Storage_Count); + (C : in out Dwarf_Context; + Addr_Size : Natural; + Start : out Address; + Len : out Storage_Count); -- Read a single .debug_aranges pair procedure Read_Aranges_Header (C : in out Dwarf_Context; Info_Offset : out Offset; + Addr_Size : out Natural; Success : out Boolean); -- Read .debug_aranges header @@ -1069,12 +1071,13 @@ package body System.Dwarf_Lines is Info_Offset : out Offset; Success : out Boolean) is + Addr_Size : Natural; begin Info_Offset := 0; Seek (C.Aranges, 0); while Tell (C.Aranges) < Length (C.Aranges) loop - Read_Aranges_Header (C, Info_Offset, Success); + Read_Aranges_Header (C, Info_Offset, Addr_Size, Success); exit when not Success; loop @@ -1082,7 +1085,7 @@ package body System.Dwarf_Lines is Start : Address; Len : Storage_Count; begin - Read_Aranges_Entry (C, Start, Len); + Read_Aranges_Entry (C, Addr_Size, Start, Len); exit when Start = 0 and Len = 0; if Addr >= Start and then Addr < Start + Len @@ -1280,9 +1283,6 @@ package body System.Dwarf_Lines is Unit_Type := Read (C.Info); Addr_Sz := Read (C.Info); - if Addr_Sz /= (Address'Size / SSU) then - return; - end if; Read_Section_Offset (C.Info, Abbrev_Offset, Is64); @@ -1290,9 +1290,6 @@ package body System.Dwarf_Lines is Read_Section_Offset (C.Info, Abbrev_Offset, Is64); Addr_Sz := Read (C.Info); - if Addr_Sz /= (Address'Size / SSU) then - return; - end if; else return; @@ -1354,6 +1351,7 @@ package body System.Dwarf_Lines is procedure Read_Aranges_Header (C : in out Dwarf_Context; Info_Offset : out Offset; + Addr_Size : out Natural; Success : out Boolean) is Unit_Length : Offset; @@ -1364,6 +1362,7 @@ package body System.Dwarf_Lines is begin Success := False; Info_Offset := 0; + Addr_Size := 0; Read_Initial_Length (C.Aranges, Unit_Length, Is64); @@ -1376,10 +1375,7 @@ package body System.Dwarf_Lines is -- Read address_size (ubyte) - Sz := Read (C.Aranges); - if Sz /= (Address'Size / SSU) then - return; - end if; + Addr_Size := Natural (uint8'(Read (C.Aranges))); -- Read segment_size (ubyte) @@ -1392,7 +1388,7 @@ package body System.Dwarf_Lines is declare Cur_Off : constant Offset := Tell (C.Aranges); - Align : constant Offset := 2 * Address'Size / SSU; + Align : constant Offset := 2 * Offset (Addr_Size); Space : constant Offset := Cur_Off mod Align; begin if Space /= 0 then @@ -1408,14 +1404,15 @@ package body System.Dwarf_Lines is ------------------------ procedure Read_Aranges_Entry - (C : in out Dwarf_Context; - Start : out Address; - Len : out Storage_Count) + (C : in out Dwarf_Context; + Addr_Size : Natural; + Start : out Address; + Len : out Storage_Count) is begin -- Read table - if Address'Size = 32 then + if Addr_Size = 4 then declare S, L : uint32; begin @@ -1425,7 +1422,7 @@ package body System.Dwarf_Lines is Len := Storage_Count (L); end; - elsif Address'Size = 64 then + elsif Addr_Size = 8 then declare S, L : uint64; begin @@ -1520,6 +1517,7 @@ package body System.Dwarf_Lines is declare Info_Offset : Offset; Line_Offset : Offset; + Addr_Size : Natural; Success : Boolean; Ar_Start : Address; Ar_Len : Storage_Count; @@ -1531,7 +1529,7 @@ package body System.Dwarf_Lines is Seek (C.Aranges, 0); while Tell (C.Aranges) < Length (C.Aranges) loop - Read_Aranges_Header (C, Info_Offset, Success); + Read_Aranges_Header (C, Info_Offset, Addr_Size, Success); exit when not Success; Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); @@ -1540,11 +1538,11 @@ package body System.Dwarf_Lines is -- Read table loop - Read_Aranges_Entry (C, Ar_Start, Ar_Len); + Read_Aranges_Entry (C, Addr_Size, Ar_Start, Ar_Len); exit when Ar_Start = Null_Address and Ar_Len = 0; Len := uint32 (Ar_Len); - Start := uint32 (Ar_Start - C.Low); + Start := uint32 (Address'(Ar_Start - C.Low)); -- Search START in the array @@ -1764,7 +1762,8 @@ package body System.Dwarf_Lines is if C.Cache /= null then declare - Addr_Off : constant uint32 := uint32 (Addr - C.Low); + Addr_Off : constant uint32 := uint32 (Address'(Addr - C.Low)); + First, Last, Mid : Natural; begin First := C.Cache'First; diff --git a/gcc/ada/libgnat/s-expmod.adb b/gcc/ada/libgnat/s-expmod.adb index 60d86e5..527338d 100644 --- a/gcc/ada/libgnat/s-expmod.adb +++ b/gcc/ada/libgnat/s-expmod.adb @@ -251,9 +251,6 @@ is pragma Loop_Invariant (Equal_Modulo (Big (Result) * Big (Factor) ** Exp, Big (Left) ** Right)); pragma Loop_Variant (Decreases => Exp); - pragma Annotate - (CodePeer, False_Positive, - "validity check", "confusion on generated code"); if Exp rem 2 /= 0 then pragma Assert diff --git a/gcc/ada/libgnat/s-exponn.ads b/gcc/ada/libgnat/s-exponn.ads index 2c95f60..5c6eeac 100644 --- a/gcc/ada/libgnat/s-exponn.ads +++ b/gcc/ada/libgnat/s-exponn.ads @@ -32,7 +32,6 @@ -- Signed integer exponentiation (checks off) with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; generic @@ -41,7 +40,6 @@ generic 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 @@ -53,14 +51,18 @@ is Contract_Cases => Ignore, Ghost => Ignore); - package Signed_Conversion is new Signed_Conversions (Int => Int); + 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 - (In_Range (Arg, Big (Int'First), Big (Int'Last))) + (BI_Ghost.In_Range (Arg, Big (Int'First), Big (Int'Last))) with Ghost; function Expon (Left : Int; Right : Natural) return Int diff --git a/gcc/ada/libgnat/s-expont.ads b/gcc/ada/libgnat/s-expont.ads index 7ca43ab..99de227 100644 --- a/gcc/ada/libgnat/s-expont.ads +++ b/gcc/ada/libgnat/s-expont.ads @@ -32,7 +32,6 @@ -- Signed integer exponentiation (checks on) with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; generic @@ -41,7 +40,6 @@ generic 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 @@ -53,14 +51,18 @@ is Contract_Cases => Ignore, Ghost => Ignore); - package Signed_Conversion is new Signed_Conversions (Int => Int); + 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 - (In_Range (Arg, Big (Int'First), Big (Int'Last))) + (BI_Ghost.In_Range (Arg, Big (Int'First), Big (Int'Last))) with Ghost; function Expon (Left : Int; Right : Natural) return Int diff --git a/gcc/ada/libgnat/s-gearop.adb b/gcc/ada/libgnat/s-gearop.adb index 32c67c3..78f4ba8 100644 --- a/gcc/ada/libgnat/s-gearop.adb +++ b/gcc/ada/libgnat/s-gearop.adb @@ -32,7 +32,8 @@ -- 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. +-- policy to Ignore, here for non-generic code, and inside the generic for +-- generic code. pragma Assertion_Policy (Pre => Ignore, Post => Ignore, @@ -72,6 +73,12 @@ is -------------- function Diagonal (A : Matrix) return Vector is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); + N : constant Natural := Natural'Min (A'Length (1), A'Length (2)); begin return R : Vector (A'First (1) .. A'First (1) + (N - 1)) @@ -126,6 +133,11 @@ is --------------------- procedure Back_Substitute (M, N : in out Matrix) is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); pragma Assert (M'First (1) = N'First (1) and then M'Last (1) = N'Last (1)); @@ -215,6 +227,11 @@ is N : in out Matrix; Det : out Scalar) is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); pragma Assert (M'First (1) = N'First (1) and then M'Last (1) = N'Last (1)); @@ -460,6 +477,11 @@ is ------------- function L2_Norm (X : X_Vector) return Result_Real'Base is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); Sum : Result_Real'Base := 0.0; begin @@ -479,6 +501,11 @@ is ---------------------------------- function Matrix_Elementwise_Operation (X : X_Matrix) return Result_Matrix is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); begin return R : Result_Matrix (X'Range (1), X'Range (2)) with Relaxed_Initialization @@ -524,6 +551,11 @@ is (Left : Left_Matrix; Right : Right_Matrix) return Result_Matrix is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); begin return R : Result_Matrix (Left'Range (1), Left'Range (2)) with Relaxed_Initialization @@ -570,6 +602,11 @@ is Y : Y_Matrix; Z : Z_Scalar) return Result_Matrix is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); begin return R : Result_Matrix (X'Range (1), X'Range (2)) with Relaxed_Initialization @@ -657,6 +694,11 @@ is (Left : Left_Matrix; Right : Right_Scalar) return Result_Matrix is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); begin return R : Result_Matrix (Left'Range (1), Left'Range (2)) with Relaxed_Initialization @@ -705,6 +747,11 @@ is (Left : Left_Scalar; Right : Right_Matrix) return Result_Matrix is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); begin return R : Result_Matrix (Right'Range (1), Right'Range (2)) with Relaxed_Initialization @@ -811,6 +858,11 @@ is (Left : Left_Matrix; Right : Right_Matrix) return Result_Matrix is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); begin return R : Result_Matrix (Left'Range (1), Right'Range (2)) with Relaxed_Initialization @@ -856,6 +908,11 @@ is ---------------------------- function Matrix_Vector_Solution (A : Matrix; X : Vector) return Vector is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); procedure Ignore (M : Matrix) with @@ -917,6 +974,11 @@ is ---------------------------- function Matrix_Matrix_Solution (A, X : Matrix) return Matrix is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); procedure Ignore (M : Matrix) with @@ -1035,6 +1097,11 @@ is (Left : Left_Vector; Right : Right_Vector) return Matrix is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); begin return R : Matrix (Left'Range, Right'Range) with Relaxed_Initialization @@ -1078,6 +1145,11 @@ is --------------- procedure Transpose (A : Matrix; R : out Matrix) is + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); begin for J in R'Range (1) loop for K in R'Range (2) loop diff --git a/gcc/ada/libgnat/s-gearop.ads b/gcc/ada/libgnat/s-gearop.ads index 15e1174..f5ee8bc 100644 --- a/gcc/ada/libgnat/s-gearop.ads +++ b/gcc/ada/libgnat/s-gearop.ads @@ -36,16 +36,10 @@ -- overflows in arithmetic operations passed on as formal generic subprogram -- parameters. --- 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); +-- Preconditions in this unit are meant mostly for analysis, but will be +-- activated at runtime depending on the assertion policy for preconditions at +-- the program point of instantiation. These preconditions are simply checking +-- bounds, so should not impact running time. package System.Generic_Array_Operations with SPARK_Mode diff --git a/gcc/ada/libgnat/s-imaged.ads b/gcc/ada/libgnat/s-imaged.ads index 41c7515..f23eac8 100644 --- a/gcc/ada/libgnat/s-imaged.ads +++ b/gcc/ada/libgnat/s-imaged.ads @@ -38,7 +38,6 @@ generic type Int is range <>; package System.Image_D is - pragma Pure; procedure Image_Decimal (V : Int; diff --git a/gcc/ada/libgnat/s-imagef.adb b/gcc/ada/libgnat/s-imagef.adb index 14e9d06..fd8e848 100644 --- a/gcc/ada/libgnat/s-imagef.adb +++ b/gcc/ada/libgnat/s-imagef.adb @@ -31,9 +31,24 @@ with System.Image_I; with System.Img_Util; use System.Img_Util; +with System.Val_Util; 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 @@ -54,7 +69,70 @@ package body System.Image_F is -- if the small is larger than 1, and smaller than 2**(Int'Size - 1) / 10 -- if the small is smaller than 1. - package Image_I is new System.Image_I (Int); + -- Define ghost subprograms without implementation (marked as Import) to + -- create a suitable package Int_Params for type Int, as instantiations + -- of System.Image_F use for this type one of the derived integer types + -- defined in Interfaces, instead of the standard signed integer types + -- which are used to define System.Img_*.Int_Params. + + type Uns_Option (Overflow : Boolean := False) is record + case Overflow is + when True => + null; + when False => + Value : Uns := 0; + end case; + end record; + + Unsigned_Width_Ghost : constant Natural := Int'Width; + + function Wrap_Option (Value : Uns) return Uns_Option + with Ghost, Import; + function Only_Decimal_Ghost + (Str : String; + From, To : Integer) + return Boolean + with Ghost, Import; + function Hexa_To_Unsigned_Ghost (X : Character) return Uns + with Ghost, Import; + function Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + return Uns_Option + with Ghost, Import; + function Is_Integer_Ghost (Str : String) return Boolean + with Ghost, Import; + procedure Prove_Iter_Scan_Based_Number_Ghost + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with Ghost, Import; + procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) + with Ghost, Import; + function Abs_Uns_Of_Int (Val : Int) return Uns + with Ghost, Import; + function Value_Integer (Str : String) return Int + with Ghost, Import; + + package Int_Params is new Val_Util.Int_Params + (Int => Int, + Uns => Uns, + Uns_Option => Uns_Option, + Unsigned_Width_Ghost => Unsigned_Width_Ghost, + Wrap_Option => Wrap_Option, + Only_Decimal_Ghost => Only_Decimal_Ghost, + Hexa_To_Unsigned_Ghost => Hexa_To_Unsigned_Ghost, + Scan_Based_Number_Ghost => Scan_Based_Number_Ghost, + Is_Integer_Ghost => Is_Integer_Ghost, + Prove_Iter_Scan_Based_Number_Ghost => Prove_Iter_Scan_Based_Number_Ghost, + Prove_Scan_Only_Decimal_Ghost => Prove_Scan_Only_Decimal_Ghost, + Abs_Uns_Of_Int => Abs_Uns_Of_Int, + Value_Integer => Value_Integer); + + package Image_I is new System.Image_I (Int_Params); procedure Set_Image_Integer (V : Int; @@ -96,7 +174,7 @@ package body System.Image_F is -- operation are omitted here. -- A 64-bit value can represent all integers with 18 decimal digits, but - -- not all with 19 decimal digits. If the total number of requested ouput + -- not all with 19 decimal digits. If the total number of requested output -- digits (Fore - 1) + Aft is greater than 18 then, for purposes of the -- conversion, Aft is adjusted to 18 - (Fore - 1). In that case, trailing -- zeros can complete the output after writing the first 18 significant @@ -355,6 +433,8 @@ package body System.Image_F is Digs (1 .. 2) := " 0"; Ndigs := 2; end if; + pragma Annotate (CodePeer, False_Positive, "test always true", + "no digits were output for zero"); Set_Decimal_Digits (Digs, Ndigs, S, P, Scale, Fore, Aft, Exp); end Set_Image_Fixed; diff --git a/gcc/ada/libgnat/s-imagef.ads b/gcc/ada/libgnat/s-imagef.ads index 67892b1..13ea22f 100644 --- a/gcc/ada/libgnat/s-imagef.ads +++ b/gcc/ada/libgnat/s-imagef.ads @@ -36,6 +36,7 @@ generic type Int is range <>; + type Uns is mod <>; with procedure Scaled_Divide (X, Y, Z : Int; @@ -43,7 +44,6 @@ generic Round : Boolean); package System.Image_F is - pragma Pure; procedure Image_Fixed (V : Int; diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb index e7199af..ff853d3 100644 --- a/gcc/ada/libgnat/s-imagei.adb +++ b/gcc/ada/libgnat/s-imagei.adb @@ -29,18 +29,140 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; +use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; + 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); + + -- As a use_clause for Int_Params cannot be used for instances of this + -- generic in System specs, rename all constants and subprograms. + + Unsigned_Width_Ghost : constant Natural := Int_Params.Unsigned_Width_Ghost; + + function Wrap_Option (Value : Uns) return Uns_Option + renames Int_Params.Wrap_Option; + function Only_Decimal_Ghost + (Str : String; + From, To : Integer) + return Boolean + renames Int_Params.Only_Decimal_Ghost; + function Hexa_To_Unsigned_Ghost (X : Character) return Uns + renames Int_Params.Hexa_To_Unsigned_Ghost; + function Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + return Uns_Option + renames Int_Params.Scan_Based_Number_Ghost; + function Is_Integer_Ghost (Str : String) return Boolean + renames Int_Params.Is_Integer_Ghost; + procedure Prove_Iter_Scan_Based_Number_Ghost + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + renames Int_Params.Prove_Iter_Scan_Based_Number_Ghost; + procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) + renames Int_Params.Prove_Scan_Only_Decimal_Ghost; + function Abs_Uns_Of_Int (Val : Int) return Uns + renames Int_Params.Abs_Uns_Of_Int; + function Value_Integer (Str : String) return Int + renames Int_Params.Value_Integer; + 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); + 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 Only_Decimal_Ghost (S, From => P'Old + 1, To => P) + and then Scan_Based_Number_Ghost (S, From => P'Old + 1, To => P) + = Wrap_Option (Uns_Of_Non_Positive (T)); -- 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 -- ------------------- @@ -52,6 +174,39 @@ package body System.Image_I is 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 Only_Decimal_Ghost (S, From => 2, To => P) + and then Scan_Based_Number_Ghost (S, From => 2, To => P) + = Wrap_Option (Abs_Uns_Of_Int (V)), + Post => Is_Integer_Ghost (S (1 .. P)) + and then Value_Integer (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 (Only_Decimal_Ghost (Str, From => 2, To => P)); + Prove_Iter_Scan_Based_Number_Ghost (S, Str, From => 2, To => P); + pragma Assert (Scan_Based_Number_Ghost (Str, From => 2, To => P) + = Wrap_Option (Abs_Uns_Of_Int (V))); + Prove_Scan_Only_Decimal_Ghost (Str, V); + end Prove_Value_Integer; + + -- Start of processing for Image_Integer + begin if V >= 0 then S (1) := ' '; @@ -63,7 +218,16 @@ package body System.Image_I is pragma Assert (P < S'Last - 1); end if; - Set_Image_Integer (V, S, P); + 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; + + Prove_Value_Integer; end Image_Integer; ---------------- @@ -77,6 +241,106 @@ package body System.Image_I is is Nb_Digits : Natural := 0; Value : Non_Positive := T; + + -- Local ghost variables + + Pow : Big_Positive := 1 with Ghost; + S_Init : constant String := S with Ghost; + Uns_T : constant Uns := Uns_Of_Non_Positive (T) with Ghost; + Uns_Value : Uns := Uns_Of_Non_Positive (Value) with Ghost; + Prev, Cur : Uns_Option with Ghost; + Prev_Value : Uns with Ghost; + Prev_S : String := S with Ghost; + + -- Local ghost lemmas + + procedure Prove_Character_Val (RU : Uns; RI : Int) + with + Ghost, + Pre => RU in 0 .. 9 + and then RI in 0 .. 9, + Post => Character'Val (48 + RU) in '0' .. '9' + and then Character'Val (48 + RI) in '0' .. '9'; + -- Ghost lemma to prove the value of a character corresponding to the + -- next figure. + + procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) + with + Ghost, + Pre => RU in 0 .. 9 + and then RI in 0 .. 9, + Post => Hexa_To_Unsigned_Ghost (Character'Val (48 + RU)) = RU + and then 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_Unchanged + with + Ghost, + Pre => P <= S'Last + and then S_Init'First = S'First + and then S_Init'Last = S'Last + and then (for all K in S'First .. P => S (K) = S_Init (K)), + Post => S (S'First .. P) = S_Init (S'First .. P); + -- Ghost lemma to prove that the part of string S before P has not been + -- modified. + + 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. + + procedure Prove_Iter_Scan + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Ghost, + Pre => Str1'Last /= Positive'Last + and then + (From > To or else (From >= Str1'First and then To <= Str1'Last)) + and then Only_Decimal_Ghost (Str1, From, To) + and then Str1'First = Str2'First + and then Str1'Last = Str2'Last + 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); + -- Ghost lemma to prove that the result of Scan_Based_Number_Ghost only + -- depends on the value of the argument string in the (From .. To) range + -- of indexes. This is a wrapper on Prove_Iter_Scan_Based_Number_Ghost + -- so that we can call it here on ghost arguments. + + ----------------------------- + -- Local lemma null bodies -- + ----------------------------- + + procedure Prove_Character_Val (RU : Uns; RI : Int) is null; + procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) is null; + procedure Prove_Unchanged is null; + procedure Prove_Uns_Of_Non_Positive_Value is null; + + --------------------- + -- Prove_Iter_Scan -- + --------------------- + + procedure Prove_Iter_Scan + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is + begin + Prove_Iter_Scan_Based_Number_Ghost (Str1, Str2, From, To, Base, Acc); + end Prove_Iter_Scan; + + -- 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 @@ -86,19 +350,118 @@ package body System.Image_I is -- First we compute the number of characters needed for representing -- the number. loop + Lemma_Div_Commutation (Uns_Of_Non_Positive (Value), 10); + Lemma_Div_Twice (Big (Uns_Of_Non_Positive (T)), + Big_10 ** Nb_Digits, Big_10); + Prove_Uns_Of_Non_Positive_Value; + Value := Value / 10; Nb_Digits := Nb_Digits + 1; + + Uns_Value := Uns_Value / 10; + Pow := Pow * 10; + + pragma Loop_Invariant (Uns_Value = Uns_Of_Non_Positive (Value)); + pragma Loop_Invariant (Nb_Digits in 1 .. Unsigned_Width_Ghost - 1); + pragma Loop_Invariant (Pow = Big_10 ** Nb_Digits); + pragma Loop_Invariant (Big (Uns_Value) = Big (Uns_T) / Pow); + pragma Loop_Variant (Increases => Value); + exit when Value = 0; + + Lemma_Non_Zero (Uns_Value); + pragma Assert (Pow <= Big (Uns'Last)); end loop; Value := T; + Uns_Value := Uns_Of_Non_Positive (T); + Pow := 1; + + pragma Assert (Uns_Value = From_Big (Big (Uns_T) / Big_10 ** 0)); -- We now populate digits from the end of the string to the beginning for J in reverse 1 .. Nb_Digits loop + Lemma_Div_Commutation (Uns_Value, 10); + Lemma_Div_Twice (Big (Uns_T), Big_10 ** (Nb_Digits - J), Big_10); + Prove_Character_Val (Uns_Value rem 10, -(Value rem 10)); + Prove_Hexa_To_Unsigned_Ghost (Uns_Value rem 10, -(Value rem 10)); + Prove_Uns_Of_Non_Positive_Value; + pragma Assert (Uns_Value rem 10 = Uns_Of_Non_Positive (Value rem 10)); + pragma Assert (Uns_Value rem 10 = Uns (-(Value rem 10))); + pragma Assert + (Uns_Value = From_Big (Big (Uns_T) / Big_10 ** (Nb_Digits - J))); + + 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; + + pragma Assert (S (P + J) in '0' .. '9'); + pragma Assert (Hexa_To_Unsigned_Ghost (S (P + J)) = + From_Big (Big (Uns_T) / Big_10 ** (Nb_Digits - J)) rem 10); + pragma Assert + (for all K in P + J + 1 .. P + Nb_Digits => S (K) in '0' .. '9'); + + Prev := Scan_Based_Number_Ghost + (Str => S, + From => P + J + 1, + To => P + Nb_Digits, + Base => 10, + Acc => Prev_Value); + Cur := Scan_Based_Number_Ghost + (Str => S, + From => P + J, + To => P + Nb_Digits, + Base => 10, + Acc => Uns_Value); + pragma Assert (Prev_Value = 10 * Uns_Value + (Prev_Value rem 10)); + pragma Assert + (Prev_Value rem 10 = Hexa_To_Unsigned_Ghost (S (P + J))); + pragma Assert + (Prev_Value = 10 * Uns_Value + Hexa_To_Unsigned_Ghost (S (P + J))); + + if J /= Nb_Digits then + Prove_Iter_Scan + (Prev_S, S, P + J + 1, P + Nb_Digits, 10, Prev_Value); + end if; + + pragma Assert (Prev = Cur); + pragma Assert (Prev = Wrap_Option (Uns_T)); + + 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 (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 + (Scan_Based_Number_Ghost + (Str => S, + From => P + J, + To => P + Nb_Digits, + Base => 10, + Acc => Uns_Value) + = Wrap_Option (Uns_T)); end loop; + pragma Assert (Big (Uns_Value) = Big (Uns_T) / Big_10 ** (Nb_Digits)); + pragma Assert (Uns_Value = 0); + Prove_Unchanged; + pragma Assert + (Scan_Based_Number_Ghost + (Str => S, + From => P + 1, + To => P + Nb_Digits, + Base => 10, + Acc => Uns_Value) + = Wrap_Option (Uns_T)); + P := P + Nb_Digits; end Set_Digits; diff --git a/gcc/ada/libgnat/s-imagei.ads b/gcc/ada/libgnat/s-imagei.ads index 7d2434b..10116d1 100644 --- a/gcc/ada/libgnat/s-imagei.ads +++ b/gcc/ada/libgnat/s-imagei.ads @@ -33,17 +33,45 @@ -- signed integer types, 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.Val_Util; + generic - type Int is range <>; + with package Int_Params is new System.Val_Util.Int_Params (<>); package System.Image_I is - pragma Pure; + + subtype Int is Int_Params.Int; + use type Int_Params.Int; + + subtype Uns is Int_Params.Uns; + use type Int_Params.Uns; + + subtype Uns_Option is Int_Params.Uns_Option; + use type Int_Params.Uns_Option; procedure Image_Integer (V : Int; S : in out String; - P : out Natural); + P : out Natural) + with + Pre => S'First = 1 + and then S'Last < Integer'Last + and then S'Last >= Int_Params.Unsigned_Width_Ghost, + Post => P in S'Range + and then Int_Params.Value_Integer (S (1 .. P)) = V; -- 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. @@ -51,7 +79,31 @@ package System.Image_I is procedure Set_Image_Integer (V : Int; S : in out String; - P : in out Natural); + 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 - Int_Params.Unsigned_Width_Ghost + 1 + else + P <= S'Last - Int_Params.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 := Int_Params.Abs_Uns_Of_Int (V); + begin + Minus = (V < 0) + and then P in P'Old + Offset .. S'Last + and then Int_Params.Only_Decimal_Ghost + (S, From => P'Old + Offset, To => P) + and then Int_Params.Scan_Based_Number_Ghost + (S, From => P'Old + Offset, To => P) + = Int_Params.Wrap_Option (Abs_V)); -- Stores the image of V in S starting at S (P + 1), P is updated to point -- to the last character stored. The value stored is identical to the value -- of Int'Image (V) except that no leading space is stored when V is diff --git a/gcc/ada/libgnat/s-imager.ads b/gcc/ada/libgnat/s-imager.ads index 2a6a321..6828b6f 100644 --- a/gcc/ada/libgnat/s-imager.ads +++ b/gcc/ada/libgnat/s-imager.ads @@ -48,7 +48,6 @@ generic P : in out Natural); package System.Image_R is - pragma Pure; procedure Image_Fixed_Point (V : Num; diff --git a/gcc/ada/libgnat/s-imageu.adb b/gcc/ada/libgnat/s-imageu.adb index 3ca5efc..6932487 100644 --- a/gcc/ada/libgnat/s-imageu.adb +++ b/gcc/ada/libgnat/s-imageu.adb @@ -29,8 +29,106 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; +use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; + 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; + + -- 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; + + ------------------ + -- 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); + + procedure Lemma_Unsigned_Width_Ghost + with + Ghost, + Post => Unsigned_Width_Ghost = Max_Log10 + 2; + + --------------------------- + -- 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; + + -------------------------------- + -- Lemma_Unsigned_Width_Ghost -- + -------------------------------- + + procedure Lemma_Unsigned_Width_Ghost is + begin + pragma Assert (Unsigned_Width_Ghost <= Max_Log10 + 2); + pragma Assert (Big (Uns'Last) > Big_10 ** Max_Log10); + pragma Assert (Big (Uns'Last) < Big_10 ** (Unsigned_Width_Ghost - 1)); + pragma Assert (Unsigned_Width_Ghost >= Max_Log10 + 2); + end Lemma_Unsigned_Width_Ghost; + -------------------- -- Image_Unsigned -- -------------------- @@ -41,10 +139,45 @@ package body System.Image_U is P : out Natural) is pragma Assert (S'First = 1); + + procedure Prove_Value_Unsigned + with + Ghost, + Pre => S'First = 1 + and then S'Last < Integer'Last + and then P in 2 .. S'Last + and then S (1) = ' ' + and then Only_Decimal_Ghost (S, From => 2, To => P) + and then Scan_Based_Number_Ghost (S, From => 2, To => P) + = Wrap_Option (V), + Post => Is_Unsigned_Ghost (S (1 .. P)) + and then Value_Unsigned (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 (Only_Decimal_Ghost (Str, From => 2, To => P)); + Prove_Iter_Scan_Based_Number_Ghost (S, Str, From => 2, To => P); + pragma Assert (Scan_Based_Number_Ghost (Str, From => 2, To => P) + = Wrap_Option (V)); + 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; ------------------------ @@ -58,27 +191,208 @@ package body System.Image_U is is Nb_Digits : Natural := 0; Value : Uns := V; + + -- Local ghost variables + + Pow : Big_Positive := 1 with Ghost; + S_Init : constant String := S with Ghost; + Prev, Cur : Uns_Option with Ghost; + Prev_Value : Uns with Ghost; + Prev_S : String := S with Ghost; + + -- Local ghost lemmas + + procedure Prove_Character_Val (R : Uns) + with + Ghost, + Pre => R in 0 .. 9, + Post => Character'Val (48 + R) 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 => 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 => 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_Unchanged + with + Ghost, + Pre => P <= S'Last + and then S_Init'First = S'First + and then S_Init'Last = S'Last + and then (for all K in S'First .. P => S (K) = S_Init (K)), + Post => S (S'First .. P) = S_Init (S'First .. P); + -- Ghost lemma to prove that the part of string S before P has not been + -- modified. + + procedure Prove_Iter_Scan + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Ghost, + Pre => Str1'Last /= Positive'Last + and then + (From > To or else (From >= Str1'First and then To <= Str1'Last)) + and then Only_Decimal_Ghost (Str1, From, To) + and then Str1'First = Str2'First + and then Str1'Last = Str2'Last + 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); + -- Ghost lemma to prove that the result of Scan_Based_Number_Ghost only + -- depends on the value of the argument string in the (From .. To) range + -- of indexes. This is a wrapper on Prove_Iter_Scan_Based_Number_Ghost + -- so that we can call it here on ghost arguments. + + ----------------------------- + -- 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; + procedure Prove_Unchanged is null; + + --------------------- + -- Prove_Iter_Scan -- + --------------------- + + procedure Prove_Iter_Scan + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is + begin + Prove_Iter_Scan_Based_Number_Ghost (Str1, Str2, From, To, Base, Acc); + end Prove_Iter_Scan; + + -- Start of processing for Set_Image_Unsigned + begin pragma Assert (P >= S'First - 1 and then P < S'Last and then P < Natural'Last); -- No check is done since, as documented in the specification, the -- caller guarantees that S is long enough to hold the result. + Lemma_Unsigned_Width_Ghost; + -- 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; 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 + 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 rem 10); + 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; + + pragma Assert (S (P + J) in '0' .. '9'); + pragma Assert (Hexa_To_Unsigned_Ghost (S (P + J)) = + From_Big (Big (V) / Big_10 ** (Nb_Digits - J)) rem 10); + pragma Assert + (for all K in P + J + 1 .. P + Nb_Digits => S (K) in '0' .. '9'); + pragma Assert + (for all K in P + J + 1 .. P + Nb_Digits => + Hexa_To_Unsigned_Ghost (S (K)) = + From_Big (Big (V) / Big_10 ** (Nb_Digits - (K - P))) rem 10); + + Prev := Scan_Based_Number_Ghost + (Str => S, + From => P + J + 1, + To => P + Nb_Digits, + Base => 10, + Acc => Prev_Value); + Cur := Scan_Based_Number_Ghost + (Str => S, + From => P + J, + To => P + Nb_Digits, + Base => 10, + Acc => Value); + + if J /= Nb_Digits then + Prove_Euclidian (Val => Prev_Value, + Quot => Value, + Rest => Hexa_To_Unsigned_Ghost (S (P + J))); + pragma Assert + (Prev_Value = 10 * Value + Hexa_To_Unsigned_Ghost (S (P + J))); + Prove_Iter_Scan + (Prev_S, S, P + J + 1, P + Nb_Digits, 10, Prev_Value); + end if; + + pragma Assert (Prev = Cur); + pragma Assert (Prev = Wrap_Option (V)); + + 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 (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 + (for all K in P + J .. P + Nb_Digits => + Hexa_To_Unsigned_Ghost (S (K)) = + From_Big (Big (V) / Big_10 ** (Nb_Digits - (K - P))) rem 10); + pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1)); + pragma Loop_Invariant (Big (Value) = Big (V) / Pow); + pragma Loop_Invariant + (Scan_Based_Number_Ghost + (Str => S, + From => P + J, + To => P + Nb_Digits, + Base => 10, + Acc => Value) + = Wrap_Option (V)); end loop; + pragma Assert (Value = 0); + + Prove_Unchanged; P := P + Nb_Digits; end Set_Image_Unsigned; diff --git a/gcc/ada/libgnat/s-imageu.ads b/gcc/ada/libgnat/s-imageu.ads index 5983e5d..789cf65 100644 --- a/gcc/ada/libgnat/s-imageu.ads +++ b/gcc/ada/libgnat/s-imageu.ads @@ -33,17 +33,68 @@ -- modular integer types, 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); + generic type Uns is mod <>; + type Uns_Option is private; + + -- Additional parameters for ghost subprograms used inside contracts + + Unsigned_Width_Ghost : Natural; + + with function Wrap_Option (Value : Uns) return Uns_Option + with Ghost; + with function Only_Decimal_Ghost + (Str : String; + From, To : Integer) + return Boolean + with Ghost; + with function Hexa_To_Unsigned_Ghost (X : Character) return Uns + with Ghost; + with function Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) return Uns_Option + with Ghost; + with function Is_Unsigned_Ghost (Str : String) return Boolean + with Ghost; + with function Value_Unsigned (Str : String) return Uns; + with procedure Prove_Iter_Scan_Based_Number_Ghost + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with Ghost; + with procedure Prove_Scan_Only_Decimal_Ghost + (Str : String; + Val : Uns) + with Ghost; package System.Image_U is - pragma Pure; procedure Image_Unsigned (V : Uns; S : in out String; - P : out Natural); + 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 Value_Unsigned (S (1 .. P)) = V; pragma Inline (Image_Unsigned); -- 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 @@ -52,7 +103,18 @@ package System.Image_U is procedure Set_Image_Unsigned (V : Uns; S : in out String; - P : in out Natural); + 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 Only_Decimal_Ghost (S, From => P'Old + 1, To => P) + and then Scan_Based_Number_Ghost (S, From => P'Old + 1, To => P) + = Wrap_Option (V); -- Stores the image of V in S starting at S (P + 1), P is updated to point -- to the last character stored. The value stored is identical to the value -- of Uns'Image (V) except that no leading space is stored. The caller diff --git a/gcc/ada/libgnat/s-imde128.ads b/gcc/ada/libgnat/s-imde128.ads index e2caac8..2bd339f 100644 --- a/gcc/ada/libgnat/s-imde128.ads +++ b/gcc/ada/libgnat/s-imde128.ads @@ -37,7 +37,6 @@ with Interfaces; with System.Image_D; package System.Img_Decimal_128 is - pragma Pure; subtype Int128 is Interfaces.Integer_128; diff --git a/gcc/ada/libgnat/s-imde32.ads b/gcc/ada/libgnat/s-imde32.ads index 0397d9c..47d7792 100644 --- a/gcc/ada/libgnat/s-imde32.ads +++ b/gcc/ada/libgnat/s-imde32.ads @@ -37,7 +37,6 @@ with Interfaces; with System.Image_D; package System.Img_Decimal_32 is - pragma Pure; subtype Int32 is Interfaces.Integer_32; diff --git a/gcc/ada/libgnat/s-imde64.ads b/gcc/ada/libgnat/s-imde64.ads index c147cb0..d84f5c9 100644 --- a/gcc/ada/libgnat/s-imde64.ads +++ b/gcc/ada/libgnat/s-imde64.ads @@ -37,7 +37,6 @@ with Interfaces; with System.Image_D; package System.Img_Decimal_64 is - pragma Pure; subtype Int64 is Interfaces.Integer_64; diff --git a/gcc/ada/libgnat/s-imfi128.ads b/gcc/ada/libgnat/s-imfi128.ads index 2658454..7f64b83 100644 --- a/gcc/ada/libgnat/s-imfi128.ads +++ b/gcc/ada/libgnat/s-imfi128.ads @@ -37,11 +37,11 @@ with System.Arith_128; with System.Image_F; package System.Img_Fixed_128 is - pragma Pure; subtype Int128 is Interfaces.Integer_128; + subtype Uns128 is Interfaces.Unsigned_128; - package Impl is new Image_F (Int128, Arith_128.Scaled_Divide128); + package Impl is new Image_F (Int128, Uns128, Arith_128.Scaled_Divide128); procedure Image_Fixed128 (V : Int128; diff --git a/gcc/ada/libgnat/s-imfi32.ads b/gcc/ada/libgnat/s-imfi32.ads index d722e51..e5c6ff8 100644 --- a/gcc/ada/libgnat/s-imfi32.ads +++ b/gcc/ada/libgnat/s-imfi32.ads @@ -37,11 +37,11 @@ with System.Arith_32; with System.Image_F; package System.Img_Fixed_32 is - pragma Pure; subtype Int32 is Interfaces.Integer_32; + subtype Uns32 is Interfaces.Unsigned_32; - package Impl is new Image_F (Int32, Arith_32.Scaled_Divide32); + package Impl is new Image_F (Int32, Uns32, Arith_32.Scaled_Divide32); procedure Image_Fixed32 (V : Int32; diff --git a/gcc/ada/libgnat/s-imfi64.ads b/gcc/ada/libgnat/s-imfi64.ads index c2e9f1b..91f4daf 100644 --- a/gcc/ada/libgnat/s-imfi64.ads +++ b/gcc/ada/libgnat/s-imfi64.ads @@ -37,11 +37,11 @@ with System.Arith_64; with System.Image_F; package System.Img_Fixed_64 is - pragma Pure; subtype Int64 is Interfaces.Integer_64; + subtype Uns64 is Interfaces.Unsigned_64; - package Impl is new Image_F (Int64, Arith_64.Scaled_Divide64); + package Impl is new Image_F (Int64, Uns64, Arith_64.Scaled_Divide64); procedure Image_Fixed64 (V : Int64; diff --git a/gcc/ada/libgnat/s-imgboo.adb b/gcc/ada/libgnat/s-imgboo.adb index 221c0c6..eb2cc96 100644 --- a/gcc/ada/libgnat/s-imgboo.adb +++ b/gcc/ada/libgnat/s-imgboo.adb @@ -37,6 +37,8 @@ pragma Assertion_Policy (Ghost => Ignore, Loop_Invariant => Ignore, Assert => Ignore); +with System.Val_Util; + package body System.Img_Bool with SPARK_Mode is @@ -55,9 +57,13 @@ is if V then S (1 .. 4) := "TRUE"; P := 4; + pragma Assert + (System.Val_Util.First_Non_Space_Ghost (S, S'First, S'Last) = 1); else S (1 .. 5) := "FALSE"; P := 5; + pragma Assert + (System.Val_Util.First_Non_Space_Ghost (S, S'First, S'Last) = 1); end if; end Image_Boolean; diff --git a/gcc/ada/libgnat/s-imgflt.ads b/gcc/ada/libgnat/s-imgflt.ads index 59e5087..cc7df51 100644 --- a/gcc/ada/libgnat/s-imgflt.ads +++ b/gcc/ada/libgnat/s-imgflt.ads @@ -38,7 +38,6 @@ with System.Powten_Flt; with System.Unsigned_Types; package System.Img_Flt is - pragma Pure; package Impl is new Image_R (Float, diff --git a/gcc/ada/libgnat/s-imgint.ads b/gcc/ada/libgnat/s-imgint.ads index 7b1fe22..fd5bea3 100644 --- a/gcc/ada/libgnat/s-imgint.ads +++ b/gcc/ada/libgnat/s-imgint.ads @@ -33,12 +33,51 @@ -- signed integer types up to 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.Val_Int; +with System.Val_Uns; +with System.Val_Util; +with System.Wid_Uns; + +package System.Img_Int + with SPARK_Mode +is + subtype Unsigned is Unsigned_Types.Unsigned; -package System.Img_Int is - pragma Pure; + package Int_Params is new Val_Util.Int_Params + (Int => Integer, + Uns => Unsigned, + Uns_Option => Val_Uns.Impl.Uns_Option, + Unsigned_Width_Ghost => + Wid_Uns.Width_Unsigned (0, Unsigned'Last), + Only_Decimal_Ghost => Val_Uns.Impl.Only_Decimal_Ghost, + Hexa_To_Unsigned_Ghost => + Val_Uns.Impl.Hexa_To_Unsigned_Ghost, + Wrap_Option => Val_Uns.Impl.Wrap_Option, + Scan_Based_Number_Ghost => + Val_Uns.Impl.Scan_Based_Number_Ghost, + Prove_Iter_Scan_Based_Number_Ghost => + Val_Uns.Impl.Prove_Iter_Scan_Based_Number_Ghost, + Is_Integer_Ghost => Val_Int.Impl.Is_Integer_Ghost, + Prove_Scan_Only_Decimal_Ghost => + Val_Int.Impl.Prove_Scan_Only_Decimal_Ghost, + Abs_Uns_Of_Int => Val_Int.Impl.Abs_Uns_Of_Int, + Value_Integer => Val_Int.Impl.Value_Integer); - package Impl is new Image_I (Integer); + package Impl is new Image_I (Int_Params); procedure Image_Integer (V : Integer; diff --git a/gcc/ada/libgnat/s-imglfl.ads b/gcc/ada/libgnat/s-imglfl.ads index 2a27986..294990a 100644 --- a/gcc/ada/libgnat/s-imglfl.ads +++ b/gcc/ada/libgnat/s-imglfl.ads @@ -38,7 +38,6 @@ with System.Powten_LFlt; with System.Unsigned_Types; package System.Img_LFlt is - pragma Pure; -- Note that the following instantiation is really for a 32-bit target, -- where 128-bit integer types are not available. For a 64-bit targaet, diff --git a/gcc/ada/libgnat/s-imgllf.ads b/gcc/ada/libgnat/s-imgllf.ads index 074b37d..b10a029 100644 --- a/gcc/ada/libgnat/s-imgllf.ads +++ b/gcc/ada/libgnat/s-imgllf.ads @@ -38,7 +38,6 @@ with System.Powten_LLF; with System.Unsigned_Types; package System.Img_LLF is - pragma Pure; -- Note that the following instantiation is really for a 32-bit target, -- where 128-bit integer types are not available. For a 64-bit targaet, diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads index fc773ae..20f108c 100644 --- a/gcc/ada/libgnat/s-imglli.ads +++ b/gcc/ada/libgnat/s-imglli.ads @@ -33,12 +33,51 @@ -- signed integer types larger than 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.Val_LLI; +with System.Val_LLU; +with System.Val_Util; +with System.Wid_LLU; + +package System.Img_LLI + with SPARK_Mode +is + subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; -package System.Img_LLI is - pragma Pure; + package Int_Params is new Val_Util.Int_Params + (Int => Long_Long_Integer, + Uns => Long_Long_Unsigned, + Uns_Option => Val_LLU.Impl.Uns_Option, + Unsigned_Width_Ghost => + Wid_LLU.Width_Long_Long_Unsigned (0, Long_Long_Unsigned'Last), + Only_Decimal_Ghost => Val_LLU.Impl.Only_Decimal_Ghost, + Hexa_To_Unsigned_Ghost => + Val_LLU.Impl.Hexa_To_Unsigned_Ghost, + Wrap_Option => Val_LLU.Impl.Wrap_Option, + Scan_Based_Number_Ghost => + Val_LLU.Impl.Scan_Based_Number_Ghost, + Prove_Iter_Scan_Based_Number_Ghost => + Val_LLU.Impl.Prove_Iter_Scan_Based_Number_Ghost, + Is_Integer_Ghost => Val_LLI.Impl.Is_Integer_Ghost, + Prove_Scan_Only_Decimal_Ghost => + Val_LLI.Impl.Prove_Scan_Only_Decimal_Ghost, + Abs_Uns_Of_Int => Val_LLI.Impl.Abs_Uns_Of_Int, + Value_Integer => Val_LLI.Impl.Value_Integer); - package Impl is new Image_I (Long_Long_Integer); + package Impl is new Image_I (Int_Params); procedure Image_Long_Long_Integer (V : Long_Long_Integer; diff --git a/gcc/ada/libgnat/s-imgllli.ads b/gcc/ada/libgnat/s-imgllli.ads index a5a1052..989c296 100644 --- a/gcc/ada/libgnat/s-imgllli.ads +++ b/gcc/ada/libgnat/s-imgllli.ads @@ -33,12 +33,52 @@ -- 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.Val_LLLI; +with System.Val_LLLU; +with System.Val_Util; +with System.Wid_LLLU; + +package System.Img_LLLI + with SPARK_Mode +is + subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; -package System.Img_LLLI is - pragma Pure; + package Int_Params is new Val_Util.Int_Params + (Int => Long_Long_Long_Integer, + Uns => Long_Long_Long_Unsigned, + Uns_Option => Val_LLLU.Impl.Uns_Option, + Unsigned_Width_Ghost => + Wid_LLLU.Width_Long_Long_Long_Unsigned + (0, Long_Long_Long_Unsigned'Last), + Only_Decimal_Ghost => Val_LLLU.Impl.Only_Decimal_Ghost, + Hexa_To_Unsigned_Ghost => + Val_LLLU.Impl.Hexa_To_Unsigned_Ghost, + Wrap_Option => Val_LLLU.Impl.Wrap_Option, + Scan_Based_Number_Ghost => + Val_LLLU.Impl.Scan_Based_Number_Ghost, + Prove_Iter_Scan_Based_Number_Ghost => + Val_LLLU.Impl.Prove_Iter_Scan_Based_Number_Ghost, + Is_Integer_Ghost => Val_LLLI.Impl.Is_Integer_Ghost, + Prove_Scan_Only_Decimal_Ghost => + Val_LLLI.Impl.Prove_Scan_Only_Decimal_Ghost, + Abs_Uns_Of_Int => Val_LLLI.Impl.Abs_Uns_Of_Int, + Value_Integer => Val_LLLI.Impl.Value_Integer); - package Impl is new Image_I (Long_Long_Long_Integer); + package Impl is new Image_I (Int_Params); procedure Image_Long_Long_Long_Integer (V : Long_Long_Long_Integer; diff --git a/gcc/ada/libgnat/s-imglllu.ads b/gcc/ada/libgnat/s-imglllu.ads index ae918c4..0116aa8 100644 --- a/gcc/ada/libgnat/s-imglllu.ads +++ b/gcc/ada/libgnat/s-imglllu.ads @@ -33,15 +33,46 @@ -- 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.Val_LLLU; +with System.Wid_LLLU; -package System.Img_LLLU is - pragma Pure; - +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 (Long_Long_Long_Unsigned); + package Impl is new Image_U + (Uns => Long_Long_Long_Unsigned, + Uns_Option => Val_LLLU.Impl.Uns_Option, + Unsigned_Width_Ghost => + Wid_LLLU.Width_Long_Long_Long_Unsigned + (0, Long_Long_Long_Unsigned'Last), + Only_Decimal_Ghost => Val_LLLU.Impl.Only_Decimal_Ghost, + Hexa_To_Unsigned_Ghost => + Val_LLLU.Impl.Hexa_To_Unsigned_Ghost, + Wrap_Option => Val_LLLU.Impl.Wrap_Option, + Scan_Based_Number_Ghost => + Val_LLLU.Impl.Scan_Based_Number_Ghost, + Is_Unsigned_Ghost => Val_LLLU.Impl.Is_Unsigned_Ghost, + Value_Unsigned => Val_LLLU.Impl.Value_Unsigned, + Prove_Iter_Scan_Based_Number_Ghost => + Val_LLLU.Impl.Prove_Iter_Scan_Based_Number_Ghost, + Prove_Scan_Only_Decimal_Ghost => + Val_LLLU.Impl.Prove_Scan_Only_Decimal_Ghost); procedure Image_Long_Long_Long_Unsigned (V : Long_Long_Long_Unsigned; diff --git a/gcc/ada/libgnat/s-imgllu.ads b/gcc/ada/libgnat/s-imgllu.ads index 220228f..67372d7 100644 --- a/gcc/ada/libgnat/s-imgllu.ads +++ b/gcc/ada/libgnat/s-imgllu.ads @@ -33,15 +33,45 @@ -- modular integer types larger than 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.Val_LLU; +with System.Wid_LLU; -package System.Img_LLU is - pragma Pure; - +package System.Img_LLU + with SPARK_Mode +is subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - package Impl is new Image_U (Long_Long_Unsigned); + package Impl is new Image_U + (Uns => Long_Long_Unsigned, + Uns_Option => Val_LLU.Impl.Uns_Option, + Unsigned_Width_Ghost => + Wid_LLU.Width_Long_Long_Unsigned (0, Long_Long_Unsigned'Last), + Only_Decimal_Ghost => Val_LLU.Impl.Only_Decimal_Ghost, + Hexa_To_Unsigned_Ghost => + Val_LLU.Impl.Hexa_To_Unsigned_Ghost, + Wrap_Option => Val_LLU.Impl.Wrap_Option, + Scan_Based_Number_Ghost => + Val_LLU.Impl.Scan_Based_Number_Ghost, + Is_Unsigned_Ghost => Val_LLU.Impl.Is_Unsigned_Ghost, + Value_Unsigned => Val_LLU.Impl.Value_Unsigned, + Prove_Iter_Scan_Based_Number_Ghost => + Val_LLU.Impl.Prove_Iter_Scan_Based_Number_Ghost, + Prove_Scan_Only_Decimal_Ghost => + Val_LLU.Impl.Prove_Scan_Only_Decimal_Ghost); procedure Image_Long_Long_Unsigned (V : Long_Long_Unsigned; diff --git a/gcc/ada/libgnat/s-imgrea.ads b/gcc/ada/libgnat/s-imgrea.ads index ca18d95..8d663b7 100644 --- a/gcc/ada/libgnat/s-imgrea.ads +++ b/gcc/ada/libgnat/s-imgrea.ads @@ -34,7 +34,6 @@ with System.Img_LLF; package System.Img_Real is - pragma Pure; procedure Set_Image_Real (V : Long_Long_Float; diff --git a/gcc/ada/libgnat/s-imguns.ads b/gcc/ada/libgnat/s-imguns.ads index c15a79d..fa903ce 100644 --- a/gcc/ada/libgnat/s-imguns.ads +++ b/gcc/ada/libgnat/s-imguns.ads @@ -33,15 +33,45 @@ -- modular integer types up to 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.Val_Uns; +with System.Wid_Uns; -package System.Img_Uns is - pragma Pure; - +package System.Img_Uns + with SPARK_Mode +is subtype Unsigned is Unsigned_Types.Unsigned; - package Impl is new Image_U (Unsigned); + package Impl is new Image_U + (Uns => Unsigned, + Uns_Option => Val_Uns.Impl.Uns_Option, + Unsigned_Width_Ghost => + Wid_Uns.Width_Unsigned (0, Unsigned'Last), + Only_Decimal_Ghost => Val_Uns.Impl.Only_Decimal_Ghost, + Hexa_To_Unsigned_Ghost => + Val_Uns.Impl.Hexa_To_Unsigned_Ghost, + Wrap_Option => Val_Uns.Impl.Wrap_Option, + Scan_Based_Number_Ghost => + Val_Uns.Impl.Scan_Based_Number_Ghost, + Is_Unsigned_Ghost => Val_Uns.Impl.Is_Unsigned_Ghost, + Value_Unsigned => Val_Uns.Impl.Value_Unsigned, + Prove_Iter_Scan_Based_Number_Ghost => + Val_Uns.Impl.Prove_Iter_Scan_Based_Number_Ghost, + Prove_Scan_Only_Decimal_Ghost => + Val_Uns.Impl.Prove_Scan_Only_Decimal_Ghost); procedure Image_Unsigned (V : Unsigned; diff --git a/gcc/ada/libgnat/s-imguti.ads b/gcc/ada/libgnat/s-imguti.ads index 541c42b..37e592f 100644 --- a/gcc/ada/libgnat/s-imguti.ads +++ b/gcc/ada/libgnat/s-imguti.ads @@ -32,7 +32,6 @@ -- This package provides some common utilities used by the s-imgxxx files package System.Img_Util is - pragma Pure; Max_Real_Image_Length : constant := 5200; -- If Exp is set to zero and Aft is set to Text_IO.Field'Last (i.e., 255) diff --git a/gcc/ada/libgnat/s-objrea.adb b/gcc/ada/libgnat/s-objrea.adb index 854bbb2..843ccf5 100644 --- a/gcc/ada/libgnat/s-objrea.adb +++ b/gcc/ada/libgnat/s-objrea.adb @@ -979,7 +979,7 @@ package body System.Object_Reader is -- Map section table - Opt_Stream := Create_Stream (Res.Mf, Signature_Loc_Offset, 4); + Opt_Stream := Create_Stream (Res.MF, Signature_Loc_Offset, 4); Hdr_Offset := Offset (uint32'(Read (Opt_Stream))); Close (Opt_Stream); Res.Sectab_Stream := Create_Stream @@ -999,7 +999,7 @@ package body System.Object_Reader is Opt_32 : Optional_Header_PE32; begin Opt_Stream := Create_Stream - (Res.Mf, Opt_Offset, Opt_32'Size / SSU); + (Res.MF, Opt_Offset, Opt_32'Size / SSU); Read_Raw (Opt_Stream, Opt_32'Address, uint32 (Opt_32'Size / SSU)); Res.ImageBase := uint64 (Opt_32.ImageBase); @@ -1011,7 +1011,7 @@ package body System.Object_Reader is Opt_64 : Optional_Header_PE64; begin Opt_Stream := Create_Stream - (Res.Mf, Opt_Offset, Opt_64'Size / SSU); + (Res.MF, Opt_Offset, Opt_64'Size / SSU); Read_Raw (Opt_Stream, Opt_64'Address, uint32 (Opt_64'Size / SSU)); Res.ImageBase := Opt_64.ImageBase; @@ -1367,7 +1367,7 @@ package body System.Object_Reader is Strtab_Sz : uint32; begin - Res.Mf := F; + Res.MF := F; Res.In_Exception := In_Exception; Res.Arch := PPC; @@ -1515,14 +1515,14 @@ package body System.Object_Reader is end Arch; function Create_Stream - (Mf : Mapped_File; + (MF : Mapped_File; File_Offset : File_Size; File_Length : File_Size) return Mapped_Stream is Region : Mapped_Region; begin - Read (Mf, Region, File_Offset, File_Length, False); + Read (MF, Region, File_Offset, File_Length, False); return (Region, 0, Offset (File_Length)); end Create_Stream; @@ -1531,7 +1531,7 @@ package body System.Object_Reader is Sec : Object_Section) return Mapped_Stream is begin - return Create_Stream (Obj.Mf, File_Size (Sec.Off), File_Size (Sec.Size)); + return Create_Stream (Obj.MF, File_Size (Sec.Off), File_Size (Sec.Size)); end Create_Stream; procedure Tell (Obj : in out Mapped_Stream; Off : out Offset) is @@ -1573,7 +1573,7 @@ package body System.Object_Reader is null; end case; - Close (Obj.Mf); + Close (Obj.MF); end Close; ------------------------ diff --git a/gcc/ada/libgnat/s-objrea.ads b/gcc/ada/libgnat/s-objrea.ads index fc440ff..ee72114 100644 --- a/gcc/ada/libgnat/s-objrea.ads +++ b/gcc/ada/libgnat/s-objrea.ads @@ -187,7 +187,7 @@ package System.Object_Reader is type Mapped_Stream is private; -- Provide an abstraction of a stream on a memory mapped file - function Create_Stream (Mf : System.Mmap.Mapped_File; + function Create_Stream (MF : System.Mmap.Mapped_File; File_Offset : System.Mmap.File_Size; File_Length : System.Mmap.File_Size) return Mapped_Stream; @@ -381,7 +381,7 @@ private subtype Any_PECOFF is Object_Format range PECOFF .. PECOFF_PLUS; type Object_File (Format : Object_Format) is record - Mf : System.Mmap.Mapped_File := System.Mmap.Invalid_Mapped_File; + MF : System.Mmap.Mapped_File := System.Mmap.Invalid_Mapped_File; Arch : Object_Arch := Unknown; Num_Sections : uint32 := 0; diff --git a/gcc/ada/libgnat/s-os_lib.adb b/gcc/ada/libgnat/s-os_lib.adb index 0681580..53dfbf9 100644 --- a/gcc/ada/libgnat/s-os_lib.adb +++ b/gcc/ada/libgnat/s-os_lib.adb @@ -1602,15 +1602,15 @@ package body System.OS_Lib is SIGKILL : constant := 9; SIGINT : constant := 2; - procedure C_Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer); + procedure C_Kill (Pid : Process_Id; Sig_Num : Integer); pragma Import (C, C_Kill, "__gnat_kill"); begin if Pid /= Invalid_Pid then if Hard_Kill then - C_Kill (Pid, SIGKILL, 1); + C_Kill (Pid, SIGKILL); else - C_Kill (Pid, SIGINT, 1); + C_Kill (Pid, SIGINT); end if; end if; end Kill; @@ -1940,7 +1940,7 @@ package body System.OS_Lib is procedure Quote_Argument (Arg : in out String_Access) is J : Positive := 1; Quote_Needed : Boolean := False; - Res : String (1 .. Arg'Length * 2); + Res : String (1 .. Arg'Length * 2 + 2); begin if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb index cc36fce..10d8b84 100644 --- a/gcc/ada/libgnat/s-putima.adb +++ b/gcc/ada/libgnat/s-putima.adb @@ -32,7 +32,7 @@ with Ada.Strings.Text_Buffers.Utils; use Ada.Strings.Text_Buffers; use Ada.Strings.Text_Buffers.Utils; -with Unchecked_Conversion; +with Ada.Unchecked_Conversion; package body System.Put_Images is @@ -133,7 +133,7 @@ package body System.Put_Images is procedure Put_Image_Pointer (S : in out Sink'Class; X : Pointer; Type_Kind : String) is - function Cast is new Unchecked_Conversion + function Cast is new Ada.Unchecked_Conversion (System.Address, Unsigned_Address); begin if X = null then diff --git a/gcc/ada/libgnat/s-regpat.adb b/gcc/ada/libgnat/s-regpat.adb index 4f758f9..3290f90 100644 --- a/gcc/ada/libgnat/s-regpat.adb +++ b/gcc/ada/libgnat/s-regpat.adb @@ -359,10 +359,11 @@ package body System.Regpat is ------------- procedure Compile - (Matcher : out Pattern_Matcher; - Expression : String; - Final_Code_Size : out Program_Size; - Flags : Regexp_Flags := No_Flags) + (Matcher : out Pattern_Matcher; + Expression : String; + Final_Code_Size : out Program_Size; + Flags : Regexp_Flags := No_Flags; + Error_When_Too_Small : Boolean := True) is -- We can't allocate space until we know how big the compiled form -- will be, but we can't compile it (and thus know how big it is) @@ -1994,6 +1995,12 @@ package body System.Regpat is end if; PM.Flags := Flags; + + -- Raise the appropriate error when Matcher does not have enough space + + if Error_When_Too_Small and then Matcher.Size < Final_Code_Size then + raise Expression_Error with "Pattern_Matcher is too small"; + end if; end Compile; function Compile @@ -2009,7 +2016,7 @@ package body System.Regpat is Size : Program_Size; begin - Compile (Dummy, Expression, Size, Flags); + Compile (Dummy, Expression, Size, Flags, Error_When_Too_Small => False); if Size <= Dummy.Size then return Pattern_Matcher' @@ -2023,17 +2030,13 @@ package body System.Regpat is Program => Dummy.Program (Dummy.Program'First .. Dummy.Program'First + Size - 1)); - else - -- We have to recompile now that we know the size - -- ??? Can we use Ada 2005's return construct ? - - declare - Result : Pattern_Matcher (Size); - begin - Compile (Result, Expression, Size, Flags); - return Result; - end; end if; + + return + Result : Pattern_Matcher (Size) + do + Compile (Result, Expression, Size, Flags); + end return; end Compile; procedure Compile diff --git a/gcc/ada/libgnat/s-regpat.ads b/gcc/ada/libgnat/s-regpat.ads index baa91be..6d0cbf4 100644 --- a/gcc/ada/libgnat/s-regpat.ads +++ b/gcc/ada/libgnat/s-regpat.ads @@ -403,10 +403,11 @@ package System.Regpat is -- (e.g. case sensitivity,...). procedure Compile - (Matcher : out Pattern_Matcher; - Expression : String; - Final_Code_Size : out Program_Size; - Flags : Regexp_Flags := No_Flags); + (Matcher : out Pattern_Matcher; + Expression : String; + Final_Code_Size : out Program_Size; + Flags : Regexp_Flags := No_Flags; + Error_When_Too_Small : Boolean := True); -- Compile a regular expression into internal code -- This procedure is significantly faster than the Compile function since @@ -426,7 +427,25 @@ package System.Regpat is -- expression. -- -- This function raises Storage_Error if Matcher is too small to hold - -- the resulting code (i.e. Matcher.Size has too small a value). + -- the resulting code (i.e. Matcher.Size has too small a value) only when + -- the paramter Error_When_Too_Small is set to True. Otherwise, no error + -- will be raised and the required size will be placed in the + -- Final_Code_Size parameter. + -- + -- Thus when Error_When_Too_Small is specified as false a check will need + -- to be made to ensure successful compilation - as in: + -- + -- ... + -- Compile + -- (Matcher, Expr, Code_Size, Flags, Error_When_Too_Small => False); + -- + -- if Matcher.Size < Code_Size then + -- declare + -- New_Matcher : Pattern_Matcher (1..Code_Size); + -- begin + -- Compile (New_Matcher, Expr, Code_Size, Flags); + -- end; + -- end if; -- -- Expression_Error is raised if the string Expression does not contain -- a valid regular expression. diff --git a/gcc/ada/libgnat/s-retsta.ads b/gcc/ada/libgnat/s-retsta.ads new file mode 100644 index 0000000..8340341 --- /dev/null +++ b/gcc/ada/libgnat/s-retsta.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . R E T U R N _ S T A C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022, 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 small package provides direct access to the return stack of the code +-- generator for functions returning a by-reference type. This return stack +-- is the portion of the primary stack that has been allocated by callers of +-- the functions and onto which the functions put the result before returning. + +with System.Storage_Elements; + +package System.Return_Stack is + pragma Preelaborate; + + package SSE renames System.Storage_Elements; + + procedure RS_Allocate + (Addr : out Address; + Storage_Size : SSE.Storage_Count); + pragma Import (Intrinsic, RS_Allocate, "__builtin_return_slot"); + -- Allocate enough space on the return stack of the invoking task to + -- accommodate a return of size Storage_Size. Return the address of the + -- first byte of the allocation in Addr. + +private + RS_Pool : Integer; + -- Unused entity that is just present to ease the sharing of the pool + -- mechanism for specific allocation/deallocation in the compiler. + +end System.Return_Stack; diff --git a/gcc/ada/libgnat/s-rident.ads b/gcc/ada/libgnat/s-rident.ads index d3a84e3..9d652a4 100644 --- a/gcc/ada/libgnat/s-rident.ads +++ b/gcc/ada/libgnat/s-rident.ads @@ -81,7 +81,8 @@ package System.Rident is -- To add a new restriction identifier, add an entry with the name to be -- used in the pragma, and add calls to the Restrict.Check_Restriction - -- routine as appropriate. + -- routine as appropriate. If the new restriction is GNAT specific, also + -- add an entry in Restrict.Implementation_Restriction (restrict.ads). type Restriction_Id is @@ -90,7 +91,7 @@ package System.Rident is -- does not violate the restriction. (Simple_Barriers, -- Ada 2012 (D.7 (10.9/3)) - Pure_Barriers, -- GNAT + Pure_Barriers, -- Ada 2022 (D.7(10.11/5)) No_Abort_Statements, -- (RM D.7(5), H.4(3)) No_Access_Parameter_Allocators, -- Ada 2012 (RM H.4 (8.3/3)) No_Access_Subprograms, -- (RM H.4(17)) @@ -126,6 +127,7 @@ package System.Rident is No_Implicit_Task_Allocations, -- GNAT No_Implicit_Protected_Object_Allocations, -- GNAT No_Initialize_Scalars, -- GNAT + No_Local_Tagged_Types, -- GNAT No_Local_Allocators, -- (RM H.4(8)) No_Local_Timing_Events, -- (RM D.7(10.2/2)) No_Local_Protected_Objects, -- Ada 2012 (D.7(10/1.3)) @@ -150,7 +152,7 @@ package System.Rident is No_Task_Attributes_Package, -- GNAT No_Task_At_Interrupt_Priority, -- GNAT No_Task_Hierarchy, -- (RM D.7(3), H.4(3)) - No_Task_Termination, -- GNAT (Ravenscar) + No_Task_Termination, -- Ada 2005 (D.7(15.1/2)) No_Tasks_Unassigned_To_CPU, -- Ada 202x (D.7(10.10/4)) No_Tasking, -- GNAT No_Terminate_Alternatives, -- (RM D.7(6)) diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb index c2ab922..359e940 100644 --- a/gcc/ada/libgnat/s-secsta.adb +++ b/gcc/ada/libgnat/s-secsta.adb @@ -53,7 +53,7 @@ package body System.Secondary_Stack is -- in order to avoid depending on the binder. Their values are set by the -- binder. - Binder_SS_Count : Natural; + Binder_SS_Count : Natural := 0; pragma Export (Ada, Binder_SS_Count, "__gnat_binder_ss_count"); -- The number of secondary stacks in the pool created by the binder @@ -506,12 +506,17 @@ package body System.Secondary_Stack is Mem_Size : Memory_Size) return Boolean is begin + -- First check if the chunk is full (Byte is > Memory'Last in that + -- case), then check there is enough free memory. + -- Byte - 1 denotes the last occupied byte. Subtracting that byte from -- the memory capacity of the chunk yields the size of the free memory -- within the chunk. The chunk can fit the request as long as the free -- memory is as big as the request. - return Chunk.Size - (Byte - 1) >= Mem_Size; + return Chunk.Memory'Last >= Byte + and then Chunk.Size - (Byte - 1) >= Mem_Size; + end Has_Enough_Free_Memory; ---------------------- @@ -550,22 +555,52 @@ package body System.Secondary_Stack is procedure SS_Allocate (Addr : out Address; - Storage_Size : Storage_Count) + Storage_Size : Storage_Count; + Alignment : SSE.Storage_Count := Standard'Maximum_Alignment) is + function Round_Up (Size : Storage_Count) return Memory_Size; pragma Inline (Round_Up); -- Round Size up to the nearest multiple of the maximum alignment + function Align_Addr (Addr : Address) return Address; + pragma Inline (Align_Addr); + -- Align Addr to the next multiple of Alignment + + ---------------- + -- Align_Addr -- + ---------------- + + function Align_Addr (Addr : Address) return Address is + Int_Algn : constant Integer_Address := Integer_Address (Alignment); + Int_Addr : constant Integer_Address := To_Integer (Addr); + begin + + -- L : Alignment + -- A : Standard'Maximum_Alignment + + -- Addr + -- L | L L + -- A--A--A--A--A--A--A--A--A--A--A + -- | | + -- \----/ | | + -- Addr mod L | Addr + L + -- | + -- Addr + L - (Addr mod L) + + return To_Address (Int_Addr + Int_Algn - (Int_Addr mod Int_Algn)); + end Align_Addr; + -------------- -- Round_Up -- -------------- function Round_Up (Size : Storage_Count) return Memory_Size is - Algn_MS : constant Memory_Size := Memory_Alignment; + Algn_MS : constant Memory_Size := Standard'Maximum_Alignment; Size_MS : constant Memory_Size := Memory_Size (Size); begin - -- Detect a case where the Storage_Size is very large and may yield + -- Detect a case where the Size is very large and may yield -- a rounded result which is outside the range of Chunk_Memory_Size. -- Treat this case as secondary-stack depletion. @@ -581,27 +616,46 @@ package body System.Secondary_Stack is Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all; Mem_Size : Memory_Size; + Over_Aligning : constant Boolean := + Alignment > Standard'Maximum_Alignment; + + Padding : SSE.Storage_Count := 0; + -- Start of processing for SS_Allocate begin - -- Round the requested size up to the nearest multiple of the maximum - -- alignment to ensure efficient access. + -- Alignment must be a power of two and can be: - if Storage_Size = 0 then - Mem_Size := Memory_Alignment; - else - -- It should not be possible to request an allocation of negative - -- size. + -- - lower than or equal to Maximum_Alignment, in which case the result + -- will be aligned on Maximum_Alignment; + -- - higher than Maximum_Alignment, in which case the result will be + -- dynamically realigned. - pragma Assert (Storage_Size >= 0); - Mem_Size := Round_Up (Storage_Size); + if Over_Aligning then + Padding := Alignment; end if; + -- Round the requested size (plus the needed padding in case of + -- over-alignment) up to the nearest multiple of the default + -- alignment to ensure efficient access and that the next available + -- Byte is always aligned on the default alignement value. + + -- It should not be possible to request an allocation of negative + -- size. + + pragma Assert (Storage_Size >= 0); + Mem_Size := Round_Up (Storage_Size + Padding); + if Sec_Stack_Dynamic then Allocate_Dynamic (Stack, Mem_Size, Addr); else Allocate_Static (Stack, Mem_Size, Addr); end if; + + if Over_Aligning then + Addr := Align_Addr (Addr); + end if; + end SS_Allocate; ------------- diff --git a/gcc/ada/libgnat/s-secsta.ads b/gcc/ada/libgnat/s-secsta.ads index b75f1a3..9399fa3 100644 --- a/gcc/ada/libgnat/s-secsta.ads +++ b/gcc/ada/libgnat/s-secsta.ads @@ -69,11 +69,13 @@ package System.Secondary_Stack is procedure SS_Allocate (Addr : out Address; - Storage_Size : SSE.Storage_Count); + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count := Standard'Maximum_Alignment); -- Allocate enough space on the secondary stack of the invoking task to - -- accommodate an alloction of size Storage_Size. Return the address of the - -- first byte of the allocation in Addr. The routine may carry out one or - -- more of the following actions: + -- accommodate an allocation of size Storage_Size. Return the address of + -- the first byte of the allocation in Addr, which is a multiple of + -- Alignment. The routine may carry out one or more of the following + -- actions: -- -- * Reuse an existing chunk that is big enough to accommodate the -- requested Storage_Size. @@ -259,22 +261,8 @@ private subtype Memory_Index is Memory_Size; -- Index into the memory storage of a single chunk - Memory_Alignment : constant := Standard'Maximum_Alignment * 2; - -- The memory alignment we will want to honor on every allocation. - -- - -- At this stage, gigi assumes we can accommodate any alignment requirement - -- there might be on the data type for which the memory gets allocated (see - -- build_call_alloc_dealloc). - -- - -- The multiplication factor is intended to account for requirements - -- by user code compiled with specific arch/cpu options such as -mavx - -- on X86[_64] targets, which Standard'Maximum_Alignment doesn't convey - -- without such compilation options. * 4 would actually be needed to - -- support -mavx512f on X86, but this would incur more annoying memory - -- consumption overheads. - type Chunk_Memory is array (Memory_Size range <>) of SSE.Storage_Element; - for Chunk_Memory'Alignment use Memory_Alignment; + for Chunk_Memory'Alignment use Standard'Maximum_Alignment; -- The memory storage of a single chunk -------------- diff --git a/gcc/ada/libgnat/s-spark.ads b/gcc/ada/libgnat/s-spark.ads new file mode 100644 index 0000000..25a18a4 --- /dev/null +++ b/gcc/ada/libgnat/s-spark.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S P A R K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022, 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 System.SPARK with + SPARK_Mode, + Pure +is +end System.SPARK; diff --git a/gcc/ada/libgnat/s-spcuop.adb b/gcc/ada/libgnat/s-spcuop.adb new file mode 100644 index 0000000..d91f897 --- /dev/null +++ b/gcc/ada/libgnat/s-spcuop.adb @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.SPARK.Cut_Operations with + SPARK_Mode => Off +is + + function By (Consequence, Premise : Boolean) return Boolean is + (Premise and then Consequence); + + function So (Premise, Consequence : Boolean) return Boolean is + (Premise and then Consequence); + +end System.SPARK.Cut_Operations; diff --git a/gcc/ada/libgnat/s-spcuop.ads b/gcc/ada/libgnat/s-spcuop.ads new file mode 100644 index 0000000..53db0ce --- /dev/null +++ b/gcc/ada/libgnat/s-spcuop.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, 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. -- +-- -- +------------------------------------------------------------------------------ + +-- By and So are 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. They are handled in the following way: +-- +-- * 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. +-- +-- * 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. + +package System.SPARK.Cut_Operations with + SPARK_Mode, + Pure, + Annotate => (GNATprove, Always_Return) +is + + function By (Consequence, Premise : Boolean) return Boolean with + Ghost, + Global => null; + + function So (Premise, Consequence : Boolean) return Boolean with + Ghost, + Global => null; + +end System.SPARK.Cut_Operations; diff --git a/gcc/ada/libgnat/s-statxd.adb b/gcc/ada/libgnat/s-statxd.adb index e34bef1..5538613 100644 --- a/gcc/ada/libgnat/s-statxd.adb +++ b/gcc/ada/libgnat/s-statxd.adb @@ -76,36 +76,36 @@ package body System.Stream_Attributes.XDR is -- Single precision - [E_Size => 8, + (E_Size => 8, E_Bias => 127, F_Size => 23, E_Last => 2 ** 8 - 1, F_Mask => 16#7F#, -- 2 ** 7 - 1, E_Bytes => 2, F_Bytes => 3, - F_Bits => 23 mod US], + F_Bits => 23 mod US), -- Double precision - [E_Size => 11, + (E_Size => 11, E_Bias => 1023, F_Size => 52, E_Last => 2 ** 11 - 1, F_Mask => 16#0F#, -- 2 ** 4 - 1, E_Bytes => 2, F_Bytes => 7, - F_Bits => 52 mod US], + F_Bits => 52 mod US), -- Quadruple precision - [E_Size => 15, + (E_Size => 15, E_Bias => 16383, F_Size => 112, E_Last => 2 ** 8 - 1, F_Mask => 16#FF#, -- 2 ** 8 - 1, E_Bytes => 2, F_Bytes => 14, - F_Bits => 112 mod US]]; + F_Bits => 112 mod US)]; -- The representation of all items requires a multiple of four bytes -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes diff --git a/gcc/ada/libgnat/s-stausa.adb b/gcc/ada/libgnat/s-stausa.adb index 8c0acc4..d050eaa 100644 --- a/gcc/ada/libgnat/s-stausa.adb +++ b/gcc/ada/libgnat/s-stausa.adb @@ -128,9 +128,9 @@ package body System.Stack_Usage is Result_Array := new Result_Array_Type (1 .. Buffer_Size); Result_Array.all := [others => - [Task_Name => [others => ASCII.NUL], + (Task_Name => [others => ASCII.NUL], Value => 0, - Stack_Size => 0]]; + Stack_Size => 0)]; -- Set the Is_Enabled flag to true, so that the task wrapper knows that -- it has to handle dynamic stack analysis diff --git a/gcc/ada/libgnat/s-stchop.ads b/gcc/ada/libgnat/s-stchop.ads index f4d1a5b..f1f3b79 100644 --- a/gcc/ada/libgnat/s-stchop.ads +++ b/gcc/ada/libgnat/s-stchop.ads @@ -72,7 +72,7 @@ package System.Stack_Checking.Operations is private Cache : aliased Stack_Access := Null_Stack; - pragma Export (C, Cache, "_gnat_stack_cache"); - pragma Export (C, Stack_Check, "_gnat_stack_check"); + pragma Export (C, Cache, "__gnat_stack_cache"); + pragma Export (C, Stack_Check, "__gnat_stack_check"); end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stoele.ads b/gcc/ada/libgnat/s-stoele.ads index 48af71b..d047368 100644 --- a/gcc/ada/libgnat/s-stoele.ads +++ b/gcc/ada/libgnat/s-stoele.ads @@ -43,6 +43,8 @@ package System.Storage_Elements is -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada 2005, -- this is Pure in any case (AI-362). + pragma Annotate (GNATprove, Always_Return, Storage_Elements); + -- We also add the pragma Pure_Function to the operations in this package, -- because otherwise functions with parameters derived from Address are -- treated as non-pure by the back-end (see exp_ch6.adb). This is because diff --git a/gcc/ada/libgnat/s-strhas.adb b/gcc/ada/libgnat/s-strhas.adb index db860c3..19124cc 100644 --- a/gcc/ada/libgnat/s-strhas.adb +++ b/gcc/ada/libgnat/s-strhas.adb @@ -4,7 +4,7 @@ -- -- -- S Y S T E M . S T R I N G _ H A S H -- -- -- --- S p e c -- +-- B o d y -- -- -- -- Copyright (C) 2009-2022, Free Software Foundation, Inc. -- -- -- diff --git a/gcc/ada/libgnat/s-valint.ads b/gcc/ada/libgnat/s-valint.ads index 4fef265..9e47f1b 100644 --- a/gcc/ada/libgnat/s-valint.ads +++ b/gcc/ada/libgnat/s-valint.ads @@ -32,16 +32,45 @@ -- 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; -package System.Val_Int is +package System.Val_Int with SPARK_Mode is pragma Preelaborate; subtype Unsigned is Unsigned_Types.Unsigned; - package Impl is new Value_I (Integer, Unsigned, Val_Uns.Scan_Raw_Unsigned); + package Impl is new Value_I + (Int => Integer, + Uns => Unsigned, + Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned, + Uns_Option => Val_Uns.Impl.Uns_Option, + Wrap_Option => Val_Uns.Impl.Wrap_Option, + Is_Raw_Unsigned_Format_Ghost => + Val_Uns.Impl.Is_Raw_Unsigned_Format_Ghost, + Raw_Unsigned_Overflows_Ghost => + Val_Uns.Impl.Raw_Unsigned_Overflows_Ghost, + Scan_Raw_Unsigned_Ghost => + Val_Uns.Impl.Scan_Raw_Unsigned_Ghost, + Raw_Unsigned_Last_Ghost => + Val_Uns.Impl.Raw_Unsigned_Last_Ghost, + Only_Decimal_Ghost => + Val_Uns.Impl.Only_Decimal_Ghost, + Scan_Based_Number_Ghost => + Val_Uns.Impl.Scan_Based_Number_Ghost); procedure Scan_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-vallli.ads b/gcc/ada/libgnat/s-vallli.ads index ce1d9ee..5bccb1a 100644 --- a/gcc/ada/libgnat/s-vallli.ads +++ b/gcc/ada/libgnat/s-vallli.ads @@ -32,19 +32,46 @@ -- 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; -package System.Val_LLI is +package System.Val_LLI with SPARK_Mode is pragma Preelaborate; subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - package Impl is new - Value_I (Long_Long_Integer, - Long_Long_Unsigned, - Val_LLU.Scan_Raw_Long_Long_Unsigned); + package Impl is new Value_I + (Int => Long_Long_Integer, + Uns => Long_Long_Unsigned, + Scan_Raw_Unsigned => + Val_LLU.Scan_Raw_Long_Long_Unsigned, + Uns_Option => Val_LLU.Impl.Uns_Option, + Wrap_Option => Val_LLU.Impl.Wrap_Option, + Is_Raw_Unsigned_Format_Ghost => + Val_LLU.Impl.Is_Raw_Unsigned_Format_Ghost, + Raw_Unsigned_Overflows_Ghost => + Val_LLU.Impl.Raw_Unsigned_Overflows_Ghost, + Scan_Raw_Unsigned_Ghost => + Val_LLU.Impl.Scan_Raw_Unsigned_Ghost, + Raw_Unsigned_Last_Ghost => + Val_LLU.Impl.Raw_Unsigned_Last_Ghost, + Only_Decimal_Ghost => + Val_LLU.Impl.Only_Decimal_Ghost, + Scan_Based_Number_Ghost => + Val_LLU.Impl.Scan_Based_Number_Ghost); procedure Scan_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-valllli.ads b/gcc/ada/libgnat/s-valllli.ads index 176000a..586c737 100644 --- a/gcc/ada/libgnat/s-valllli.ads +++ b/gcc/ada/libgnat/s-valllli.ads @@ -32,19 +32,46 @@ -- 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; -package System.Val_LLLI is +package System.Val_LLLI with SPARK_Mode is pragma Preelaborate; subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - package Impl is new - Value_I (Long_Long_Long_Integer, - Long_Long_Long_Unsigned, - Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned); + 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, + Uns_Option => Val_LLLU.Impl.Uns_Option, + Wrap_Option => Val_LLLU.Impl.Wrap_Option, + Is_Raw_Unsigned_Format_Ghost => + Val_LLLU.Impl.Is_Raw_Unsigned_Format_Ghost, + Raw_Unsigned_Overflows_Ghost => + Val_LLLU.Impl.Raw_Unsigned_Overflows_Ghost, + Scan_Raw_Unsigned_Ghost => + Val_LLLU.Impl.Scan_Raw_Unsigned_Ghost, + Raw_Unsigned_Last_Ghost => + Val_LLLU.Impl.Raw_Unsigned_Last_Ghost, + Only_Decimal_Ghost => + Val_LLLU.Impl.Only_Decimal_Ghost, + Scan_Based_Number_Ghost => + Val_LLLU.Impl.Scan_Based_Number_Ghost); procedure Scan_Long_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-valuei.adb b/gcc/ada/libgnat/s-valuei.adb index 83828d3..b453ffc 100644 --- a/gcc/ada/libgnat/s-valuei.adb +++ b/gcc/ada/libgnat/s-valuei.adb @@ -29,10 +29,71 @@ -- -- ------------------------------------------------------------------------------ -with System.Val_Util; use System.Val_Util; - package body System.Value_I is + -- Ghost code, loop invariants and assertions in this unit are meant for + -- analysis only, not for run-time checking, as it would be too costly + -- otherwise. This is enforced by setting the assertion policy to Ignore. + + pragma Assertion_Policy (Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore, + Assert_And_Cut => Ignore, + Subprogram_Variant => Ignore); + + ----------------------------------- + -- 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 + (if Val < 0 then Non_Blank = Str'First + else + Only_Space_Ghost (Str, Str'First, 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 := + Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last); + + procedure Unique_Int_Of_Uns (Val1, Val2 : Int) + with + Pre => Uns_Is_Valid_Int (Minus, Uval) + and then Is_Int_Of_Uns (Minus, Uval, Val1) + and then Is_Int_Of_Uns (Minus, Uval, Val2), + Post => Val1 = Val2; + -- Local proof of the unicity of the signed representation + + procedure Unique_Int_Of_Uns (Val1, Val2 : Int) is null; + + -- Start of processing for Prove_Scan_Only_Decimal_Ghost + + begin + pragma Assert (Minus = (Val < 0)); + pragma Assert (Uval = Abs_Uns_Of_Int (Val)); + pragma Assert (if Minus then Uval <= Uns (Int'Last) + 1 + else Uval <= Uns (Int'Last)); + pragma Assert (Uns_Is_Valid_Int (Minus, Uval)); + pragma Assert + (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First + elsif Minus then Val = -(Int (Uval)) + else Val = Int (Uval)); + pragma Assert (Is_Int_Of_Uns (Minus, Uval, Val)); + pragma Assert + (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); + pragma Assert + (not Raw_Unsigned_Overflows_Ghost (Str, Fst_Num, Str'Last)); + pragma Assert (Only_Space_Ghost + (Str, 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)); + Unique_Int_Of_Uns (Val, Value_Integer (Str)); + end Prove_Scan_Only_Decimal_Ghost; + ------------------ -- Scan_Integer -- ------------------ @@ -46,26 +107,36 @@ package body System.Value_I is Uval : Uns; -- Unsigned result - Minus : Boolean := False; + Minus : Boolean; -- Set to True if minus sign is present, otherwise to False - Start : Positive; + 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, Start); + Scan_Sign (Str, Ptr, Max, Minus, Unused_Start); if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; + Ptr.all := Unused_Start; Bad_Value (Str); end if; Scan_Raw_Unsigned (Str, Ptr, Max, Uval); + pragma Assert (Uval = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max)); -- Deal with overflow cases, and also with largest negative number if Uval > Uns (Int'Last) then - if Minus and then Uval = Uns (-(Int'First)) then + if Minus and then Uval = Uns (Int'Last) + 1 then Res := Int'First; else Bad_Value (Str); @@ -106,9 +177,32 @@ package body System.Value_I is declare V : Int; P : aliased Integer := Str'First; + + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last) + with Ghost; + + Fst_Num : constant Positive := + (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 + else Non_Blank) + with Ghost; begin - Scan_Integer (Str, P'Access, Str'Last, V); + pragma Assert + (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); + + declare + P_Acc : constant not null access Integer := P'Access; + begin + Scan_Integer (Str, P_Acc, Str'Last, V); + end; + + pragma Assert + (P = Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last)); + Scan_Trailing_Blanks (Str, P); + + pragma Assert + (Is_Value_Integer_Ghost (Slide_If_Necessary (Str), V)); return V; end; end if; diff --git a/gcc/ada/libgnat/s-valuei.ads b/gcc/ada/libgnat/s-valuei.ads index e0a34d9..5e42773 100644 --- a/gcc/ada/libgnat/s-valuei.ads +++ b/gcc/ada/libgnat/s-valuei.ads @@ -32,6 +32,14 @@ -- 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_Util; use System.Val_Util; + generic type Int is range <>; @@ -44,14 +52,112 @@ generic Max : Integer; Res : out Uns); + -- Additional parameters for ghost subprograms used inside contracts + + type Uns_Option is private; + with function Wrap_Option (Value : Uns) return Uns_Option + with Ghost; + with function Is_Raw_Unsigned_Format_Ghost (Str : String) return Boolean + with Ghost; + with function Raw_Unsigned_Overflows_Ghost + (Str : String; + From, To : Integer) + return Boolean + with Ghost; + with function Scan_Raw_Unsigned_Ghost + (Str : String; + From, To : Integer) + return Uns + with Ghost; + with function Raw_Unsigned_Last_Ghost + (Str : String; + From, To : Integer) + return Positive + with Ghost; + with function Only_Decimal_Ghost + (Str : String; + From, To : Integer) + return Boolean + with Ghost; + with function Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + return Uns_Option + with Ghost; + package System.Value_I is pragma Preelaborate; + 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 Ghost, + 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 + Ghost, + 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)) + with Ghost; + -- Return the unsigned absolute value of Val + procedure Scan_Integer (Str : String; Ptr : not null access Integer; Max : Integer; - Res : out Int); + 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 + Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max)) + and then not Raw_Unsigned_Overflows_Ghost (Str, Fst_Num, Max) + and then Uns_Is_Valid_Int + (Minus => Str (Non_Blank) = '-', + Uval => 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 := + Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max); + begin + Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', + Uval => Uval, + Val => Res) + and then Ptr.all = Raw_Unsigned_Last_Ghost (Str, Fst_Num, Max)); -- 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 @@ -77,10 +183,111 @@ package System.Value_I is -- special case of an all-blank string, and Ptr is unchanged, and hence -- is greater than Max as required in this case. - function Value_Integer (Str : String) return Int; + function Slide_To_1 (Str : String) return String + with + Ghost, + 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) + with + Ghost, + Post => + Only_Space_Ghost (Str, Str'First, Str'Last) = + Only_Space_Ghost (Slide_If_Necessary'Result, + Slide_If_Necessary'Result'First, + Slide_If_Necessary'Result'Last); + -- 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 + Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) + and then not Raw_Unsigned_Overflows_Ghost (Str, Fst_Num, Str'Last) + and then + Uns_Is_Valid_Int + (Minus => Str (Non_Blank) = '-', + Uval => Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)) + and then Only_Space_Ghost + (Str, Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last), Str'Last)) + with + Ghost, + 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 := + Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last); + begin + Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', + Uval => Uval, + Val => Val)) + with + Ghost, + 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. + + 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 Is_Integer_Ghost (Slide_If_Necessary (Str)), + Post => Is_Value_Integer_Ghost + (Slide_If_Necessary (Str), Value_Integer'Result), + Subprogram_Variant => (Decreases => Str'First); -- 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 -- malformed, or if the value is out of range. + 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 Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) + and then Scan_Based_Number_Ghost (Str, Str'First + 1, Str'Last) + = Wrap_Option (Abs_Uns_Of_Int (Val)), + Post => Is_Integer_Ghost (Slide_If_Necessary (Str)) + and then Value_Integer (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; diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb index 4b4e887..b474f84 100644 --- a/gcc/ada/libgnat/s-valuer.adb +++ b/gcc/ada/libgnat/s-valuer.adb @@ -645,7 +645,14 @@ package body System.Value_R is Ptr.all := Index; Scan_Exponent (Str, Ptr, Max, Expon, Real => True); - Scale := Scale + Expon; + + -- Handle very large exponents like Scan_Exponent + + if Expon < Integer'First / 10 or else Expon > Integer'Last / 10 then + Scale := Expon; + else + Scale := Scale + Expon; + end if; -- Here is where we check for a bad based number diff --git a/gcc/ada/libgnat/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb index 991d4a5..f5a6881 100644 --- a/gcc/ada/libgnat/s-valueu.adb +++ b/gcc/ada/libgnat/s-valueu.adb @@ -234,6 +234,77 @@ package body System.Value_U is end if; end Lemma_Scan_Digit; + ---------------------------------------- + -- Prove_Iter_Scan_Based_Number_Ghost -- + ---------------------------------------- + + procedure Prove_Iter_Scan_Based_Number_Ghost + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is + begin + if From > To then + null; + elsif Str1 (From) = '_' then + Prove_Iter_Scan_Based_Number_Ghost + (Str1, Str2, From + 1, To, Base, Acc); + elsif Scan_Overflows_Ghost + (Hexa_To_Unsigned_Ghost (Str1 (From)), Base, Acc) + then + null; + else + Prove_Iter_Scan_Based_Number_Ghost + (Str1, Str2, From + 1, To, Base, + Base * Acc + Hexa_To_Unsigned_Ghost (Str1 (From))); + end if; + end Prove_Iter_Scan_Based_Number_Ghost; + + ----------------------------------- + -- Prove_Scan_Only_Decimal_Ghost -- + ----------------------------------- + + procedure Prove_Scan_Only_Decimal_Ghost + (Str : String; + Val : Uns) + is + 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); + Last_Num_Init : constant Integer := + Last_Number_Ghost (Str (Str'First + 1 .. Str'Last)); + pragma Assert (Last_Num_Init = Str'Last); + Starts_As_Based : constant Boolean := + Last_Num_Init < Str'Last - 1 + and then Str (Last_Num_Init + 1) in '#' | ':' + and then Str (Last_Num_Init + 2) in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; + pragma Assert (Starts_As_Based = False); + Last_Num_Based : constant Integer := + (if Starts_As_Based + then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) + else Last_Num_Init); + pragma Assert (Last_Num_Based = Str'Last); + begin + pragma Assert + (Is_Opt_Exponent_Format_Ghost (Str (Str'Last + 1 .. Str'Last))); + pragma Assert + (Is_Natural_Format_Ghost (Str (Str'First + 1 .. Str'Last))); + pragma Assert + (Is_Raw_Unsigned_Format_Ghost (Str (Str'First + 1 .. Str'Last))); + pragma Assert + (not Raw_Unsigned_Overflows_Ghost (Str, Str'First + 1, Str'Last)); + pragma Assert (Val = Exponent_Unsigned_Ghost (Val, 0, 10).Value); + pragma Assert + (Val = Scan_Raw_Unsigned_Ghost (Str, Str'First + 1, Str'Last)); + pragma Assert (Is_Unsigned_Ghost (Str)); + pragma Assert (Is_Value_Unsigned_Ghost (Str, Val)); + end Prove_Scan_Only_Decimal_Ghost; + ----------------------- -- Scan_Raw_Unsigned -- ----------------------- @@ -451,6 +522,9 @@ package body System.Value_U is Uval := Base; Base := 10; pragma Assert (Ptr.all = Last_Num_Init + 1); + pragma Assert + (if Starts_As_Based then P = Last_Num_Based + 1); + pragma Assert (not Is_Based); pragma Assert (if not Overflow then Uval = Init_Val.Value); exit; end if; @@ -498,10 +572,6 @@ package body System.Value_U is end if; end if; - Lemma_Scan_Digit - (Str, P, Last_Num_Based, Digit, Base, Old_Uval, Uval, - Based_Val, Old_Overflow, Overflow); - -- If at end of string with no base char, not a based number -- but we signal Constraint_Error and set the pointer past -- the end of the field, since this is what the ACVC tests @@ -509,6 +579,10 @@ package body System.Value_U is P := P + 1; + Lemma_Scan_Digit + (Str, P - 1, Last_Num_Based, Digit, Base, Old_Uval, Uval, + Based_Val, Old_Overflow, Overflow); + if P > Max then Ptr.all := P; Bad_Value (Str); @@ -519,6 +593,11 @@ package body System.Value_U is if Str (P) = Base_Char then Ptr.all := P + 1; pragma Assert (Ptr.all = Last_Num_Based + 2); + pragma Assert (Is_Based); + pragma Assert + (if not Overflow then + Based_Val = Scan_Based_Number_Ghost + (Str, P, Last_Num_Based, Base, Uval)); Lemma_End_Of_Scan (Str, P, Last_Num_Based, Base, Uval); pragma Assert (if not Overflow then Uval = Based_Val.Value); exit; @@ -570,6 +649,7 @@ package body System.Value_U is Scan_Exponent (Str, Ptr, Max, Expon); + pragma Assert (Ptr.all = Raw_Unsigned_Last_Ghost (Str, Ptr_Old, Max)); pragma Assert (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. Max)) then Expon = Scan_Exponent_Ghost (Str (First_Exp .. Max))); diff --git a/gcc/ada/libgnat/s-valueu.ads b/gcc/ada/libgnat/s-valueu.ads index b0e3b1e..1508b6e 100644 --- a/gcc/ada/libgnat/s-valueu.ads +++ b/gcc/ada/libgnat/s-valueu.ads @@ -43,8 +43,6 @@ pragma Assertion_Policy (Pre => Ignore, Contract_Cases => Ignore, Ghost => Ignore, Subprogram_Variant => Ignore); -pragma Warnings (Off, "postcondition does not mention function result"); --- True postconditions are used to avoid inlining for GNATprove with System.Val_Util; use System.Val_Util; @@ -62,7 +60,24 @@ package System.Value_U is when False => Value : Uns := 0; end case; - end record with Ghost; + end record; + + function Wrap_Option (Value : Uns) return Uns_Option is + (Overflow => False, Value => Value) + with + Ghost; + + function Only_Decimal_Ghost + (Str : String; + From, To : Integer) + return Boolean + is + (for all J in From .. To => Str (J) in '0' .. '9') + with + Ghost, + 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 @@ -535,6 +550,46 @@ package System.Value_U is -- is the string argument of the attribute. Constraint_Error is raised if -- the string is malformed, or if the value is out of range. + procedure Prove_Iter_Scan_Based_Number_Ghost + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Ghost, + 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); + -- Ghost lemma used in the proof of 'Image implementation, to prove the + -- preservation of Scan_Based_Number_Ghost across an update in the string + -- in lower indexes. + + procedure Prove_Scan_Only_Decimal_Ghost + (Str : String; + Val : Uns) + with + Ghost, + 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 Value_Unsigned (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. + private ----------------------------- diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads index 5c0f2a5..2b89b12 100644 --- a/gcc/ada/libgnat/s-valuti.ads +++ b/gcc/ada/libgnat/s-valuti.ads @@ -41,8 +41,6 @@ pragma Assertion_Policy (Pre => Ignore, Post => Ignore, Contract_Cases => Ignore, Ghost => Ignore); -pragma Warnings (Off, "postcondition does not mention function result"); --- True postconditions are used to avoid inlining for GNATprove with System.Case_Util; @@ -376,6 +374,50 @@ is -- no check for this case, the caller must ensure this condition is met. pragma Warnings (GNATprove, On, """Ptr"" is not modified"); + -- Bundle Int 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. + generic + type Int is range <>; + type Uns is mod <>; + type Uns_Option is private; + + Unsigned_Width_Ghost : Natural; + + with function Wrap_Option (Value : Uns) return Uns_Option + with Ghost; + with function Only_Decimal_Ghost + (Str : String; + From, To : Integer) + return Boolean + with Ghost; + with function Hexa_To_Unsigned_Ghost (X : Character) return Uns + with Ghost; + with function Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + return Uns_Option + with Ghost; + with function Is_Integer_Ghost (Str : String) return Boolean + with Ghost; + with procedure Prove_Iter_Scan_Based_Number_Ghost + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with Ghost; + with procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) + with Ghost; + with function Abs_Uns_Of_Int (Val : Int) return Uns + with Ghost; + with function Value_Integer (Str : String) return Int + with Ghost; + + package Int_Params is + end Int_Params; + private ------------------------ diff --git a/gcc/ada/libgnat/s-widlllu.ads b/gcc/ada/libgnat/s-widlllu.ads index 802c74a..e9b6f9b 100644 --- a/gcc/ada/libgnat/s-widlllu.ads +++ b/gcc/ada/libgnat/s-widlllu.ads @@ -50,8 +50,11 @@ package System.Wid_LLLU is subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - function Width_Long_Long_Long_Unsigned is - new Width_U (Long_Long_Long_Unsigned); - pragma Pure_Function (Width_Long_Long_Long_Unsigned); + package Width_Uns is new Width_U (Long_Long_Long_Unsigned); + + function Width_Long_Long_Long_Unsigned + (Lo, Hi : Long_Long_Long_Unsigned) + return Natural + renames Width_Uns.Width; end System.Wid_LLLU; diff --git a/gcc/ada/libgnat/s-widllu.ads b/gcc/ada/libgnat/s-widllu.ads index eafb04f..7276d02 100644 --- a/gcc/ada/libgnat/s-widllu.ads +++ b/gcc/ada/libgnat/s-widllu.ads @@ -50,7 +50,11 @@ package System.Wid_LLU is subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - function Width_Long_Long_Unsigned is new Width_U (Long_Long_Unsigned); - pragma Pure_Function (Width_Long_Long_Unsigned); + package Width_Uns is new Width_U (Long_Long_Unsigned); + + function Width_Long_Long_Unsigned + (Lo, Hi : Long_Long_Unsigned) + return Natural + renames Width_Uns.Width; end System.Wid_LLU; diff --git a/gcc/ada/libgnat/s-widthu.adb b/gcc/ada/libgnat/s-widthu.adb index e23ecef..390942c 100644 --- a/gcc/ada/libgnat/s-widthu.adb +++ b/gcc/ada/libgnat/s-widthu.adb @@ -29,157 +29,138 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Numerics.Big_Numbers.Big_Integers_Ghost; -use Ada.Numerics.Big_Numbers.Big_Integers_Ghost; - -function System.Width_U (Lo, Hi : Uns) return Natural is +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); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - package Unsigned_Conversion is new Unsigned_Conversions (Int => Uns); - - function Big (Arg : Uns) return Big_Integer renames - Unsigned_Conversion.To_Big_Integer; - - -- 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; - - ------------------ - -- 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); - - ---------------------- - -- 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; - - -- Local variables - - W : Natural; - T : Uns; - - -- 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 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 - - W := 2; - - -- Get max of absolute values + 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); + + ---------------------- + -- 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; - T := Uns'Max (Lo, Hi); + -- Local variables - -- Increase value if more digits required + W : Natural; + T : Uns; - while T >= 10 loop - Lemma_Div_Commutation (T, 10); - Lemma_Div_Twice (Big (T_Init), Big_10 ** (W - 2), Big_10); + -- Local ghost variables - T := T / 10; - W := W + 1; - Pow := Pow * 10; + Max_W : constant Natural := Max_Log10 with Ghost; + Pow : Big_Integer := 1 with Ghost; + T_Init : constant Uns := Uns'Max (Lo, Hi) with Ghost; - 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; + -- Start of processing for System.Width_U - 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); - 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_U, - -- which cannot be expressed readily as a postcondition as this would - -- require making the instantiation Unsigned_Conversion and function - -- Big available from the spec. - - pragma Assert (Big (Lo) < Big_10 ** (W - 1)); - pragma Assert (Big (Hi) < Big_10 ** (W - 1)); - - return W; - end if; + begin + if Lo > Hi then + return 0; + + else + -- Minimum value is 2, one for space, one for digit + + W := 2; + + -- Get max of absolute values + + T := Uns'Max (Lo, Hi); + + -- 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); + 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; + + return W; + end if; + end Width; end System.Width_U; diff --git a/gcc/ada/libgnat/s-widthu.ads b/gcc/ada/libgnat/s-widthu.ads index 7611e8d..b6ae541 100644 --- a/gcc/ada/libgnat/s-widthu.ads +++ b/gcc/ada/libgnat/s-widthu.ads @@ -29,16 +29,65 @@ -- -- ------------------------------------------------------------------------------ +-- 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 <>; -function System.Width_U (Lo, Hi : Uns) return Natural -with - Post => (if Lo > Hi then - System.Width_U'Result = 0 - else - System.Width_U'Result > 0); +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))); + +end System.Width_U; diff --git a/gcc/ada/libgnat/s-widuns.ads b/gcc/ada/libgnat/s-widuns.ads index 19d3261..137b881 100644 --- a/gcc/ada/libgnat/s-widuns.ads +++ b/gcc/ada/libgnat/s-widuns.ads @@ -50,7 +50,9 @@ package System.Wid_Uns is subtype Unsigned is Unsigned_Types.Unsigned; - function Width_Unsigned is new Width_U (Unsigned); - pragma Pure_Function (Width_Unsigned); + package Width_Uns is new Width_U (Unsigned); + + function Width_Unsigned (Lo, Hi : Unsigned) return Natural + renames Width_Uns.Width; end System.Wid_Uns; diff --git a/gcc/ada/libgnat/system-aix.ads b/gcc/ada/libgnat/system-aix.ads index c016361..57756d4 100644 --- a/gcc/ada/libgnat/system-aix.ads +++ b/gcc/ada/libgnat/system-aix.ads @@ -150,7 +150,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-darwin-arm.ads b/gcc/ada/libgnat/system-darwin-arm.ads index be5d664..7390f3a 100644 --- a/gcc/ada/libgnat/system-darwin-arm.ads +++ b/gcc/ada/libgnat/system-darwin-arm.ads @@ -166,7 +166,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-darwin-ppc.ads b/gcc/ada/libgnat/system-darwin-ppc.ads index dc3d6c4..984d5a2 100644 --- a/gcc/ada/libgnat/system-darwin-ppc.ads +++ b/gcc/ada/libgnat/system-darwin-ppc.ads @@ -166,7 +166,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-darwin-x86.ads b/gcc/ada/libgnat/system-darwin-x86.ads index 378fa9b..8d8e5f0 100644 --- a/gcc/ada/libgnat/system-darwin-x86.ads +++ b/gcc/ada/libgnat/system-darwin-x86.ads @@ -166,7 +166,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-djgpp.ads b/gcc/ada/libgnat/system-djgpp.ads index 31a5351..1148a46 100644 --- a/gcc/ada/libgnat/system-djgpp.ads +++ b/gcc/ada/libgnat/system-djgpp.ads @@ -140,7 +140,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-dragonfly-x86_64.ads b/gcc/ada/libgnat/system-dragonfly-x86_64.ads index 37726fe..90abfe9 100644 --- a/gcc/ada/libgnat/system-dragonfly-x86_64.ads +++ b/gcc/ada/libgnat/system-dragonfly-x86_64.ads @@ -140,7 +140,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-freebsd.ads b/gcc/ada/libgnat/system-freebsd.ads index 3604280..fcc0c4f 100644 --- a/gcc/ada/libgnat/system-freebsd.ads +++ b/gcc/ada/libgnat/system-freebsd.ads @@ -141,7 +141,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-hpux-ia64.ads b/gcc/ada/libgnat/system-hpux-ia64.ads index 4268ff5..0562bf7 100644 --- a/gcc/ada/libgnat/system-hpux-ia64.ads +++ b/gcc/ada/libgnat/system-hpux-ia64.ads @@ -140,7 +140,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-hpux.ads b/gcc/ada/libgnat/system-hpux.ads index a412645..a8848d6 100644 --- a/gcc/ada/libgnat/system-hpux.ads +++ b/gcc/ada/libgnat/system-hpux.ads @@ -139,7 +139,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; -------------------------- diff --git a/gcc/ada/libgnat/system-linux-alpha.ads b/gcc/ada/libgnat/system-linux-alpha.ads index b6f1550..56d708d 100644 --- a/gcc/ada/libgnat/system-linux-alpha.ads +++ b/gcc/ada/libgnat/system-linux-alpha.ads @@ -140,7 +140,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-linux-arm.ads b/gcc/ada/libgnat/system-linux-arm.ads index 10fc281..996d407 100644 --- a/gcc/ada/libgnat/system-linux-arm.ads +++ b/gcc/ada/libgnat/system-linux-arm.ads @@ -70,7 +70,7 @@ package System is Storage_Unit : constant := 8; Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Long_Integer'Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -149,7 +149,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-linux-hppa.ads b/gcc/ada/libgnat/system-linux-hppa.ads index 9a40009..d4b8364 100644 --- a/gcc/ada/libgnat/system-linux-hppa.ads +++ b/gcc/ada/libgnat/system-linux-hppa.ads @@ -139,7 +139,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-linux-ia64.ads b/gcc/ada/libgnat/system-linux-ia64.ads index 85e9c9e..0ebc233 100644 --- a/gcc/ada/libgnat/system-linux-ia64.ads +++ b/gcc/ada/libgnat/system-linux-ia64.ads @@ -148,7 +148,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-linux-m68k.ads b/gcc/ada/libgnat/system-linux-m68k.ads index 83ac5ea..2189465 100644 --- a/gcc/ada/libgnat/system-linux-m68k.ads +++ b/gcc/ada/libgnat/system-linux-m68k.ads @@ -150,7 +150,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-linux-mips.ads b/gcc/ada/libgnat/system-linux-mips.ads index 5013883..d3bafb2 100644 --- a/gcc/ada/libgnat/system-linux-mips.ads +++ b/gcc/ada/libgnat/system-linux-mips.ads @@ -140,7 +140,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-linux-ppc.ads b/gcc/ada/libgnat/system-linux-ppc.ads index 84cf532..0b8aad9 100644 --- a/gcc/ada/libgnat/system-linux-ppc.ads +++ b/gcc/ada/libgnat/system-linux-ppc.ads @@ -148,7 +148,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-linux-riscv.ads b/gcc/ada/libgnat/system-linux-riscv.ads index 56f4d09..c656604 100644 --- a/gcc/ada/libgnat/system-linux-riscv.ads +++ b/gcc/ada/libgnat/system-linux-riscv.ads @@ -139,7 +139,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-linux-s390.ads b/gcc/ada/libgnat/system-linux-s390.ads index 24803e2..ee1e87a 100644 --- a/gcc/ada/libgnat/system-linux-s390.ads +++ b/gcc/ada/libgnat/system-linux-s390.ads @@ -139,7 +139,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-linux-sh4.ads b/gcc/ada/libgnat/system-linux-sh4.ads index 5cee747..c4fb6ed 100644 --- a/gcc/ada/libgnat/system-linux-sh4.ads +++ b/gcc/ada/libgnat/system-linux-sh4.ads @@ -147,7 +147,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-linux-sparc.ads b/gcc/ada/libgnat/system-linux-sparc.ads index db46b74..cc502da 100644 --- a/gcc/ada/libgnat/system-linux-sparc.ads +++ b/gcc/ada/libgnat/system-linux-sparc.ads @@ -139,7 +139,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-linux-x86.ads b/gcc/ada/libgnat/system-linux-x86.ads index 87eb903..9336207 100644 --- a/gcc/ada/libgnat/system-linux-x86.ads +++ b/gcc/ada/libgnat/system-linux-x86.ads @@ -148,7 +148,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-lynxos178-ppc.ads b/gcc/ada/libgnat/system-lynxos178-ppc.ads index ebf8132..2a693c5 100644 --- a/gcc/ada/libgnat/system-lynxos178-ppc.ads +++ b/gcc/ada/libgnat/system-lynxos178-ppc.ads @@ -154,7 +154,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := False; end System; diff --git a/gcc/ada/libgnat/system-lynxos178-x86.ads b/gcc/ada/libgnat/system-lynxos178-x86.ads index 302a2f3..2f13aae 100644 --- a/gcc/ada/libgnat/system-lynxos178-x86.ads +++ b/gcc/ada/libgnat/system-lynxos178-x86.ads @@ -154,7 +154,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := False; end System; diff --git a/gcc/ada/libgnat/system-mingw.ads b/gcc/ada/libgnat/system-mingw.ads index 77fb6f0..a2eaf6a 100644 --- a/gcc/ada/libgnat/system-mingw.ads +++ b/gcc/ada/libgnat/system-mingw.ads @@ -140,7 +140,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; --------------------------- diff --git a/gcc/ada/libgnat/system-qnx-aarch64.ads b/gcc/ada/libgnat/system-qnx-arm.ads index 827f9df..749384f 100644 --- a/gcc/ada/libgnat/system-qnx-aarch64.ads +++ b/gcc/ada/libgnat/system-qnx-arm.ads @@ -5,7 +5,7 @@ -- S Y S T E M -- -- -- -- S p e c -- --- (QNX/Aarch64 Version) -- +-- (QNX-ARM/AARCH64 Version) -- -- -- -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- -- -- @@ -70,7 +70,7 @@ package System is Storage_Unit : constant := 8; Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Long_Integer'Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -149,7 +149,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-rtems.ads b/gcc/ada/libgnat/system-rtems.ads index 06f7831..5959b72 100644 --- a/gcc/ada/libgnat/system-rtems.ads +++ b/gcc/ada/libgnat/system-rtems.ads @@ -156,7 +156,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-solaris-sparc.ads b/gcc/ada/libgnat/system-solaris-sparc.ads index 2ba5198..c15a517 100644 --- a/gcc/ada/libgnat/system-solaris-sparc.ads +++ b/gcc/ada/libgnat/system-solaris-sparc.ads @@ -140,7 +140,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-solaris-x86.ads b/gcc/ada/libgnat/system-solaris-x86.ads index 7872523..981e7ca 100644 --- a/gcc/ada/libgnat/system-solaris-x86.ads +++ b/gcc/ada/libgnat/system-solaris-x86.ads @@ -140,7 +140,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; end System; diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads deleted file mode 100644 index 4273245..0000000 --- a/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads +++ /dev/null @@ -1,166 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 6.x ARM RTP) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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. -- --- -- --- In particular, you can freely distribute your programs built with the -- --- GNAT Pro compiler, including any required library run-time units, using -- --- any licensing terms of your choosing. See the AdaCore Software License -- --- for full details. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VxWorks version of this package for RTPs - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-smp-arm-link.spec"); - pragma Linker_Options ("--specs=vxworks-arm-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp.ads deleted file mode 100644 index 214e3d5..0000000 --- a/gcc/ada/libgnat/system-vxworks-arm-rtp.ads +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 6.x ARM RTP) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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. -- --- -- --- In particular, you can freely distribute your programs built with the -- --- GNAT Pro compiler, including any required library run-time units, using -- --- any licensing terms of your choosing. See the AdaCore Software License -- --- for full details. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VxWorks version of this package for RTPs - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-arm-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-arm.ads b/gcc/ada/libgnat/system-vxworks-arm.ads deleted file mode 100644 index be391d0..0000000 --- a/gcc/ada/libgnat/system-vxworks-arm.ads +++ /dev/null @@ -1,160 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks Version ARM) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := False; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-e500-kernel.ads b/gcc/ada/libgnat/system-vxworks-e500-kernel.ads deleted file mode 100644 index 9ee828b..0000000 --- a/gcc/ada/libgnat/system-vxworks-e500-kernel.ads +++ /dev/null @@ -1,161 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 6 Kernel Version E500) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := False; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - -- MPC8548ECE Chip Errata Rev 8: signed zero not reliable - Signed_Zeros : constant Boolean := False; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads deleted file mode 100644 index d7ab0a9..0000000 --- a/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads +++ /dev/null @@ -1,167 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 6.x SMP E500 RTP) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 VxWorks SMP version of this package for RTPs - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-smp-e500-link.spec"); - pragma Linker_Options ("--specs=vxworks-e500-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - -- MPC8548ECE Chip Errata Rev 8: signed zero not reliable - Signed_Zeros : constant Boolean := False; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp.ads deleted file mode 100644 index e304d50..0000000 --- a/gcc/ada/libgnat/system-vxworks-e500-rtp.ads +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 6.x E500 RTP) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 VxWorks version of this package for RTPs - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-e500-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads index 6cf9b3f..640150a 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads @@ -69,8 +69,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -152,7 +152,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".out"; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads index 07da01d..0855721 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads @@ -71,8 +71,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -158,7 +158,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".vxe"; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads index b6807b3..f72177f 100644 --- a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads +++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads @@ -71,8 +71,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -157,7 +157,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".vxe"; diff --git a/gcc/ada/libgnat/system-vxworks-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks-x86-kernel.ads deleted file mode 100644 index c8cbf52..0000000 --- a/gcc/ada/libgnat/system-vxworks-x86-kernel.ads +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 6 Kernel Version x86) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-x86-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := False; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads deleted file mode 100644 index d70642e..0000000 --- a/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks Version x86 for SMP RTPs) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-smp-x86-link.spec"); - pragma Linker_Options ("--specs=vxworks-x86-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp.ads deleted file mode 100644 index 262445d..0000000 --- a/gcc/ada/libgnat/system-vxworks-x86-rtp.ads +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks Version x86 for RTPs) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-x86-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads index a739441..46b740e 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads @@ -71,8 +71,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 64; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -151,13 +151,13 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".vxe"; diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64.ads b/gcc/ada/libgnat/system-vxworks7-aarch64.ads index 840682b..1aba15b 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64.ads @@ -71,8 +71,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 64; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -148,13 +148,13 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".out"; diff --git a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads index c82f8fc..e81348e 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads @@ -71,8 +71,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -148,13 +148,13 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".vxe"; diff --git a/gcc/ada/libgnat/system-vxworks7-arm.ads b/gcc/ada/libgnat/system-vxworks7-arm.ads index be391d0..4ced0f1 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm.ads @@ -69,8 +69,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -146,13 +146,13 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".out"; diff --git a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads b/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads deleted file mode 100644 index bb72157..0000000 --- a/gcc/ada/libgnat/system-vxworks7-e500-kernel.ads +++ /dev/null @@ -1,161 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 7 Kernel Version E500) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := False; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - -- MPC8548ECE Chip Errata Rev 8: signed zero not reliable - Signed_Zeros : constant Boolean := False; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads deleted file mode 100644 index d4b4dce..0000000 --- a/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads +++ /dev/null @@ -1,166 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 7.x E500 RTP) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 VxWorks version of this package for RTPs - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks7-rtp-base-link.spec"); - -- Define the symbol wrs_rtp_base - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - -- MPC8548ECE Chip Errata Rev 8: signed zero not reliable - Signed_Zeros : constant Boolean := False; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads b/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads deleted file mode 100644 index 7f7f817..0000000 --- a/gcc/ada/libgnat/system-vxworks7-e500-rtp.ads +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 7.x E500 RTP) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 VxWorks version of this package for RTPs - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-e500-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads index 2b83609..bddf951 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc-kernel.ads @@ -69,8 +69,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -152,7 +152,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".out"; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads index f232b34..3ead193 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads @@ -71,8 +71,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -157,7 +157,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".vxe"; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads deleted file mode 100644 index 1c59deb..0000000 --- a/gcc/ada/libgnat/system-vxworks7-ppc-rtp.ads +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 7.x PPC RTP) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 VxWorks version of this package for RTPs - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-ppc-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads index 942c4b1..a1a983b 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc64-kernel.ads @@ -71,8 +71,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 64; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -154,7 +154,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".out"; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads index 42aeb34..afdd820 100644 --- a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads @@ -71,8 +71,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 64; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -157,7 +157,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".vxe"; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads index f84d8f0..42ae983 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads @@ -69,8 +69,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -153,7 +153,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".out"; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads index 26e35ab..47dd3ae 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads @@ -69,8 +69,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -156,7 +156,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".vxe"; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads deleted file mode 100644 index 9eb643c..0000000 --- a/gcc/ada/libgnat/system-vxworks7-x86-rtp.ads +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 7 Version x86 for RTPs) -- --- -- --- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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 System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := -2 ** (Standard'Max_Integer_Size - 1); - Max_Int : constant := 2 ** (Standard'Max_Integer_Size - 1) - 1; - - Max_Binary_Modulus : constant := 2 ** Standard'Max_Integer_Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := Standard'Max_Integer_Size - 1; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 1.0 / 60.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 256 is reserved for the VxWorks kernel - -- 248 - 255 correspond to hardware interrupt levels 0 .. 7 - -- 247 is a catchall default "interrupt" priority for signals, - -- allowing higher priority than normal tasks, but lower than - -- hardware priority levels. Protected Object ceilings can - -- override these values. - -- 246 is used by the Interrupt_Manager task - - Max_Priority : constant Positive := 245; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 245; - subtype Interrupt_Priority is Any_Priority range 246 .. 255; - - Default_Priority : constant Priority := 122; - -private - - pragma Linker_Options ("--specs=vxworks-x86-link.spec"); - -- Setup proper set of -L's for this configuration - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".vxe"; - -end System; diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads index 6cdd59e..7931241 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads @@ -69,8 +69,8 @@ package System is Null_Address : constant Address; Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 64; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; -- Address comparison @@ -153,7 +153,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".out"; diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads index 47a91e6..3c98b4c 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads @@ -156,7 +156,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; Executable_Extension : constant String := ".vxe"; |