diff options
| author | Ian Lance Taylor <iant@golang.org> | 2022-09-22 06:29:20 -0700 |
|---|---|---|
| committer | Ian Lance Taylor <iant@golang.org> | 2022-09-22 06:29:20 -0700 |
| commit | 795cffe109e28b248a54b8ee583cbae48368c2a7 (patch) | |
| tree | 0c12b075c51c0d5097f26953835ae540d9f2f501 /gcc/ada/libgnat | |
| parent | 9f62ed218fa656607740b386c0caa03e65dcd283 (diff) | |
| parent | f35be1268c996d993ab0b4ff329734d467474445 (diff) | |
| download | gcc-795cffe109e28b248a54b8ee583cbae48368c2a7.zip gcc-795cffe109e28b248a54b8ee583cbae48368c2a7.tar.gz gcc-795cffe109e28b248a54b8ee583cbae48368c2a7.tar.bz2 | |
Merge from trunk revision f35be1268c996d993ab0b4ff329734d467474445.
Diffstat (limited to 'gcc/ada/libgnat')
84 files changed, 2809 insertions, 27933 deletions
diff --git a/gcc/ada/libgnat/a-cfdlli.adb b/gcc/ada/libgnat/a-cfdlli.adb deleted file mode 100644 index bbb8fd4..0000000 --- a/gcc/ada/libgnat/a-cfdlli.adb +++ /dev/null @@ -1,1905 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-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/>. -- ------------------------------------------------------------------------------- - -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 -- - ----------------------- - - procedure Allocate - (Container : in out List; - New_Item : Element_Type; - 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; - - --------- - -- "=" -- - --------- - - 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 /= Right.Nodes (RI).Element then - return False; - end if; - - LI := Left.Nodes (LI).Next; - RI := Right.Nodes (RI).Next; - end loop; - - return True; - end "="; - - -------------- - -- Allocate -- - -------------- - - procedure Allocate - (Container : in out List; - New_Item : Element_Type; - New_Node : out Count_Type) - is - N : Node_Array renames Container.Nodes; - - begin - if Container.Free >= 0 then - New_Node := Container.Free; - N (New_Node).Element := New_Item; - Container.Free := N (New_Node).Next; - - else - New_Node := abs Container.Free; - N (New_Node).Element := New_Item; - Container.Free := Container.Free - 1; - end if; - 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 renames Source.Nodes; - J : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - J := Source.First; - while J /= 0 loop - Append (Target, N (J).Element, 1); - J := N (J).Next; - end loop; - end Assign; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out List) is - N : Node_Array 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 : aliased 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'Access; - 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; - Capacity : Count_Type := 0) return List - is - C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity); - N : Count_Type; - P : List (C); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - N := 1; - while N <= Source.Capacity loop - P.Nodes (N).Prev := Source.Nodes (N).Prev; - P.Nodes (N).Next := Source.Nodes (N).Next; - P.Nodes (N).Element := Source.Nodes (N).Element; - N := N + 1; - end loop; - - P.Free := Source.Free; - P.Length := Source.Length; - P.First := Source.First; - P.Last := Source.Last; - - if P.Free >= 0 then - N := Source.Capacity + 1; - while N <= C loop - Free (P, N); - N := N + 1; - end loop; - end if; - - 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 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 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 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; - end Element; - - ---------- - -- 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 = 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; - 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); - 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.Capacity); - - N : Node_Array renames Container.Nodes; - - begin - N (X).Prev := -1; -- Node is deallocated (not on active list) - - 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; - - if Container.Free > Container.Capacity then - Container.Free := 0; - - else - for J in Container.Free .. Container.Capacity - 1 loop - N (J).Next := J + 1; - end loop; - - N (Container.Capacity).Next := 0; - end if; - - 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 renames Container.Nodes; - Node : Count_Type := Container.First; - - begin - for J in 2 .. Container.Length loop - if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element 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 renames Target.Nodes; - RN : Node_Array 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 < - RN (RI.Node).Element)); - - 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 < - LN (LI.Node).Element)); - - if RN (RI.Node).Element < LN (LI.Node).Element 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 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 < N (R).Element); - 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; - - if Container.Length > Container.Capacity - Count then - raise Constraint_Error with "new length exceeds capacity"; - 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 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; - 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 renames Source.Nodes; - X : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - while Source.Length > 1 loop - pragma Assert (Source.First in 1 .. Source.Capacity); - pragma Assert (Source.Last /= Source.First); - pragma Assert (N (Source.First).Prev = 0); - pragma Assert (N (Source.Last).Next = 0); - - -- Copy first element from Source to Target - - X := Source.First; - Append (Target, N (X).Element); -- optimize away??? - - -- Unlink first node of Source - - Source.First := N (X).Next; - N (Source.First).Prev := 0; - - Source.Length := Source.Length - 1; - - -- The representation invariants for Source have been restored. It is - -- now safe to free the unlinked node, without fear of corrupting the - -- active links of Source. - - -- Note that the algorithm we use here models similar algorithms used - -- in the unbounded form of the doubly-linked list container. In that - -- case, Free is an instantation of Unchecked_Deallocation, which can - -- fail (because PE will be raised if controlled Finalize fails), so - -- we must defer the call until the last step. Here in the bounded - -- form, Free merely links the node we have just "deallocated" onto a - -- list of inactive nodes, so technically Free cannot fail. However, - -- for consistency, we handle Free the same way here as we do for the - -- unbounded form, with the pessimistic assumption that it can fail. - - Free (Source, X); - end loop; - - if Source.Length = 1 then - pragma Assert (Source.First in 1 .. Source.Capacity); - pragma Assert (Source.Last = Source.First); - pragma Assert (N (Source.First).Prev = 0); - pragma Assert (N (Source.Last).Next = 0); - - -- Copy element from Source to Target - - X := Source.First; - Append (Target, N (X).Element); - - -- Unlink node of Source - - Source.First := 0; - Source.Last := 0; - Source.Length := 0; - - -- Return the unlinked node to the free store - - Free (Source, X); - end if; - 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'Access; - 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"); - - Container.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out List) is - N : Node_Array 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 = 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 renames Source.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; - - pragma Assert (SN (Source.First).Prev = 0); - pragma Assert (SN (Source.Last).Next = 0); - - if Target.Length > Count_Type'Base'Last - Source.Length then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - if Target.Length + Source.Length > Target.Capacity then - raise Constraint_Error; - end if; - - loop - Insert (Target, Before, SN (Source.Last).Element); - Delete_Last (Source); - exit when Is_Empty (Source); - end loop; - end Splice; - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor) - is - Target_Position : Cursor; - - 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"); - - if Target.Length >= Target.Capacity then - raise Constraint_Error; - end if; - - Insert - (Container => Target, - Before => Before, - New_Item => Source.Nodes (Position.Node).Element, - Position => Target_Position); - - Delete (Source, Position); - Position := Target_Position; - end Splice; - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor) - is - N : Node_Array 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 renames Container.Nodes; - NI : Node_Type renames NN (I.Node); - NJ : Node_Type renames NN (J.Node); - - EI_Copy : constant Element_Type := 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 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.Capacity then - return False; - end if; - - if N (Position.Node).Prev < 0 - or else N (Position.Node).Prev > L.Capacity - then - return False; - end if; - - if N (Position.Node).Next > L.Capacity 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_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads index 01e7db2..3a53ca5 100644 --- a/gcc/ada/libgnat/a-cfdlli.ads +++ b/gcc/ada/libgnat/a-cfdlli.ads @@ -29,1643 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -with Ada.Containers.Functional_Vectors; -with Ada.Containers.Functional_Maps; - generic - type Element_Type is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Formal_Doubly_Linked_Lists with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -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 (Capacity : Count_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Element), - Default_Initial_Condition => Is_Empty (List); - pragma Preelaborable_Initialization (List); - - type Cursor is record - Node : Count_Type := 0; - end record; - - No_Element : constant Cursor := Cursor'(Node => 0); - - Empty_List : constant List; - - function Length (Container : List) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - 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, - Pre => Target.Capacity >= Length (Source), - Post => Model (Target) = Model (Source); - - function Copy (Source : List; Capacity : Count_Type := 0) return List with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - - 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 : aliased 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, - Pre => Target.Capacity >= Length (Source), - 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) < Container.Capacity - 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) <= Container.Capacity - 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) < Container.Capacity - 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) <= Container.Capacity - 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) < Container.Capacity, - 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) <= Container.Capacity - 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) < Container.Capacity, - 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) <= Container.Capacity - 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) <= Target.Capacity - 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) < Target.Capacity, - 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 (Source) <= Target.Capacity - Length (Target), - 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); - - type Node_Type is record - Prev : Count_Type'Base := -1; - Next : Count_Type; - Element : aliased Element_Type; - end record; - - 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 List (Capacity : Count_Type) is record - Free : Count_Type'Base := -1; - Length : Count_Type := 0; - First : Count_Type := 0; - Last : Count_Type := 0; - Nodes : Node_Array (1 .. Capacity); - end record; +package Ada.Containers.Formal_Doubly_Linked_Lists with SPARK_Mode is - Empty_List : constant List := (0, others => <>); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfhama.adb b/gcc/ada/libgnat/a-cfhama.adb deleted file mode 100644 index bdf2c61..0000000 --- a/gcc/ada/libgnat/a-cfhama.adb +++ /dev/null @@ -1,976 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Hash_Tables.Generic_Formal_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations); - -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 - SPARK_Mode => Off -is - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All local subprograms require comments ??? - - function Equivalent_Keys - (Key : Key_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Keys); - - procedure Free - (HT : in out Map; - X : Count_Type); - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (HT : in out HT_Types.Hash_Table_Type; - Node : out Count_Type); - - function Hash_Node (Node : Node_Type) return Hash_Type; - pragma Inline (Hash_Node); - - function Next (Node : Node_Type) return Count_Type; - pragma Inline (Next); - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type); - pragma Inline (Set_Next); - - 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_Formal_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next); - - package Key_Ops is - new Hash_Tables.Generic_Formal_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Keys); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Map) return Boolean is - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Length (Left) = 0 then - return True; - end if; - - declare - Node : Count_Type; - ENode : Count_Type; - - begin - Node := First (Left).Node; - while Node /= 0 loop - ENode := - Find - (Container => Right, - Key => Left.Content.Nodes (Node).Key).Node; - - if ENode = 0 or else - Right.Content.Nodes (ENode).Element /= - Left.Content.Nodes (Node).Element - then - return False; - end if; - - Node := HT_Ops.Next (Left.Content, Node); - end loop; - - return True; - end; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Insert_Element (Source_Node : Count_Type); - pragma Inline (Insert_Element); - - procedure Insert_Elements is - new HT_Ops.Generic_Iteration (Insert_Element); - - -------------------- - -- Insert_Element -- - -------------------- - - procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.Content.Nodes (Source_Node); - begin - Insert (Target, N.Key, N.Element); - end Insert_Element; - - -- Start of processing for Assign - - begin - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- correct exception ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - Insert_Elements (Source.Content); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Map) return Count_Type is - begin - return Container.Content.Nodes'Length; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Map) is - begin - HT_Ops.Clear (Container.Content); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return not null access constant 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 function Constant_Reference"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return not null access constant Element_Type - is - Node : constant Count_Type := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Content.Nodes (Node).Element'Access; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Map; - Capacity : Count_Type := 0) return Map - is - C : constant Count_Type := - Count_Type'Max (Capacity, Source.Capacity); - Cu : Cursor; - H : Hash_Type; - N : Count_Type; - Target : Map (C, Source.Modulus); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - Target.Content.Length := Source.Content.Length; - Target.Content.Free := Source.Content.Free; - - H := 1; - while H <= Source.Modulus loop - Target.Content.Buckets (H) := Source.Content.Buckets (H); - H := H + 1; - end loop; - - N := 1; - while N <= Source.Capacity loop - Target.Content.Nodes (N) := Source.Content.Nodes (N); - N := N + 1; - end loop; - - while N <= C loop - Cu := (Node => N); - Free (Target, Cu.Node); - N := N + 1; - end loop; - - return Target; - end Copy; - - --------------------- - -- Default_Modulus -- - --------------------- - - function Default_Modulus (Capacity : Count_Type) return Hash_Type is - begin - return To_Prime (Capacity); - end Default_Modulus; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : Count_Type; - - begin - Key_Ops.Delete_Key_Sans_Free (Container.Content, Key, X); - - if X = 0 then - raise Constraint_Error with "attempt to delete key not in map"; - end if; - - Free (Container, X); - end Delete; - - procedure Delete (Container : in out Map; Position : in out Cursor) is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Delete has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container.Content, Position.Node); - - Free (Container, Position.Node); - Position := No_Element; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Count_Type := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Content.Nodes (Node).Element; - end Element; - - function Element (Container : Map; Position : Cursor) return Element_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in function Element"); - - return Container.Content.Nodes (Position.Node).Element; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys - (Key : Key_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Keys (Key, Node.Key); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : Count_Type; - begin - Key_Ops.Delete_Key_Sans_Free (Container.Content, Key, X); - Free (Container, X); - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Find (Container.Content, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - Node : constant Count_Type := HT_Ops.First (Container.Content); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end First; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ---------- - -- Find -- - ---------- - - function Find - (Container : K.Sequence; - Key : Key_Type) return Count_Type - is - begin - for I in 1 .. K.Length (Container) loop - if Equivalent_Keys (Key, K.Get (Container, I)) then - return I; - end if; - end loop; - return 0; - end Find; - - --------------------- - -- K_Keys_Included -- - --------------------- - - function K_Keys_Included - (Left : K.Sequence; - Right : K.Sequence) return Boolean - is - begin - for I in 1 .. K.Length (Left) loop - if not K.Contains (Right, 1, K.Length (Right), K.Get (Left, I)) - then - return False; - end if; - end loop; - - return True; - end K_Keys_Included; - - ---------- - -- Keys -- - ---------- - - function Keys (Container : Map) return K.Sequence is - Position : Count_Type := HT_Ops.First (Container.Content); - R : K.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := K.Add (R, Container.Content.Nodes (Position).Key); - Position := HT_Ops.Next (Container.Content, Position); - end loop; - - return R; - end Keys; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Map) is null; - - ----------------------- - -- Mapping_Preserved -- - ----------------------- - - function Mapping_Preserved - (K_Left : K.Sequence; - K_Right : K.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) > K.Length (K_Left) - or else P.Get (P_Right, C) > K.Length (K_Right) - or else K.Get (K_Left, P.Get (P_Left, C)) /= - K.Get (K_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ----------- - -- Model -- - ----------- - - function Model (Container : Map) return M.Map is - Position : Count_Type := HT_Ops.First (Container.Content); - R : M.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - New_Key => Container.Content.Nodes (Position).Key, - New_Item => Container.Content.Nodes (Position).Element); - - Position := HT_Ops.Next (Container.Content, Position); - end loop; - - return R; - end Model; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Map) return P.Map is - I : Count_Type := 1; - Position : Count_Type := HT_Ops.First (Container.Content); - 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) = Big (I)); - Position := HT_Ops.Next (Container.Content, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (HT : in out Map; X : Count_Type) is - begin - if X /= 0 then - pragma Assert (X <= HT.Capacity); - HT.Content.Nodes (X).Has_Element := False; - HT_Ops.Free (HT.Content, X); - end if; - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - 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, Node); - HT.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Map; Position : Cursor) return Boolean is - begin - if Position.Node = 0 - or else not Container.Content.Nodes (Position.Node).Has_Element - then - return False; - else - return True; - end if; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Type) return Hash_Type is - begin - return Hash (Node.Key); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - declare - P : constant Count_Type := Position.Node; - N : Node_Type renames Container.Content.Nodes (P); - begin - N.Key := Key; - N.Element := New_Item; - end; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - procedure Assign_Key (Node : in out Node_Type); - pragma Inline (Assign_Key); - - procedure New_Node - (HT : in out HT_Types.Hash_Table_Type; - Node : out Count_Type); - pragma Inline (New_Node); - - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new Generic_Allocate (Assign_Key); - - ----------------- - -- Assign_Key -- - ----------------- - - procedure Assign_Key (Node : in out Node_Type) is - begin - Node.Key := Key; - Node.Element := New_Item; - end Assign_Key; - - -------------- - -- New_Node -- - -------------- - - procedure New_Node - (HT : in out HT_Types.Hash_Table_Type; - Node : out Count_Type) - is - begin - Allocate (HT, Node); - end New_Node; - - -- Start of processing for Insert - - begin - Local_Insert (Container.Content, Key, Position.Node, Inserted); - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Unused_Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Unused_Position, Inserted); - - if not Inserted then - raise Constraint_Error with "attempt to insert key already in map"; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - --------- - -- Key -- - --------- - - function Key (Container : Map; Position : Cursor) return Key_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of function Key has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in function Key"); - - return Container.Content.Nodes (Position.Node).Key; - end Key; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.Content.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out Map; - Source : in out Map) - is - NN : HT_Types.Nodes_Type renames Source.Content.Nodes; - X : Count_Type; - Y : Count_Type; - - begin - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - if Source.Content.Length = 0 then - return; - end if; - - X := HT_Ops.First (Source.Content); - while X /= 0 loop - Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? - - Y := HT_Ops.Next (Source.Content, X); - - HT_Ops.Delete_Node_Sans_Free (Source.Content, X); - Free (Source, X); - - X := Y; - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Type) return Count_Type is - begin - return Node.Next; - end Next; - - function Next (Container : Map; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in function Next"); - - declare - Node : constant Count_Type := - HT_Ops.Next (Container.Content, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - end Next; - - procedure Next (Container : Map; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : not null access Map; - 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; - - pragma Assert - (Vet (Container.all, Position), "bad cursor in function Reference"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Reference; - - function Reference - (Container : not null access Map; - Key : Key_Type) return not null access Element_Type - is - Node : constant Count_Type := Find (Container.all, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Content.Nodes (Node).Element'Access; - end Reference; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Ops.Find (Container.Content, Key); - - begin - if Node = 0 then - raise Constraint_Error with "attempt to replace key not in map"; - end if; - - declare - N : Node_Type renames Container.Content.Nodes (Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Replace_Element has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in Replace_Element"); - - Container.Content.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type) - is - begin - if Capacity > Container.Capacity then - raise Capacity_Error with "requested capacity is too large"; - end if; - end Reserve_Capacity; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is - begin - Node.Next := Next; - end Set_Next; - - --------- - -- Vet -- - --------- - - 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; - - declare - X : Count_Type; - - begin - if Container.Content.Length = 0 then - return False; - end if; - - if Container.Capacity = 0 then - return False; - end if; - - if Container.Content.Buckets'Length = 0 then - return False; - end if; - - if Position.Node > Container.Capacity then - return False; - end if; - - if Container.Content.Nodes (Position.Node).Next = Position.Node then - return False; - end if; - - X := - Container.Content.Buckets - (Key_Ops.Index - (Container.Content, - Container.Content.Nodes (Position.Node).Key)); - - for J in 1 .. Container.Content.Length loop - if X = Position.Node then - return True; - end if; - - if X = 0 then - return False; - end if; - - if X = Container.Content.Nodes (X).Next then - - -- Prevent unnecessary looping - - return False; - end if; - - X := Container.Content.Nodes (X).Next; - end loop; - - return False; - end; - end Vet; - -end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads index 8cb7488..42c7fbd 100644 --- a/gcc/ada/libgnat/a-cfhama.ads +++ b/gcc/ada/libgnat/a-cfhama.ads @@ -29,885 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- This spec is derived from package Ada.Containers.Bounded_Hashed_Maps in the --- Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- contents of a container: Key, Element, Next, Query_Element, Has_Element, --- Iterate, Equivalent_Keys. This change is motivated by the need to have --- cursors which are valid on different containers (typically a container C --- and its previous version C'Old) for expressing properties, which is not --- possible if cursors encapsulate an access to the underlying container. - --- Iteration over maps is done using the Iterable aspect, which is SPARK --- compatible. "For of" iteration ranges over keys instead of elements. - -with Ada.Containers.Functional_Vectors; -with Ada.Containers.Functional_Maps; -private with Ada.Containers.Hash_Tables; - generic - type Key_Type is private; - type Element_Type is private; - - with function Hash (Key : Key_Type) return Hash_Type; - with function Equivalent_Keys - (Left : Key_Type; - Right : Key_Type) return Boolean is "="; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Formal_Hashed_Maps with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -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 Map (Capacity : Count_Type; Modulus : Hash_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Key), - Default_Initial_Condition => Is_Empty (Map); - pragma Preelaborable_Initialization (Map); - - Empty_Map : constant Map; - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - function Length (Container : Map) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - 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_Maps - (Element_Type => Element_Type, - Key_Type => Key_Type, - Equivalent_Keys => Equivalent_Keys); - - function "=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."="; - - function "<=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."<="; - - package K is new Ada.Containers.Functional_Vectors - (Element_Type => Key_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."="; - - function "<" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<"; - - function "<=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<="; - - function Find (Container : K.Sequence; Key : Key_Type) return Count_Type - -- Search for Key in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= K.Length (Container) - and Equivalent_Keys (Key, K.Get (Container, Find'Result))); - - function K_Keys_Included - (Left : K.Sequence; - Right : K.Sequence) return Boolean - -- Return True if Right contains all the keys of Left - - with - Global => null, - Post => - K_Keys_Included'Result = - (for all I in 1 .. K.Length (Left) => - Find (Right, K.Get (Left, I)) > 0 - and then K.Get (Right, Find (Right, K.Get (Left, I))) = - K.Get (Left, I)); - - 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 Mapping_Preserved - (K_Left : K.Sequence; - K_Right : K.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Right contains all the keys of Left - - and K_Keys_Included (K_Left, K_Right) - - -- Mappings from cursors to elements induced by K_Left, P_Left - -- and K_Right, P_Right are the same. - - and (for all C of P_Left => - K.Get (K_Left, P.Get (P_Left, C)) = - K.Get (K_Right, P.Get (P_Right, C)))); - - function Model (Container : Map) return M.Map with - -- The high-level model of a map is a map from keys to elements. Neither - -- cursors nor order of elements are represented in this model. Keys are - -- modeled up to equivalence. - - Ghost, - Global => null; - - function Keys (Container : Map) return K.Sequence with - -- The Keys sequence represents the underlying list structure of maps - -- that is used for iteration. It stores the actual values of keys in - -- the map. It does not model cursors nor elements. - - Ghost, - Global => null, - Post => - K.Length (Keys'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Key of Keys'Result => - M.Has_Key (Model (Container), Key)) - - -- It contains all the keys contained in Model - - and (for all Key of Model (Container) => - (Find (Keys'Result, Key) > 0 - and then Equivalent_Keys - (K.Get (Keys'Result, Find (Keys'Result, Key)), - Key))) - - -- It has no duplicate - - and (for all I in 1 .. Length (Container) => - Find (Keys'Result, K.Get (Keys'Result, I)) = I) - - and (for all I in 1 .. Length (Container) => - (for all J in 1 .. Length (Container) => - (if Equivalent_Keys - (K.Get (Keys'Result, I), K.Get (Keys'Result, J)) - then - I = J))); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys); - - function Positions (Container : Map) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps 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 : Map) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access 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 Key of Keys (Container) => - (for some I of Positions (Container) => - K.Get (Keys (Container), P.Get (Positions (Container), I)) = - Key)); - - function Contains - (C : M.Map; - K : Key_Type) return Boolean renames M.Has_Key; - -- To improve readability of contracts, we rename the function used to - -- search for a key in the model to Contains. - - function Element - (C : M.Map; - K : Key_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 : Map) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function Capacity (Container : Map) return Count_Type with - Global => null, - Post => Capacity'Result = Container.Capacity; - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type) - with - Global => null, - Pre => Capacity <= Container.Capacity, - Post => - Model (Container) = Model (Container)'Old - and Length (Container)'Old = Length (Container) - - -- Actual keys are preserved - - and K_Keys_Included (Keys (Container), Keys (Container)'Old) - and K_Keys_Included (Keys (Container)'Old, Keys (Container)); - - function Is_Empty (Container : Map) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Map) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - - procedure Assign (Target : in out Map; Source : Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Length (Source) = Length (Target) - - -- Actual keys are preserved - - and K_Keys_Included (Keys (Target), Keys (Source)) - and K_Keys_Included (Keys (Source), Keys (Target)); - - function Copy - (Source : Map; - Capacity : Count_Type := 0) return Map - with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Keys (Copy'Result) = Keys (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - -- Copy returns a container stricty equal to Source. It must have the same - -- cursors associated with each element. Therefore: - -- - capacity=0 means use Source.Capacity as capacity of target - -- - the modulus cannot be changed. - - function Key (Container : Map; Position : Cursor) return Key_Type with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Key'Result = - K.Get (Keys (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element - (Container : Map; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = Element (Model (Container), Key (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - - -- Order of keys and cursors is preserved - - Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old - - -- New_Item is now associated with the key at position Position in - -- Container. - - and Element (Container, Position) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key (Container, Position)); - - function At_End - (E : not null access constant Map) return not null access constant Map - 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 : aliased Map; - 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), Key (Container, Position)); - - function Reference - (Container : not null access Map; - Position : Cursor) return not null access Element_Type - with - Global => null, - Pre => Has_Element (Container.all, Position), - Post => - - -- Order of keys and cursors is preserved - - Keys (At_End (Container).all) = Keys (Container.all) - and Positions (At_End (Container).all) = Positions (Container.all) - - -- The value designated by the result of Reference is now associated - -- with the key at position Position in Container. - - and Element (At_End (Container).all, Position) = - At_End (Reference'Result).all - - -- Elements associated with other keys are preserved - - and M.Same_Keys - (Model (At_End (Container).all), - Model (Container.all)) - and M.Elements_Equal_Except - (Model (At_End (Container).all), - Model (Container.all), - Key (At_End (Container).all, Position)); - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return not null access constant Element_Type - with - Global => null, - Pre => Contains (Container, Key), - Post => - Constant_Reference'Result.all = Element (Model (Container), Key); - - function Reference - (Container : not null access Map; - Key : Key_Type) return not null access Element_Type - with - Global => null, - Pre => Contains (Container.all, Key), - Post => - - -- Order of keys and cursors is preserved - - Keys (At_End (Container).all) = Keys (Container.all) - and Positions (At_End (Container).all) = Positions (Container.all) - - -- The value designated by the result of Reference is now associated - -- with Key in Container. - - and Element (Model (At_End (Container).all), Key) = - At_End (Reference'Result).all - - -- Elements associated with other keys are preserved - - and M.Same_Keys - (Model (At_End (Container).all), - Model (Container.all)) - and M.Elements_Equal_Except - (Model (At_End (Container).all), - Model (Container.all), - Key); - - procedure Move (Target : in out Map; Source : in out Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source)'Old - and Length (Source)'Old = Length (Target) - and Length (Source) = 0 - - -- Actual keys are preserved - - and K_Keys_Included (Keys (Target), Keys (Source)'Old) - and K_Keys_Included (Keys (Source)'Old, Keys (Target)); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) - and Has_Element (Container, Position) - and Equivalent_Keys - (Formal_Hashed_Maps.Key (Container, Position), Key), - Contract_Cases => - - -- If Key is already in Container, it is not modified and Inserted is - -- set to False. - - (Contains (Container, Key) => - not Inserted - and Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is inserted in Container and Inserted is set to True - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Key now maps to New_Item - - and Formal_Hashed_Maps.Key (Container, Position) = Key - and Element (Model (Container), Key) = New_Item - - -- Other keys are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container)'Old, - K_Right => Keys (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Position)); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (not Contains (Container, Key)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, Key) - - -- Key now maps to New_Item - - and Formal_Hashed_Maps.Key (Container, Find (Container, Key)) = Key - and Element (Model (Container), Key) = New_Item - - -- Other keys are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container)'Old, - K_Right => Keys (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, Key)); - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) and Element (Container, Key) = New_Item, - Contract_Cases => - - -- If Key is already in Container, Key is mapped to New_Item - - (Contains (Container, Key) => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get - (Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) = Key - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key), - - -- Otherwise, Key is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other keys are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Key is inserted in Container - - and K.Get - (Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) = Key - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container)'Old, - K_Right => Keys (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, Key))); - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get - (Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) = Key - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) - - -- New_Item is now associated with the Key in Container - - and Element (Model (Container), Key) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key); - - procedure Exclude (Container : in out Map; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other keys are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container), - K_Right => Keys (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old)); - - procedure Delete (Container : in out Map; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other keys are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container), - K_Right => Keys (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old); - - procedure Delete (Container : in out Map; Position : in out Cursor) with - Global => null, - Depends => (Container =>+ Position, Position => null), - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The key at position Position is no longer in Container - - and not Contains (Container, Key (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other keys are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key (Container, Position)'Old) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container), - K_Right => Keys (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Position'Old); - - function First (Container : Map) 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 Next (Container : Map; 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 : Map; 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 Find (Container : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Key) => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Keys (Container), Key) - - -- The key designated by the result of Find is Key - - and Equivalent_Keys - (Formal_Hashed_Maps.Key (Container, Find'Result), Key)); - - function Contains (Container : Map; Key : Key_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Element (Container : Map; Key : Key_Type) return Element_Type with - Global => null, - Pre => Contains (Container, Key), - Post => Element'Result = Element (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - function Has_Element (Container : Map; 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); - - function Default_Modulus (Capacity : Count_Type) return Hash_Type with - Global => null; - -private - pragma SPARK_Mode (Off); - - pragma Inline (Length); - pragma Inline (Is_Empty); - pragma Inline (Clear); - pragma Inline (Key); - pragma Inline (Element); - pragma Inline (Contains); - pragma Inline (Capacity); - pragma Inline (Has_Element); - pragma Inline (Equivalent_Keys); - pragma Inline (Next); - - type Node_Type is record - Key : Key_Type; - Element : aliased Element_Type; - Next : Count_Type; - Has_Element : Boolean := False; - end record; - - package HT_Types is new - 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); - end record; +package Ada.Containers.Formal_Hashed_Maps with SPARK_Mode is - Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cfhase.adb b/gcc/ada/libgnat/a-cfhase.adb deleted file mode 100644 index 34afa55..0000000 --- a/gcc/ada/libgnat/a-cfhase.adb +++ /dev/null @@ -1,1559 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Hash_Tables.Generic_Formal_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations); - -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 System; use type System.Address; - -package body Ada.Containers.Formal_Hashed_Sets with - SPARK_Mode => Off -is - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All need comments ??? - - procedure Difference (Left : Set; Right : Set; Target : in out Set); - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Keys); - - procedure Free - (HT : in out Set; - X : Count_Type); - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (HT : in out Hash_Table_Type; - Node : out Count_Type); - - function Hash_Node (Node : Node_Type) return Hash_Type; - pragma Inline (Hash_Node); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean); - - procedure Intersection - (Left : Set; - Right : Set; - Target : in out Set); - - function Is_In - (HT : Set; - Key : Node_Type) return Boolean; - pragma Inline (Is_In); - - procedure Set_Element (Node : in out Node_Type; Item : Element_Type); - pragma Inline (Set_Element); - - function Next (Node : Node_Type) return Count_Type; - pragma Inline (Next); - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type); - pragma Inline (Set_Next); - - function Vet (Container : Set; Position : Cursor) return Boolean - with Inline; - - -------------------------- - -- Local Instantiations -- - -------------------------- - - 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_Formal_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Element_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Keys); - - procedure Replace_Element is - new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Length (Left) = 0 then - return True; - end if; - - declare - Node : Count_Type; - ENode : Count_Type; - - begin - Node := First (Left).Node; - while Node /= 0 loop - ENode := - Find - (Container => Right, - Item => Left.Content.Nodes (Node).Element).Node; - - if ENode = 0 - or else Right.Content.Nodes (ENode).Element /= - Left.Content.Nodes (Node).Element - then - return False; - end if; - - Node := HT_Ops.Next (Left.Content, Node); - end loop; - - return True; - end; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Set; Source : Set) is - procedure Insert_Element (Source_Node : Count_Type); - - procedure Insert_Elements is - new HT_Ops.Generic_Iteration (Insert_Element); - - -------------------- - -- Insert_Element -- - -------------------- - - procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.Content.Nodes (Source_Node); - Unused_X : Count_Type; - B : Boolean; - - begin - Insert (Target, N.Element, Unused_X, B); - pragma Assert (B); - end Insert_Element; - - -- Start of processing for Assign - - begin - if Target.Capacity < Length (Source) then - raise Storage_Error with "not enough capacity"; -- SE or CE? ??? - end if; - - HT_Ops.Clear (Target.Content); - Insert_Elements (Source.Content); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Set) return Count_Type is - begin - return Container.Content.Nodes'Length; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Set) is - begin - HT_Ops.Clear (Container.Content); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return not null access constant Element_Type - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in function Element"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Set; - Capacity : Count_Type := 0) return Set - is - C : constant Count_Type := - Count_Type'Max (Capacity, Source.Capacity); - Cu : Cursor; - H : Hash_Type; - N : Count_Type; - Target : Set (C, Source.Modulus); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - Target.Content.Length := Source.Content.Length; - Target.Content.Free := Source.Content.Free; - - H := 1; - while H <= Source.Modulus loop - Target.Content.Buckets (H) := Source.Content.Buckets (H); - H := H + 1; - end loop; - - N := 1; - while N <= Source.Capacity loop - Target.Content.Nodes (N) := Source.Content.Nodes (N); - N := N + 1; - end loop; - - while N <= C loop - Cu := (Node => N); - Free (Target, Cu.Node); - N := N + 1; - end loop; - - return Target; - end Copy; - - --------------------- - -- Default_Modulus -- - --------------------- - - function Default_Modulus (Capacity : Count_Type) return Hash_Type is - begin - return To_Prime (Capacity); - end Default_Modulus; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Item : Element_Type) is - X : Count_Type; - - begin - Element_Keys.Delete_Key_Sans_Free (Container.Content, Item, X); - - if X = 0 then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - Free (Container, X); - end Delete; - - procedure Delete (Container : in out Set; Position : in out Cursor) 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 Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container.Content, Position.Node); - Free (Container, Position.Node); - - Position := No_Element; - end Delete; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Set; Source : Set) is - Src_Last : Count_Type; - Src_Length : Count_Type; - Src_Node : Count_Type; - Tgt_Node : Count_Type; - - TN : Nodes_Type renames Target.Content.Nodes; - SN : Nodes_Type renames Source.Content.Nodes; - - begin - Src_Length := Source.Content.Length; - - if Src_Length = 0 then - return; - end if; - - if Src_Length >= Target.Content.Length then - Tgt_Node := HT_Ops.First (Target.Content); - while Tgt_Node /= 0 loop - if Element_Keys.Find (Source.Content, TN (Tgt_Node).Element) /= 0 - then - declare - X : constant Count_Type := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target.Content, X); - Free (Target, X); - end; - - else - Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node); - end if; - end loop; - - return; - else - Src_Node := HT_Ops.First (Source.Content); - Src_Last := 0; - end if; - - while Src_Node /= Src_Last loop - Tgt_Node := Element_Keys.Find (Target.Content, SN (Src_Node).Element); - - if Tgt_Node /= 0 then - HT_Ops.Delete_Node_Sans_Free (Target.Content, Tgt_Node); - Free (Target, Tgt_Node); - end if; - - Src_Node := HT_Ops.Next (Source.Content, Src_Node); - end loop; - end Difference; - - procedure Difference (Left : Set; Right : Set; Target : in out Set) is - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - 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, Unused_X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Difference - - begin - Iterate (Left.Content); - end Difference; - - function Difference (Left : Set; Right : Set) return Set is - begin - if Length (Left) = 0 then - return Empty_Set; - end if; - - if Length (Right) = 0 then - return Copy (Left); - end if; - - 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; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Set; - Position : Cursor) return Element_Type - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in function Element"); - - return Container.Content.Nodes (Position.Node).Element; - end Element; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Type) return Boolean; - pragma Inline (Find_Equivalent_Key); - - function Is_Equivalent is - new HT_Ops.Generic_Equal (Find_Equivalent_Key); - - ------------------------- - -- Find_Equivalent_Key -- - ------------------------- - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Type) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element); - R_Node : Count_Type := R_HT.Buckets (R_Index); - RN : Nodes_Type renames R_HT.Nodes; - - begin - loop - if R_Node = 0 then - return False; - end if; - - if Equivalent_Elements - (L_Node.Element, RN (R_Node).Element) - then - return True; - end if; - - R_Node := HT_Ops.Next (R_HT, R_Node); - end loop; - end Find_Equivalent_Key; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left.Content, Right.Content); - end Equivalent_Sets; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Elements (Key, Node.Element); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Item : Element_Type) is - X : Count_Type; - begin - Element_Keys.Delete_Key_Sans_Free (Container.Content, Item, X); - Free (Container, X); - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Item : Element_Type) return Cursor - is - Node : constant Count_Type := - Element_Keys.Find (Container.Content, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - Node : constant Count_Type := HT_Ops.First (Container.Content); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end First; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- E_Elements_Included -- - ------------------------- - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I)) - then - return False; - end if; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - declare - Item : constant Element_Type := E.Get (Left, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Container) loop - declare - Item : constant Element_Type := E.Get (Container, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Left, 1, E.Length (Left), Item) then - return False; - end if; - else - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - ---------- - -- Find -- - ---------- - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - is - begin - for I in 1 .. E.Length (Container) loop - if Equivalent_Elements (Item, E.Get (Container, I)) then - return I; - end if; - end loop; - return 0; - end Find; - - -------------- - -- Elements -- - -------------- - - function Elements (Container : Set) return E.Sequence is - Position : Count_Type := HT_Ops.First (Container.Content); - R : E.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := E.Add (R, Container.Content.Nodes (Position).Element); - Position := HT_Ops.Next (Container.Content, Position); - end loop; - - return R; - end Elements; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Set) is null; - - ----------------------- - -- Mapping_Preserved -- - ----------------------- - - function Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.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) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ------------------------------ - -- Mapping_Preserved_Except -- - ------------------------------ - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - is - begin - for C of P_Left loop - if C /= Position - and (not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C))) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved_Except; - - ----------- - -- Model -- - ----------- - - function Model (Container : Set) return M.Set is - Position : Count_Type := HT_Ops.First (Container.Content); - R : M.Set; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - Item => Container.Content.Nodes (Position).Element); - - Position := HT_Ops.Next (Container.Content, Position); - end loop; - - return R; - end Model; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Set) return P.Map is - I : Count_Type := 1; - Position : Count_Type := HT_Ops.First (Container.Content); - 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) = Big (I)); - Position := HT_Ops.Next (Container.Content, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (HT : in out Set; X : Count_Type) is - begin - if X /= 0 then - pragma Assert (X <= HT.Capacity); - HT.Content.Nodes (X).Has_Element := False; - HT_Ops.Free (HT.Content, X); - end if; - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - 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, Node); - HT.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - package body Generic_Keys with SPARK_Mode => Off is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is new Hash_Tables.Generic_Formal_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Key_Node); - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Key : Key_Type) return Boolean - is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Key : Key_Type) is - X : Count_Type; - - begin - Key_Keys.Delete_Key_Sans_Free (Container.Content, Key, X); - - if X = 0 then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - Free (Container, X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Set; - Key : Key_Type) return Element_Type - is - Node : constant Count_Type := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - return Container.Content.Nodes (Node).Element; - end Element; - - ------------------------- - -- Equivalent_Key_Node -- - ------------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); - end Equivalent_Key_Node; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Key : Key_Type) is - X : Count_Type; - begin - Key_Keys.Delete_Key_Sans_Free (Container.Content, Key, X); - Free (Container, X); - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Key : Key_Type) return Cursor - is - Node : constant Count_Type := Key_Keys.Find (Container.Content, Key); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end Find; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ----------------------- - -- M_Included_Except -- - ----------------------- - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - is - begin - for E of Left loop - if not Contains (Right, E) - and not Equivalent_Keys (Generic_Keys.Key (E), Key) - then - return False; - end if; - end loop; - - return True; - end M_Included_Except; - - end Formal_Model; - - --------- - -- Key -- - --------- - - function Key (Container : Set; Position : Cursor) return Key_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 function Key"); - - declare - N : Node_Type renames Container.Content.Nodes (Position.Node); - begin - return Key (N.Element); - end; - end Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Keys.Find (Container.Content, Key); - - begin - if Node = 0 then - raise Constraint_Error with "attempt to replace key not in set"; - end if; - - Replace_Element (Container.Content, Node, New_Item); - end Replace; - - end Generic_Keys; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Set; Position : Cursor) return Boolean is - begin - if Position.Node = 0 - or else not Container.Content.Nodes (Position.Node).Has_Element - then - return False; - end if; - - return True; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Type) return Hash_Type is - begin - return Hash (Node.Element); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include (Container : in out Set; New_Item : Element_Type) is - Inserted : Boolean; - Position : Cursor; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - Container.Content.Nodes (Position.Node).Element := New_Item; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert (Container, New_Item, Position.Node, Inserted); - end Insert; - - procedure Insert (Container : in out Set; New_Item : Element_Type) is - Inserted : Boolean; - Unused_Position : Cursor; - - begin - Insert (Container, New_Item, Unused_Position, Inserted); - - if not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - procedure Allocate_Set_Element (Node : in out Node_Type); - pragma Inline (Allocate_Set_Element); - - procedure New_Node - (HT : in out Hash_Table_Type; - Node : out Count_Type); - pragma Inline (New_Node); - - procedure Local_Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new Generic_Allocate (Allocate_Set_Element); - - --------------------------- - -- Allocate_Set_Element -- - --------------------------- - - procedure Allocate_Set_Element (Node : in out Node_Type) is - begin - Node.Element := New_Item; - end Allocate_Set_Element; - - -------------- - -- New_Node -- - -------------- - - procedure New_Node - (HT : in out Hash_Table_Type; - Node : out Count_Type) - is - begin - Allocate (HT, Node); - end New_Node; - - -- Start of processing for Insert - - begin - Local_Insert (Container.Content, New_Item, Node, Inserted); - end Insert; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection (Target : in out Set; Source : Set) is - Tgt_Node : Count_Type; - TN : Nodes_Type renames Target.Content.Nodes; - - begin - if Source.Content.Length = 0 then - Clear (Target); - return; - end if; - - Tgt_Node := HT_Ops.First (Target.Content); - while Tgt_Node /= 0 loop - if Find (Source, TN (Tgt_Node).Element).Node /= 0 then - Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node); - - else - declare - X : constant Count_Type := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target.Content, X); - Free (Target, X); - end; - end if; - end loop; - end Intersection; - - procedure Intersection (Left : Set; Right : Set; Target : in out Set) is - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - 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, Unused_X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Intersection - - begin - Iterate (Left.Content); - end Intersection; - - function Intersection (Left : Set; Right : Set) return Set is - C : constant Count_Type := - Count_Type'Min (Length (Left), Length (Right)); -- ??? - H : constant Hash_Type := Default_Modulus (C); - - begin - return S : Set (C, H) do - if Length (Left) /= 0 and Length (Right) /= 0 then - Intersection (Left, Right, Target => S); - end if; - end return; - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ----------- - -- Is_In -- - ----------- - - function Is_In (HT : Set; Key : Node_Type) return Boolean is - begin - return Element_Keys.Find (HT.Content, Key.Element) /= 0; - end Is_In; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - Subset_Node : Count_Type; - Subset_Nodes : Nodes_Type renames Subset.Content.Nodes; - - begin - if Length (Subset) > Length (Of_Set) then - return False; - end if; - - Subset_Node := First (Subset).Node; - while Subset_Node /= 0 loop - declare - S : constant Count_Type := Subset_Node; - N : Node_Type renames Subset_Nodes (S); - E : Element_Type renames N.Element; - - begin - if Find (Of_Set, E).Node = 0 then - return False; - end if; - end; - - Subset_Node := HT_Ops.Next (Subset.Content, Subset_Node); - end loop; - - return True; - end Is_Subset; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Content.Length; - end Length; - - ---------- - -- Move -- - ---------- - - -- Comments??? - - procedure Move (Target : in out Set; Source : in out Set) is - NN : HT_Types.Nodes_Type renames Source.Content.Nodes; - X, Y : Count_Type; - - begin - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - if Source.Content.Length = 0 then - return; - end if; - - X := HT_Ops.First (Source.Content); - while X /= 0 loop - Insert (Target, NN (X).Element); -- optimize??? - - Y := HT_Ops.Next (Source.Content, X); - - HT_Ops.Delete_Node_Sans_Free (Source.Content, X); - Free (Source, X); - - X := Y; - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Type) return Count_Type is - begin - return Node.Next; - end Next; - - function Next (Container : Set; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Next"); - - return (Node => HT_Ops.Next (Container.Content, Position.Node)); - end Next; - - procedure Next (Container : Set; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - Left_Node : Count_Type; - Left_Nodes : Nodes_Type renames Left.Content.Nodes; - - begin - if Length (Right) = 0 or Length (Left) = 0 then - return False; - end if; - - Left_Node := First (Left).Node; - while Left_Node /= 0 loop - declare - 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 - return True; - end if; - end; - - Left_Node := HT_Ops.Next (Left.Content, Left_Node); - end loop; - - return False; - end Overlap; - - ------------- - -- Replace -- - ------------- - - procedure Replace (Container : in out Set; New_Item : Element_Type) is - Node : constant Count_Type := - Element_Keys.Find (Container.Content, New_Item); - - begin - if Node = 0 then - raise Constraint_Error with "attempt to replace element not in set"; - end if; - - Container.Content.Nodes (Node).Element := New_Item; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in Replace_Element"); - - Replace_Element (Container.Content, Position.Node, New_Item); - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type) - is - begin - if Capacity > Container.Capacity then - raise Constraint_Error with "requested capacity is too large"; - end if; - end Reserve_Capacity; - - ------------------ - -- Set_Element -- - ------------------ - - procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is - begin - Node.Element := Item; - end Set_Element; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is - begin - Node.Next := Next; - end Set_Next; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference (Target : in out Set; Source : Set) is - procedure Process (Source_Node : Count_Type); - pragma Inline (Process); - - procedure Iterate is new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Source_Node : Count_Type) is - 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, Unused_X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Symmetric_Difference - - begin - if Length (Target) = 0 then - Assign (Target, Source); - return; - end if; - - Iterate (Source.Content); - end Symmetric_Difference; - - function Symmetric_Difference (Left : Set; Right : Set) return Set is - begin - if Length (Right) = 0 then - return Copy (Left); - end if; - - if Length (Left) = 0 then - return Copy (Right); - end if; - - 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; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - Unused_X : Count_Type; - B : Boolean; - - begin - return S : Set (Capacity => 1, Modulus => 1) do - Insert (S, New_Item, Unused_X, B); - pragma Assert (B); - end return; - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Set; Source : Set) is - procedure Process (Src_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Count_Type) is - N : Node_Type renames Source.Content.Nodes (Src_Node); - E : Element_Type renames N.Element; - - Unused_X : Count_Type; - Unused_B : Boolean; - - begin - Insert (Target, E, Unused_X, Unused_B); - end Process; - - -- Start of processing for Union - - begin - Iterate (Source.Content); - end Union; - - function Union (Left : Set; Right : Set) return Set is - begin - if Length (Right) = 0 then - return Copy (Left); - end if; - - if Length (Left) = 0 then - return Copy (Right); - end if; - - 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; - - --------- - -- Vet -- - --------- - - 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; - - declare - S : Set renames Container; - N : Nodes_Type renames S.Content.Nodes; - X : Count_Type; - - begin - if S.Content.Length = 0 then - return False; - end if; - - if Position.Node > N'Last then - return False; - end if; - - if N (Position.Node).Next = Position.Node then - return False; - end if; - - X := S.Content.Buckets - (Element_Keys.Index (S.Content, N (Position.Node).Element)); - - for J in 1 .. S.Content.Length loop - if X = Position.Node then - return True; - end if; - - if X = 0 then - return False; - end if; - - if X = N (X).Next then -- to prevent unnecessary looping - return False; - end if; - - X := N (X).Next; - end loop; - - return False; - end; - end Vet; - -end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cfhase.ads b/gcc/ada/libgnat/a-cfhase.ads index 248a0ac..633ed20 100644 --- a/gcc/ada/libgnat/a-cfhase.ads +++ b/gcc/ada/libgnat/a-cfhase.ads @@ -29,1475 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- This spec is derived from package Ada.Containers.Bounded_Hashed_Sets in the --- Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- content of a container: Element, Next, Query_Element, Has_Element, Key, --- Iterate, Equivalent_Elements. This change is motivated by the need to --- have cursors which are valid on different containers (typically a --- container C and its previous version C'Old) for expressing properties, --- which is not possible if cursors encapsulate an access to the underlying --- container. - -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 - type Element_Type is private; - - with function Hash (Element : Element_Type) return Hash_Type; - - with function Equivalent_Elements - (Left : Element_Type; - Right : Element_Type) return Boolean is "="; - -package Ada.Containers.Formal_Hashed_Sets with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -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); - - -- 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, - Has_Element => Has_Element, - Element => Element), - Default_Initial_Condition => Is_Empty (Set); - pragma Preelaborable_Initialization (Set); - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - function Length (Container : Set) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - 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_Sets - (Element_Type => Element_Type, - Equivalent_Elements => Equivalent_Elements); - - function "=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."="; - - function "<=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."<="; - - package E is new Ada.Containers.Functional_Vectors - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."="; - - function "<" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<"; - - function "<=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<="; - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - -- Search for Item in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= E.Length (Container) - and Equivalent_Elements - (Item, E.Get (Container, Find'Result))); - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Left are contained in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I)); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - (if M.Contains (Model, E.Get (Left, I)) then - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Left and others - -- are in Right. - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Container) => - (if M.Contains (Model, E.Get (Container, I)) then - Find (Left, E.Get (Container, I)) > 0 - and then E.Get (Left, Find (Left, E.Get (Container, I))) = - E.Get (Container, I) - else - Find (Right, E.Get (Container, I)) > 0 - and then E.Get - (Right, Find (Right, E.Get (Container, I))) = - E.Get (Container, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - 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 Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Right contains all the elements of Left - - and E_Elements_Included (E_Left, E_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same. - - and (for all C of P_Left => - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C)))); - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved_Except'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same except for Position. - - and (for all C of P_Left => - (if C /= Position then - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C))))); - - function Model (Container : Set) return M.Set with - -- The high-level model of a set is a set of elements. Neither cursors - -- nor order of elements are represented in this model. Elements are - -- modeled up to equivalence. - - Ghost, - Global => null, - 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 - -- sets that is used for iteration. It stores the actual values of - -- elements in the set. It does not model cursors. - - Ghost, - Global => null, - Post => - E.Length (Elements'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Item of Elements'Result => - M.Contains (Model (Container), Item)) - - -- It contains all the elements contained in Model - - and (for all Item of Model (Container) => - (Find (Elements'Result, Item) > 0 - and then Equivalent_Elements - (E.Get (Elements'Result, - Find (Elements'Result, Item)), - Item))) - - -- It has no duplicate - - and (for all I in 1 .. Length (Container) => - Find (Elements'Result, E.Get (Elements'Result, I)) = I) - - and (for all I in 1 .. Length (Container) => - (for all J in 1 .. Length (Container) => - (if Equivalent_Elements - (E.Get (Elements'Result, I), - E.Get (Elements'Result, J)) - then I = J))); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements); - - function Positions (Container : Set) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps 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 : Set) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access 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 Item of Elements (Container) => - (for some I of Positions (Container) => - E.Get (Elements (Container), P.Get (Positions (Container), I)) = - Item)); - - function Contains - (C : M.Set; - K : Element_Type) return Boolean renames M.Contains; - -- To improve readability of contracts, we rename the function used to - -- search for an element in the model to Contains. - - end Formal_Model; - use Formal_Model; - - Empty_Set : constant Set; - - function "=" (Left, Right : Set) return Boolean with - Global => null, - Post => - "="'Result = - (Length (Left) = Length (Right) - and E_Elements_Included (Elements (Left), Elements (Right))) - and - "="'Result = - (E_Elements_Included (Elements (Left), Elements (Right)) - and E_Elements_Included (Elements (Right), Elements (Left))); - -- For each element in Left, set equality attempts to find the equal - -- element in Right; if a search fails, then set equality immediately - -- returns False. The search works by calling Hash to find the bucket in - -- the Right set that corresponds to the Left element. If the bucket is - -- non-empty, the search calls the generic formal element equality operator - -- to compare the element (in Left) to the element of each node in the - -- bucket (in Right); the search terminates when a matching node in the - -- bucket is found, or the nodes in the bucket are exhausted. (Note that - -- element equality is called here, not Equivalent_Elements. Set equality - -- is the only operation in which element equality is used. Compare set - -- equality to Equivalent_Sets, which does call Equivalent_Elements.) - - function Equivalent_Sets (Left, Right : Set) return Boolean with - Global => null, - Post => Equivalent_Sets'Result = (Model (Left) = Model (Right)); - -- Similar to set equality, with the difference that the element in Left is - -- compared to the elements in Right using the generic formal - -- Equivalent_Elements operation instead of element equality. - - function To_Set (New_Item : Element_Type) return Set with - Global => null, - Post => - M.Is_Singleton (Model (To_Set'Result), New_Item) - and Length (To_Set'Result) = 1 - and E.Get (Elements (To_Set'Result), 1) = New_Item; - -- Constructs a singleton set comprising New_Element. To_Set calls Hash to - -- determine the bucket for New_Item. - - function Capacity (Container : Set) return Count_Type with - Global => null, - Post => Capacity'Result = Container.Capacity; - -- Returns the current capacity of the set. Capacity is the maximum length - -- before which rehashing in guaranteed not to occur. - - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type) - with - Global => null, - Pre => Capacity <= Container.Capacity, - Post => - Model (Container) = Model (Container)'Old - and Length (Container)'Old = Length (Container) - - -- Actual elements are preserved - - and E_Elements_Included - (Elements (Container), Elements (Container)'Old) - and E_Elements_Included - (Elements (Container)'Old, Elements (Container)); - -- If the value of the Capacity actual parameter is less or equal to - -- Container.Capacity, then the operation has no effect. Otherwise it - -- raises Capacity_Error (as no expansion of capacity is possible for a - -- bounded form). - - function Is_Empty (Container : Set) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - -- Equivalent to Length (Container) = 0 - - procedure Clear (Container : in out Set) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - -- Removes all of the items from the set. This will deallocate all memory - -- associated with this set. - - procedure Assign (Target : in out Set; Source : Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Length (Target) = Length (Source) - - -- Actual elements are preserved - - and E_Elements_Included (Elements (Target), Elements (Source)) - and E_Elements_Included (Elements (Source), Elements (Target)); - -- If Target denotes the same object as Source, then the operation has no - -- effect. If the Target capacity is less than the Source length, then - -- Assign raises Capacity_Error. Otherwise, Assign clears Target and then - -- copies the (active) elements from Source to Target. - - function Copy - (Source : Set; - Capacity : Count_Type := 0) return Set - with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Elements (Copy'Result) = Elements (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - -- Constructs a new set object whose elements correspond to Source. If the - -- Capacity parameter is 0, then the capacity of the result is the same as - -- the length of Source. If the Capacity parameter is equal or greater than - -- the length of Source, then the capacity of the result is the specified - -- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter - -- is 0, then the modulus of the result is the value returned by a call to - -- Default_Modulus with the capacity parameter determined as above; - -- otherwise the modulus of the result is the specified value. - - function Element - (Container : Set; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = - E.Get (Elements (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Position) - and Positions (Container) = Positions (Container)'Old; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return not null access constant Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Constant_Reference'Result.all = - E.Get (Elements (Container), P.Get (Positions (Container), Position)); - - procedure Move (Target : in out Set; Source : in out Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Length (Source) = 0 - and Model (Target) = Model (Source)'Old - and Length (Target) = Length (Source)'Old - - -- Actual elements are preserved - - and E_Elements_Included (Elements (Target), Elements (Source)'Old) - and E_Elements_Included (Elements (Source)'Old, Elements (Target)); - -- Clears Target (if it's not empty), and then moves (not copies) the - -- buckets array and nodes from Source to Target. - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => - Contains (Container, New_Item) - and Has_Element (Container, Position) - and Equivalent_Elements (Element (Container, Position), New_Item), - Contract_Cases => - - -- If New_Item is already in Container, it is not modified and Inserted - -- is set to False. - - (Contains (Container, New_Item) => - not Inserted - and Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, New_Item is inserted in Container and Inserted is set to - -- True. - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Position)); - -- Conditionally inserts New_Item into the set. If New_Item is already in - -- the set, then Inserted returns False and Position designates the node - -- containing the existing element (which is not modified). If New_Item is - -- not already in the set, then Inserted returns True and Position - -- designates the newly-inserted node containing New_Item. The search for - -- an existing element works as follows. Hash is called to determine - -- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements - -- is called to compare New_Item to the element of each node in that - -- bucket. If the bucket is empty, or there were no equivalent elements in - -- the bucket, the search "fails" and the New_Item is inserted in the set - -- (and Inserted returns True); otherwise, the search "succeeds" (and - -- Inserted returns False). - - procedure Insert (Container : in out Set; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Container.Capacity - and then (not Contains (Container, New_Item)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, New_Item) - and Element (Container, Find (Container, New_Item)) = New_Item - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, New_Item)); - -- Attempts to insert New_Item into the set, performing the usual insertion - -- search (which involves calling both Hash and Equivalent_Elements); if - -- the search succeeds (New_Item is equivalent to an element already in the - -- set, and so was not inserted), then this operation raises - -- Constraint_Error. (This version of Insert is similar to Replace, but - -- having the opposite exception behavior. It is intended for use when you - -- want to assert that the item is not already in the set.) - - procedure Include (Container : in out Set; New_Item : Element_Type) with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => - Contains (Container, New_Item) - and Element (Container, Find (Container, New_Item)) = New_Item, - Contract_Cases => - - -- If an element equivalent to New_Item is already in Container, it is - -- replaced by New_Item. - - (Contains (Container, New_Item) => - - -- Elements are preserved modulo equivalence - - Model (Container) = Model (Container)'Old - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The actual value of other elements is preserved - - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - P.Get (Positions (Container), Find (Container, New_Item))), - - -- Otherwise, New_Item is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, New_Item))); - -- Attempts to insert New_Item into the set. If an element equivalent to - -- New_Item is already in the set (the insertion search succeeded, and - -- hence New_Item was not inserted), then the value of New_Item is assigned - -- to the existing element. (This insertion operation only raises an - -- exception if cursor tampering occurs. It is intended for use when you - -- want to insert the item in the set, and you don't care whether an - -- equivalent element is already present.) - - procedure Replace (Container : in out Set; New_Item : Element_Type) with - Global => null, - Pre => Contains (Container, New_Item), - Post => - - -- Elements are preserved modulo equivalence - - Model (Container) = Model (Container)'Old - and Contains (Container, New_Item) - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The element equivalent to New_Item in Container is replaced by - -- New_Item. - - and Element (Container, Find (Container, New_Item)) = New_Item - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - P.Get (Positions (Container), Find (Container, New_Item))); - -- Searches for New_Item in the set; if the search fails (because an - -- equivalent element was not in the set), then it raises - -- Constraint_Error. Otherwise, the existing element is assigned the value - -- New_Item. (This is similar to Insert, but with the opposite exception - -- behavior. It is intended for use when you want to assert that the item - -- is already in the set.) - - procedure Exclude (Container : in out Set; Item : Element_Type) with - Global => null, - Post => not Contains (Container, Item), - Contract_Cases => - - -- If Item is not in Container, nothing is changed - - (not Contains (Container, Item) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Item is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Item)'Old)); - -- Searches for Item in the set, and if found, removes its node from the - -- set and then deallocates it. The search works as follows. The operation - -- calls Hash to determine the item's bucket; if the bucket is not empty, - -- it calls Equivalent_Elements to compare Item to the element of each node - -- in the bucket. (This is the deletion analog of Include. It is intended - -- for use when you want to remove the item from the set, but don't care - -- whether the item is already in the set.) - - procedure Delete (Container : in out Set; Item : Element_Type) with - Global => null, - Pre => Contains (Container, Item), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Item is no longer in Container - - and not Contains (Container, Item) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Item)'Old); - -- Searches for Item in the set (which involves calling both Hash and - -- Equivalent_Elements). If the search fails, then the operation raises - -- Constraint_Error. Otherwise it removes the node from the set and then - -- deallocates it. (This is the deletion analog of non-conditional - -- Insert. It is intended for use when you want to assert that the item is - -- already in the set.) - - procedure Delete (Container : in out Set; Position : in out Cursor) with - Global => null, - Depends => (Container =>+ Position, Position => null), - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The element at position Position is no longer in Container - - and not Contains (Container, Element (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Position'Old); - -- Removes the node designated by Position from the set, and then - -- deallocates the node. The operation calls Hash to determine the bucket, - -- and then compares Position to each node in the bucket until there's a - -- match (it does not call Equivalent_Elements). - - procedure Union (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target), - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - + Big (Length (Source)) - - -- Elements already in Target are still in Target - - and Model (Target)'Old <= Model (Target) - - -- Elements of Source are included in Target - - and Model (Source) <= Model (Target) - - -- Elements of Target come from either Source or Target - - and M.Included_In_Union - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - - and E_Elements_Included - (Elements (Target)'Old, Model (Target)'Old, Elements (Target)) - - and E_Elements_Included - (Elements (Source), - Model (Target)'Old, - Elements (Source), - Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target)'Old, - E_Right => Elements (Target), - P_Left => Positions (Target)'Old, - P_Right => Positions (Target)); - -- Iterates over the Source set, and conditionally inserts each element - -- into Target. - - function Union (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Big (Length (Union'Result)) = Big (Length (Left)) - - M.Num_Overlaps (Model (Left), Model (Right)) - + Big (Length (Right)) - - -- Elements of Left and Right are in the result of Union - - and Model (Left) <= Model (Union'Result) - and Model (Right) <= Model (Union'Result) - - -- Elements of the result of union come from either Left or Right - - and - M.Included_In_Union - (Model (Union'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Union'Result), - Model (Left), - Elements (Left), - Elements (Right)) - - and E_Elements_Included - (Elements (Left), Model (Left), Elements (Union'Result)) - - and E_Elements_Included - (Elements (Right), - Model (Left), - Elements (Right), - Elements (Union'Result)); - -- The operation first copies the Left set to the result, and then iterates - -- over the Right set to conditionally insert each element into the result. - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set) with - Global => null, - Post => - Big (Length (Target)) = - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are in Source - - and Model (Target) <= Model (Source) - - -- Elements both in Source and Target are in the intersection - - and M.Includes_Intersection - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and E_Elements_Included - (Elements (Target)'Old, Model (Source), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - -- Iterates over the Target set (calling First and Next), calling Find to - -- determine whether the element is in Source. If an equivalent element is - -- not found in Source, the element is deleted from Target. - - function Intersection (Left, Right : Set) return Set with - Global => null, - Post => - Big (Length (Intersection'Result)) = - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements in the result of Intersection are in Left and Right - - and Model (Intersection'Result) <= Model (Left) - and Model (Intersection'Result) <= Model (Right) - - -- Elements both in Left and Right are in the result of Intersection - - and M.Includes_Intersection - (Model (Intersection'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from Left - - and E_Elements_Included - (Elements (Intersection'Result), Elements (Left)) - - and E_Elements_Included - (Elements (Left), Model (Right), - Elements (Intersection'Result)); - -- Iterates over the Left set, calling Find to determine whether the - -- element is in Right. If an equivalent element is found, it is inserted - -- into the result set. - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set) with - Global => null, - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are not in Source - - and M.No_Overlap (Model (Target), Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - -- Iterates over the Source (calling First and Next), calling Find to - -- determine whether the element is in Target. If an equivalent element is - -- found, it is deleted from Target. - - function Difference (Left, Right : Set) return Set with - Global => null, - Post => - Big (Length (Difference'Result)) = Big (Length (Left)) - - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements of the result of Difference are in Left - - and Model (Difference'Result) <= Model (Left) - - -- Elements of the result of Difference are in Right - - and M.No_Overlap (Model (Difference'Result), Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and M.Included_In_Union - (Model (Left), Model (Difference'Result), Model (Right)) - - -- Actual value of elements come from Left - - and E_Elements_Included - (Elements (Difference'Result), Elements (Left)) - - and E_Elements_Included - (Elements (Left), - Model (Difference'Result), - Elements (Difference'Result)); - -- Iterates over the Left set, calling Find to determine whether the - -- element is in the Right set. If an equivalent element is not found, the - -- element is inserted into the result set. - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target) + Length (Target and Source), - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) + - Big (Length (Source)) - - -- Elements of the difference were not both in Source and in Target - - and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Elements in Source but not in Target are in the difference - - and M.Included_In_Union - (Model (Source), Model (Target), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - - and E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - - and E_Elements_Included - (Elements (Source), Model (Target), Elements (Target)); - -- The operation iterates over the Source set, searching for the element - -- in Target (calling Hash and Equivalent_Elements). If an equivalent - -- element is found, it is removed from Target; otherwise it is inserted - -- into Target. - - function Symmetric_Difference (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Big (Length (Symmetric_Difference'Result)) = Big (Length (Left)) - - 2 * M.Num_Overlaps (Model (Left), Model (Right)) + - Big (Length (Right)) - - -- Elements of the difference were not both in Left and Right - - and M.Not_In_Both - (Model (Symmetric_Difference'Result), - Model (Left), - Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and M.Included_In_Union - (Model (Left), - Model (Symmetric_Difference'Result), - Model (Right)) - - -- Elements in Right but not in Left are in the difference - - and M.Included_In_Union - (Model (Right), - Model (Symmetric_Difference'Result), - Model (Left)) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Symmetric_Difference'Result), - Model (Left), - Elements (Left), - Elements (Right)) - - and E_Elements_Included - (Elements (Left), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)) - - and E_Elements_Included - (Elements (Right), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)); - -- The operation first iterates over the Left set. It calls Find to - -- determine whether the element is in the Right set. If no equivalent - -- element is found, the element from Left is inserted into the result. The - -- operation then iterates over the Right set, to determine whether the - -- element is in the Left set. If no equivalent element is found, the Right - -- element is inserted into the result. - - function "xor" (Left, Right : Set) return Set - renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean with - Global => null, - Post => - Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right))); - -- Iterates over the Left set (calling First and Next), calling Find to - -- determine whether the element is in the Right set. If an equivalent - -- element is found, the operation immediately returns True. The operation - -- returns False if the iteration over Left terminates without finding any - -- equivalent element in Right. - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with - Global => null, - Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set)); - -- Iterates over Subset (calling First and Next), calling Find to determine - -- whether the element is in Of_Set. If no equivalent element is found in - -- Of_Set, the operation immediately returns False. The operation returns - -- True if the iteration over Subset terminates without finding an element - -- not in Of_Set (that is, every element in Subset is equivalent to an - -- element in Of_Set). - - function First (Container : Set) 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); - -- Returns a cursor that designates the first non-empty bucket, by - -- searching from the beginning of the buckets array. - - function Next (Container : Set; 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); - -- Returns a cursor that designates the node that follows the current one - -- designated by Position. If Position designates the last node in its - -- bucket, the operation calls Hash to compute the index of this bucket, - -- and searches the buckets array for the first non-empty bucket, starting - -- from that index; otherwise, it simply follows the link to the next node - -- in the same bucket. - - procedure Next (Container : Set; 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); - -- Equivalent to Position := Next (Position) - - function Find - (Container : Set; - Item : Element_Type) return Cursor - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Item) => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Elements (Container), Item) - - -- The element designated by the result of Find is Item - - and Equivalent_Elements - (Element (Container, Find'Result), Item)); - -- Searches for Item in the set. Find calls Hash to determine the item's - -- bucket; if the bucket is not empty, it calls Equivalent_Elements to - -- compare Item to each element in the bucket. If the search succeeds, Find - -- returns a cursor designating the node containing the equivalent element; - -- otherwise, it returns No_Element. - - function Contains (Container : Set; Item : Element_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Item); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Has_Element (Container : Set; 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); - - function Default_Modulus (Capacity : Count_Type) return Hash_Type with - Global => null; - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function Hash (Key : Key_Type) return Hash_Type; - - with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - package Generic_Keys with SPARK_Mode is - - package Formal_Model with Ghost is - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - with - Global => null, - Post => - M_Included_Except'Result = - (for all E of Left => - Contains (Right, E) - or Equivalent_Keys (Generic_Keys.Key (E), Key)); - - end Formal_Model; - use Formal_Model; - - function Key (Container : Set; Position : Cursor) return Key_Type with - Global => null, - Post => Key'Result = Key (Element (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element (Container : Set; Key : Key_Type) return Element_Type - with - Global => null, - Pre => Contains (Container, Key), - Post => - Element'Result = Element (Container, Find (Container, Key)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - - -- Key now maps to New_Item - - and Element (Container, Key) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Find (Container, Key)) - and Positions (Container) = Positions (Container)'Old; - - procedure Exclude (Container : in out Set; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old)); - - procedure Delete (Container : in out Set; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old); - - function Find (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - ((for all E of Model (Container) => - not Equivalent_Keys (Key, Generic_Keys.Key (E))) => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - - -- The key designated by the result of Find is Key - - and Equivalent_Keys - (Generic_Keys.Key (Container, Find'Result), Key)); - - function Contains (Container : Set; Key : Key_Type) return Boolean with - Global => null, - Post => - Contains'Result = - (for some E of Model (Container) => - Equivalent_Keys (Key, Generic_Keys.Key (E))); - - end Generic_Keys; - -private - pragma SPARK_Mode (Off); - - pragma Inline (Next); - - type Node_Type is - record - Element : aliased Element_Type; - Next : Count_Type; - Has_Element : Boolean := False; - end record; - - package HT_Types is new - 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); - end record; - - use HT_Types; +package Ada.Containers.Formal_Hashed_Sets with SPARK_Mode is - Empty_Set : constant Set := (Capacity => 0, Modulus => 0, others => <>); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cfidll.adb b/gcc/ada/libgnat/a-cfidll.adb deleted file mode 100644 index 17e48d2..0000000 --- a/gcc/ada/libgnat/a-cfidll.adb +++ /dev/null @@ -1,2054 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 index c4d244a..cbddde3 100644 --- a/gcc/ada/libgnat/a-cfidll.ads +++ b/gcc/ada/libgnat/a-cfidll.ads @@ -29,1642 +29,12 @@ -- <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; +package Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with SPARK_Mode is - 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; + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); - 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 deleted file mode 100644 index 7b457f6..0000000 --- a/gcc/ada/libgnat/a-cfinse.adb +++ /dev/null @@ -1,304 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 index d7fdb04..6f517fa 100644 --- a/gcc/ada/libgnat/a-cfinse.ads +++ b/gcc/ada/libgnat/a-cfinse.ads @@ -29,352 +29,12 @@ -- <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); +package Ada.Containers.Functional_Infinite_Sequences with SPARK_Mode is - function Iter_Next - (Container : Sequence; - Position : Big_Integer) return Big_Integer - is - (Position + 1); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); - 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 deleted file mode 100644 index a55786d..0000000 --- a/gcc/ada/libgnat/a-cfinve.adb +++ /dev/null @@ -1,1452 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FORMAL_INDEFINITE_VECTORS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Generic_Array_Sort; -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Formal_Indefinite_Vectors with - SPARK_Mode => Off -is - function H (New_Item : Element_Type) return Holder renames To_Holder; - function E (Container : Holder) return Element_Type renames Get; - - Growth_Factor : constant := 2; - -- When growing a container, multiply current capacity by this. Doubling - -- leads to amortized linear-time copying. - - subtype Int is Long_Long_Integer; - - procedure Free is - new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr); - - type Maximal_Array_Ptr is access all Elements_Array (Array_Index) - with Storage_Size => 0; - type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index) - with Storage_Size => 0; - - function Elems (Container : in out Vector) return Maximal_Array_Ptr; - function Elemsc - (Container : Vector) return Maximal_Array_Ptr_Const; - -- Returns a pointer to the Elements array currently in use -- either - -- Container.Elements_Ptr or a pointer to Container.Elements. We work with - -- pointers to a bogus array subtype that is constrained with the maximum - -- possible bounds. This means that the pointer is a thin pointer. This is - -- necessary because 'Unrestricted_Access doesn't work when it produces - -- access-to-unconstrained and is returned from a function. - -- - -- Note that this is dangerous: make sure calls to this use an indexed - -- component or slice that is within the bounds 1 .. Length (Container). - - function Get_Element - (Container : Vector; - Position : Capacity_Range) return Element_Type; - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; - - function Current_Capacity (Container : Vector) return Capacity_Range; - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - --------- - -- "=" -- - --------- - - function "=" (Left : Vector; Right : Vector) return Boolean is - begin - if Left'Address = Right'Address then - return True; - end if; - - if Length (Left) /= Length (Right) then - return False; - end if; - - for J in 1 .. Length (Left) loop - if Get_Element (Left, J) /= Get_Element (Right, J) then - return False; - end if; - end loop; - - return True; - end "="; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; New_Item : Vector) is - begin - if Is_Empty (New_Item) then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item); - end Append; - - procedure Append (Container : in out Vector; New_Item : Element_Type) is - begin - Append (Container, New_Item, 1); - end Append; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - if Count = 0 then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Vector; Source : Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Bounded and then Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Vector) return Capacity_Range is - begin - return - (if Bounded then - Container.Capacity - else - Capacity_Range'Last); - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Vector) is - begin - Container.Last := No_Index; - - -- Free element, note that this is OK if Elements_Ptr is null - - Free (Container.Elements_Ptr); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return not null access constant Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - return Constant_Reference (Elemsc (Container) (I)); - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - is - begin - return Find_Index (Container, Item) /= No_Index; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - is - LS : constant Capacity_Range := Length (Source); - C : Capacity_Range; - - begin - if Capacity = 0 then - C := LS; - elsif Capacity >= LS then - C := Capacity; - else - raise Capacity_Error; - end if; - - return Target : Vector (C) do - Elems (Target) (1 .. LS) := Elemsc (Source) (1 .. LS); - Target.Last := Source.Last; - end return; - end Copy; - - ---------------------- - -- Current_Capacity -- - ---------------------- - - function Current_Capacity (Container : Vector) return Capacity_Range is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Length - else - Container.Elements_Ptr.all'Length); - end Current_Capacity; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Vector; Index : Extended_Index) is - begin - Delete (Container, Index, 1); - end Delete; - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - is - Old_Last : constant Index_Type'Base := Container.Last; - Old_Len : constant Count_Type := Length (Container); - New_Last : Index_Type'Base; - Count2 : Count_Type'Base; -- count of items from Index to Old_Last - Off : Count_Type'Base; -- Index expressed as offset from IT'First - - begin - -- Delete removes items from the vector, the number of which is the - -- minimum of the specified Count and the items (if any) that exist from - -- Index to Container.Last. There are no constraints on the specified - -- value of Count (it can be larger than what's available at this - -- position in the vector, for example), but there are constraints on - -- the allowed values of the Index. - - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying which items - -- should be deleted, so we must manually check. (That the user is - -- allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Index < Index_Type'First then - raise Constraint_Error with "Index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows the - -- corner case of deleting no items from the back end of the vector to - -- be treated as a no-op. (It is assumed that specifying an index value - -- greater than Last + 1 indicates some deeper flaw in the caller's - -- algorithm, so that case is treated as a proper error.) - - if Index > Old_Last then - if Index > Old_Last + 1 then - raise Constraint_Error with "Index is out of range (too large)"; - end if; - - return; - end if; - - if Count = 0 then - return; - end if; - - -- We first calculate what's available for deletion starting at - -- Index. Here and elsewhere we use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. (See function - -- Length for more information.) - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else - Count2 := Count_Type'Base (Old_Last - Index + 1); - end if; - - -- If more elements are requested (Count) for deletion than are - -- available (Count2) for deletion beginning at Index, then everything - -- from Index is deleted. There are no elements to slide down, and so - -- all we need to do is set the value of Container.Last. - - if Count >= Count2 then - Container.Last := Index - 1; - return; - end if; - - -- There are some elements that aren't being deleted (the requested - -- count was less than the available count), so we must slide them down - -- to Index. We first calculate the index values of the respective array - -- slices, using the wider of Index_Type'Base and Count_Type'Base as the - -- type for intermediate calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Off := Count_Type'Base (Index - Index_Type'First); - New_Last := Old_Last - Index_Type'Base (Count); - else - Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); - New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); - end if; - - -- The array index values for each slice have already been determined, - -- so we just slide down to Index the elements that weren't deleted. - - declare - EA : Maximal_Array_Ptr renames Elems (Container); - Idx : constant Count_Type := EA'First + Off; - - begin - EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); - Container.Last := New_Last; - end; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Vector) is - begin - Delete_First (Container, 1); - end Delete_First; - - procedure Delete_First (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - - elsif Count >= Length (Container) then - Clear (Container); - return; - - else - Delete (Container, Index_Type'First, Count); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Vector) is - begin - Delete_Last (Container, 1); - end Delete_Last; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - end if; - - -- There is no restriction on how large Count can be when deleting - -- items. If it is equal or greater than the current length, then this - -- is equivalent to clearing the vector. (In particular, there's no need - -- for us to actually calculate the new value for Last.) - - -- If the requested count is less than the current length, then we must - -- calculate the new value for Last. For the type we use the widest of - -- Index_Type'Base and Count_Type'Base for the intermediate values of - -- our calculation. (See the comments in Length for more information.) - - if Count >= Length (Container) then - Container.Last := No_Index; - - elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := Container.Last - Index_Type'Base (Count); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (Container.Last) - Count); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Vector; - Index : Extended_Index) return Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - return Get_Element (Container, I); - end; - end Element; - - ----------- - -- Elems -- - ----------- - - function Elems (Container : in out Vector) return Maximal_Array_Ptr is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Unrestricted_Access - else - Container.Elements_Ptr.all'Unrestricted_Access); - end Elems; - - function Elemsc (Container : Vector) return Maximal_Array_Ptr_Const is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Unrestricted_Access - else - Container.Elements_Ptr.all'Unrestricted_Access); - end Elemsc; - - ---------------- - -- Find_Index -- - ---------------- - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - is - K : Count_Type; - Last : constant Extended_Index := Last_Index (Container); - - begin - K := Capacity_Range (Int (Index) - Int (No_Index)); - for Indx in Index .. Last loop - if Get_Element (Container, K) = Item then - return Indx; - end if; - - K := K + 1; - end loop; - - return No_Index; - end Find_Index; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Get_Element (Container, 1); - end if; - end First_Element; - - ----------------- - -- First_Index -- - ----------------- - - function First_Index (Container : Vector) return Index_Type is - pragma Unreferenced (Container); - begin - return Index_Type'First; - end First_Index; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- M_Elements_In_Union -- - ------------------------- - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - is - begin - for Index in Index_Type'First .. M.Last (Container) loop - declare - Elem : constant Element_Type := Element (Container, Index); - begin - if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem) - and then - not M.Contains - (Right, Index_Type'First, M.Last (Right), Elem) - then - return False; - end if; - end; - end loop; - - return True; - end M_Elements_In_Union; - - ------------------------- - -- M_Elements_Included -- - ------------------------- - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) return Boolean - is - begin - for I in L_Fst .. L_Lst loop - declare - Found : Boolean := False; - J : Extended_Index := 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 Index_Type := M.Last (Left); - - begin - if L /= M.Last (Right) then - return False; - end if; - - for I in Index_Type'First .. 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 : Index_Type; - Y : Index_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 Index_Type'First .. M.Last (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 : Vector) return M.Sequence is - R : M.Sequence; - - begin - for Position in 1 .. Length (Container) loop - R := M.Add (R, E (Elemsc (Container) (Position))); - end loop; - - return R; - end Model; - - end Formal_Model; - - --------------------- - -- 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, Index_Type'First); - - begin - for I in Index_Type'First + 1 .. M.Last (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 : Vector) return Boolean is - L : constant Capacity_Range := Length (Container); - - begin - for J in 1 .. L - 1 loop - if Get_Element (Container, J + 1) < Get_Element (Container, J) then - return False; - end if; - end loop; - - return True; - end Is_Sorted; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out Vector) is - function "<" (Left : Holder; Right : Holder) return Boolean is - (E (Left) < E (Right)); - - procedure Sort is new Generic_Array_Sort - (Index_Type => Array_Index, - Element_Type => Holder, - Array_Type => Elements_Array, - "<" => "<"); - - Len : constant Capacity_Range := Length (Container); - - begin - if Container.Last <= Index_Type'First then - return; - else - Sort (Elems (Container) (1 .. Len)); - end if; - end Sort; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target : in out Vector; Source : in out Vector) is - I : Count_Type; - J : Count_Type; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Length (Source) = 0 then - return; - end if; - - if Length (Target) = 0 then - Move (Target => Target, Source => Source); - return; - end if; - - I := Length (Target); - - declare - New_Length : constant Count_Type := I + Length (Source); - - begin - if not Bounded - and then Current_Capacity (Target) < Capacity_Range (New_Length) - then - Reserve_Capacity - (Target, - Capacity_Range'Max - (Current_Capacity (Target) * Growth_Factor, - Capacity_Range (New_Length))); - end if; - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Target.Last := No_Index + Index_Type'Base (New_Length); - - else - Target.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end; - - declare - TA : Maximal_Array_Ptr renames Elems (Target); - SA : Maximal_Array_Ptr renames Elems (Source); - - begin - J := Length (Target); - while Length (Source) /= 0 loop - if I = 0 then - TA (1 .. J) := SA (1 .. Length (Source)); - Source.Last := No_Index; - exit; - end if; - - if E (SA (Length (Source))) < E (TA (I)) then - TA (J) := TA (I); - I := I - 1; - - else - TA (J) := SA (Length (Source)); - Source.Last := Source.Last - 1; - end if; - - J := J - 1; - end loop; - end; - end Merge; - - end Generic_Sorting; - - ----------------- - -- Get_Element -- - ----------------- - - function Get_Element - (Container : Vector; - Position : Capacity_Range) return Element_Type - is - begin - return E (Elemsc (Container) (Position)); - end Get_Element; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - is - begin - return Position in First_Index (Container) .. Last_Index (Container); - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - is - begin - Insert (Container, Before, New_Item, 1); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - is - J : Count_Type'Base; -- scratch - - begin - -- Use Insert_Space to create the "hole" (the destination slice) - - Insert_Space (Container, Before, Count); - - J := To_Array_Index (Before); - - Elems (Container) (J .. J - 1 + Count) := [others => H (New_Item)]; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - is - N : constant Count_Type := Length (New_Item); - B : Count_Type; -- index Before converted to Count_Type - - begin - if Container'Address = New_Item'Address then - raise Program_Error with - "Container and New_Item denote same container"; - end if; - - -- Use Insert_Space to create the "hole" (the destination slice) into - -- which we copy the source items. - - Insert_Space (Container, Before, Count => N); - - if N = 0 then - -- There's nothing else to do here (vetting of parameters was - -- performed already in Insert_Space), so we simply return. - - return; - end if; - - B := To_Array_Index (Before); - - Elems (Container) (B .. B + N - 1) := Elemsc (New_Item) (1 .. N); - end Insert; - - ------------------ - -- Insert_Space -- - ------------------ - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Length (Container); - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Before > Container.Last - and then Before - 1 > Container.Last - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - - -- We treat inserting 0 items into the container as a no-op, so we - -- simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion - -- count. Note that we cannot simply add these values, because of the - -- possibility of overflow. - - if Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last) - then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - J := To_Array_Index (Before); - - -- Increase the capacity of container if needed - - if not Bounded - and then Current_Capacity (Container) < Capacity_Range (New_Length) - then - Reserve_Capacity - (Container, - Capacity_Range'Max - (Current_Capacity (Container) * Growth_Factor, - Capacity_Range (New_Length))); - end if; - - declare - EA : Maximal_Array_Ptr renames Elems (Container); - - begin - if Before <= Container.Last then - - -- The new items are being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. - - EA (J + Count .. New_Length) := EA (J .. Old_Length); - end if; - end; - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := No_Index + Index_Type'Base (New_Length); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end Insert_Space; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Vector) return Boolean is - begin - return Last_Index (Container) < Index_Type'First; - end Is_Empty; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Get_Element (Container, Length (Container)); - end if; - end Last_Element; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - ------------ - -- Length -- - ------------ - - function Length (Container : Vector) return Capacity_Range is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; - - begin - return Capacity_Range (N); - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Vector; Source : in out Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Bounded and then Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - Clear (Source); - end Move; - - ------------ - -- Prepend -- - ------------ - - procedure Prepend (Container : in out Vector; New_Item : Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) is - begin - Prepend (Container, New_Item, 1); - end Prepend; - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, Index_Type'First, New_Item, Count); - end Prepend; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : not null access Vector; - Index : Index_Type) return not null access Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - if Container.Elements_Ptr = null then - return Reference (Container.Elements (I)'Access); - else - return Reference (Container.Elements_Ptr (I)'Access); - end if; - end; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - Elems (Container) (I) := H (New_Item); - end; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - is - begin - if Bounded then - if Capacity > Container.Capacity then - raise Constraint_Error with "Capacity is out of range"; - end if; - - else - if Capacity > Current_Capacity (Container) then - declare - New_Elements : constant Elements_Array_Ptr := - new Elements_Array (1 .. Capacity); - L : constant Capacity_Range := Length (Container); - - begin - New_Elements (1 .. L) := Elemsc (Container) (1 .. L); - Free (Container.Elements_Ptr); - Container.Elements_Ptr := New_Elements; - end; - end if; - end if; - end Reserve_Capacity; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out Vector) is - begin - if Length (Container) <= 1 then - return; - end if; - - declare - I : Capacity_Range; - J : Capacity_Range; - E : Elements_Array renames - Elems (Container) (1 .. Length (Container)); - - begin - I := 1; - J := Length (Container); - while I < J loop - declare - EI : constant Holder := E (I); - - begin - E (I) := E (J); - E (J) := EI; - end; - - I := I + 1; - J := J - 1; - end loop; - end; - end Reverse_Elements; - - ------------------------ - -- Reverse_Find_Index -- - ------------------------ - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - is - Last : Index_Type'Base; - K : Count_Type'Base; - - begin - if Index > Last_Index (Container) then - Last := Last_Index (Container); - else - Last := Index; - end if; - - K := Capacity_Range (Int (Last) - Int (No_Index)); - for Indx in reverse Index_Type'First .. Last loop - if Get_Element (Container, K) = Item then - return Indx; - end if; - - K := K - 1; - end loop; - - return No_Index; - end Reverse_Find_Index; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - is - begin - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; - - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; - end if; - - if I = J then - return; - end if; - - declare - II : constant Int'Base := Int (I) - Int (No_Index); - JJ : constant Int'Base := Int (J) - Int (No_Index); - - EI : Holder renames Elems (Container) (Capacity_Range (II)); - EJ : Holder renames Elems (Container) (Capacity_Range (JJ)); - - EI_Copy : constant Holder := EI; - - begin - EI := EJ; - EJ := EI_Copy; - end; - end Swap; - - -------------------- - -- To_Array_Index -- - -------------------- - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is - Offset : Count_Type'Base; - - begin - -- We know that - -- Index >= Index_Type'First - -- hence we also know that - -- Index - Index_Type'First >= 0 - - -- The issue is that even though 0 is guaranteed to be a value in the - -- type Index_Type'Base, there's no guarantee that the difference is a - -- value in that type. To prevent overflow we use the wider of - -- Count_Type'Base and Index_Type'Base to perform intermediate - -- calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Offset := Count_Type'Base (Index - Index_Type'First); - - else - Offset := Count_Type'Base (Index) - - Count_Type'Base (Index_Type'First); - end if; - - -- The array index subtype for all container element arrays always - -- starts with 1. - - return 1 + Offset; - end To_Array_Index; - - --------------- - -- To_Vector -- - --------------- - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - is - begin - if Length = 0 then - return Empty_Vector; - end if; - - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; -- ??? - end if; - - Last := Index_Type (Last_As_Int); - - return - (Capacity => Length, - Last => Last, - Elements_Ptr => <>, - Elements => [others => H (New_Item)]); - end; - end To_Vector; - -end Ada.Containers.Formal_Indefinite_Vectors; diff --git a/gcc/ada/libgnat/a-cfinve.ads b/gcc/ada/libgnat/a-cfinve.ads index f44e45b..dcec6ba 100644 --- a/gcc/ada/libgnat/a-cfinve.ads +++ b/gcc/ada/libgnat/a-cfinve.ads @@ -29,959 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- Similar to Ada.Containers.Formal_Vectors. The main difference is that --- Element_Type may be indefinite (but not an unconstrained array). - -with Ada.Containers.Bounded_Holders; -with Ada.Containers.Functional_Vectors; - generic - type Index_Type is range <>; - type Element_Type (<>) is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - Max_Size_In_Storage_Elements : Natural; - -- Maximum size of Vector elements in bytes. This has the same meaning as - -- in Ada.Containers.Bounded_Holders, with the same restrictions. Note that - -- setting this too small can lead to erroneous execution; see comments in - -- Ada.Containers.Bounded_Holders. If Element_Type is class-wide, it is the - -- responsibility of clients to calculate the maximum size of all types in - -- the class. - - Bounded : Boolean := True; - -- If True, the containers are bounded; the initial capacity is the maximum - -- size, and heap allocation will be avoided. If False, the containers can - -- grow via heap allocation. - -package Ada.Containers.Formal_Indefinite_Vectors with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -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); - - subtype Extended_Index is Index_Type'Base - range Index_Type'First - 1 .. - Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; - - No_Index : constant Extended_Index := Extended_Index'First; - - Last_Count : constant Count_Type := - (if Index_Type'Last < Index_Type'First then - 0 - elsif Index_Type'Last < -1 - or else Index_Type'Pos (Index_Type'First) > - Index_Type'Pos (Index_Type'Last) - Count_Type'Last - then - Index_Type'Pos (Index_Type'Last) - - Index_Type'Pos (Index_Type'First) + 1 - else - Count_Type'Last); - -- Maximal capacity of any vector. It is the minimum of the size of the - -- index range and the last possible Count_Type. - - subtype Capacity_Range is Count_Type range 0 .. Last_Count; - - type Vector (Capacity : Capacity_Range) is limited private with - Default_Initial_Condition => Is_Empty (Vector); - -- In the bounded case, Capacity is the capacity of the container, which - -- never changes. In the unbounded case, Capacity is the initial capacity - -- of the container, and operations such as Reserve_Capacity and Append can - -- increase the capacity. The capacity never shrinks, except in the case of - -- Clear. - -- - -- Note that all objects of type Vector are constrained, including in the - -- unbounded case; you can't assign from one object to another if the - -- Capacity is different. - - function Length (Container : Vector) return Capacity_Range with - Global => null, - Post => Length'Result <= Capacity (Container); - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - - package M is new Ada.Containers.Functional_Vectors - (Index_Type => Index_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 Index_Type'First .. M.Last (Container) => - (for some J in Index_Type'First .. M.Last (Left) => - Element (Container, I) = Element (Left, J)) - or (for some J in Index_Type'First .. M.Last (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 : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) 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.Last (Left) and R_Lst <= M.Last (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 Index_Type'First .. M.Last (Left) => - Element (Left, I) = - Element (Right, M.Last (Left) - I + 1)) - and (for all I in Index_Type'First .. M.Last (Right) => - Element (Right, I) = - Element (Left, M.Last (Left) - I + 1))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - -- Elements stored at X and Y are reversed in Left and Right - with - Global => null, - Pre => X <= M.Last (Left) and Y <= M.Last (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); - - function Model (Container : Vector) return M.Sequence with - -- The high-level model of a vector is a sequence of elements. The - -- sequence really is similar to the vector itself. However, it is not - -- limited which allows usage of 'Old and 'Loop_Entry attributes. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - - function Element - (S : M.Sequence; - I : Index_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 Empty_Vector return Vector with - Global => null, - Post => Length (Empty_Vector'Result) = 0; - - function "=" (Left, Right : Vector) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - with - Global => null, - Post => - Formal_Indefinite_Vectors.Length (To_Vector'Result) = Length - and M.Constant_Range - (Container => Model (To_Vector'Result), - Fst => Index_Type'First, - Lst => Last_Index (To_Vector'Result), - Item => New_Item); - - function Capacity (Container : Vector) return Capacity_Range with - Global => null, - Post => - Capacity'Result = - (if Bounded then - Container.Capacity - else - Capacity_Range'Last); - pragma Annotate (GNATprove, Inline_For_Proof, Capacity); - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - with - Global => null, - Pre => (if Bounded then Capacity <= Container.Capacity), - Post => Model (Container) = Model (Container)'Old; - - function Is_Empty (Container : Vector) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Vector) with - Global => null, - Post => Length (Container) = 0; - -- Note that this reclaims storage in the unbounded case. You need to call - -- this before a container goes out of scope in order to avoid storage - -- leaks. In addition, "X := ..." can leak unless you Clear(X) first. - - procedure Assign (Target : in out Vector; Source : Vector) with - Global => null, - Pre => (if Bounded then Length (Source) <= Target.Capacity), - Post => Model (Target) = Model (Source); - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - with - Global => null, - Pre => (if Bounded then (Capacity = 0 or Length (Source) <= Capacity)), - Post => - Model (Copy'Result) = Model (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Length (Source) - else - Copy'Result.Capacity = Capacity); - - procedure Move (Target : in out Vector; Source : in out Vector) - with - Global => null, - Pre => (if Bounded then Length (Source) <= Capacity (Target)), - Post => Model (Target) = Model (Source)'Old and Length (Source) = 0; - - function Element - (Container : Vector; - Index : Extended_Index) return Element_Type - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => Element'Result = Element (Model (Container), Index); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - - -- Container now has New_Item at index Index - - and Element (Model (Container), Index) = New_Item - - -- All other elements are preserved - - and M.Equal_Except - (Left => Model (Container)'Old, - Right => Model (Container), - Position => Index); - - function At_End (E : access constant Vector) return access constant Vector - 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 : aliased Vector; - Index : Index_Type) return not null access constant Element_Type - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Constant_Reference'Result.all = Element (Model (Container), Index); - - function Reference - (Container : not null access Vector; - Index : Index_Type) return not null access Element_Type - with - Global => null, - Pre => - Index in First_Index (Container.all) .. Last_Index (Container.all), - Post => - Length (Container.all) = Length (At_End (Container).all) - - -- Container will have Result.all at index Index - - and At_End (Reference'Result).all = - Element (Model (At_End (Container).all), Index) - - -- All other elements are preserved - - and M.Equal_Except - (Left => Model (Container.all), - Right => Model (At_End (Container).all), - Position => Index); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item) - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Elements of New_Item are inserted at position Before - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => Count_Type (Before - Index_Type'First))) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Capacity (Container) - and then (Before in Index_Type'First .. Last_Index (Container) + 1), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Container now has New_Item at index Before - - and Element (Model (Container), Before) = New_Item - - -- Elements located after Before in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Count - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- New_Item is inserted Count times at position Before - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Before, - Lst => Before + Index_Type'Base (Count - 1), - Item => New_Item)) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Prepend (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements of New_Item are inserted at the beginning of Container - - and M.Range_Equal - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item)) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Container now has New_Item at Index_Type'First - - and Element (Model (Container), Index_Type'First) = New_Item - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- New_Item is inserted Count times at the beginning of Container - - and M.Constant_Range - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Index_Type'First + Index_Type'Base (Count - 1), - Item => New_Item) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Append (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- The elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- Elements of New_Item are inserted at the end of Container - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => - Count_Type - (Last_Index (Container)'Old - Index_Type'First + 1))); - - procedure Append (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements of Container are preserved - - and Model (Container)'Old < Model (Container) - - -- Container now has New_Item at the end of Container - - and Element - (Model (Container), Last_Index (Container)'Old + 1) = New_Item; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- New_Item is inserted Count times at the end of Container - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Last_Index (Container)'Old + 1, - Lst => - Last_Index (Container)'Old + Index_Type'Base (Count), - Item => New_Item)); - - procedure Delete (Container : in out Vector; Index : Extended_Index) with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements located before Index in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1) - - -- Elements located after Index in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - with - Global => null, - Pre => - Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) in - Length (Container)'Old - Count .. Length (Container)'Old - - -- The elements of Container located before Index are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1), - - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) - Count <= Count_Type (Index - Index_Type'First) => - Length (Container) = Count_Type (Index - Index_Type'First), - - 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 => Index, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_First (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index_Type'First, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete_First (Container : in out Vector; 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 => Index_Type'First, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_Last (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are preserved - - and Model (Container) < Model (Container)'Old; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements after Position 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); - - procedure Reverse_Elements (Container : in out Vector) with - Global => null, - Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - with - Global => null, - Pre => - I in First_Index (Container) .. Last_Index (Container) - and then J in First_Index (Container) .. Last_Index (Container), - Post => - M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J); - - function First_Index (Container : Vector) return Index_Type with - Global => null, - Post => First_Index'Result = Index_Type'First; - pragma Annotate (GNATprove, Inline_For_Proof, First_Index); - - function First_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = Element (Model (Container), Index_Type'First); - pragma Annotate (GNATprove, Inline_For_Proof, First_Element); - - function Last_Index (Container : Vector) return Extended_Index with - Global => null, - Post => Last_Index'Result = M.Last (Model (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Index); - - function Last_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = - Element (Model (Container), Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Element); - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container after Index, Find_Index - -- returns No_Index. - - (Index > Last_Index (Container) - or else not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Last_Index (Container), - Item => Item) - => - Find_Index'Result = No_Index, - - -- Otherwise, Find_Index returns a valid index greater than Index - - others => - Find_Index'Result in Index .. Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Find_Index'Result) = Item - - -- It is the first occurrence of Item after Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Find_Index'Result - 1, - Item => Item)); - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container before Index, - -- Reverse_Find_Index returns No_Index. - - (not M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => (if Index <= Last_Index (Container) then Index - else Last_Index (Container)), - Item => Item) - => - Reverse_Find_Index'Result = No_Index, - - -- Otherwise, Reverse_Find_Index returns a valid index smaller than - -- Index - - others => - Reverse_Find_Index'Result in Index_Type'First .. Index - and Reverse_Find_Index'Result <= Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Reverse_Find_Index'Result) = Item - - -- It is the last occurrence of Item before Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Reverse_Find_Index'Result + 1, - Lst => - (if Index <= Last_Index (Container) then - Index - else - Last_Index (Container)), - Item => Item)); - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - with - Global => null, - Post => - Contains'Result = - M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container), - Item => Item); - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - with - Global => null, - Post => - Has_Element'Result = - (Position in Index_Type'First .. Last_Index (Container)); - 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 Index_Type'First .. M.Last (Container) => - (for all J in I .. M.Last (Container) => - Element (Container, I) = Element (Container, J) - or Element (Container, I) < Element (Container, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); - - end Formal_Model; - use Formal_Model; - - function Is_Sorted (Container : Vector) return Boolean with - Global => null, - Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); - - procedure Sort (Container : in out Vector) 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 => Last_Index (Container), - Right => Model (Container), - R_Lst => Last_Index (Container)) - and M_Elements_Included - (Left => Model (Container), - L_Lst => Last_Index (Container), - Right => Model (Container)'Old, - R_Lst => Last_Index (Container)); - - procedure Merge (Target : in out Vector; Source : in out Vector) with - -- Target and Source should not be aliased - Global => null, - Pre => Length (Source) <= Capacity (Target) - Length (Target), - 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 => Last_Index (Target)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Last_Index (Source)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_In_Union - (Model (Target), - Model (Source)'Old, - Model (Target)'Old); - end Generic_Sorting; - -private - pragma SPARK_Mode (Off); - - pragma Inline (First_Index); - pragma Inline (Last_Index); - pragma Inline (Element); - pragma Inline (First_Element); - pragma Inline (Last_Element); - pragma Inline (Replace_Element); - pragma Inline (Contains); - - -- The implementation method is to instantiate Bounded_Holders to get a - -- definite type for Element_Type. - - package Holders is new Bounded_Holders - (Element_Type, Max_Size_In_Storage_Elements, "="); - use Holders; - - subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last; - type Elements_Array is array (Array_Index range <>) of aliased Holder; - function "=" (L, R : Elements_Array) return Boolean is abstract; - - type Elements_Array_Ptr is access all Elements_Array; - - type Vector (Capacity : Capacity_Range) is limited record - - -- In the bounded case, the elements are stored in Elements. In the - -- unbounded case, the elements are initially stored in Elements, until - -- we run out of room, then we switch to Elements_Ptr. - - Last : Extended_Index := No_Index; - Elements_Ptr : Elements_Array_Ptr := null; - Elements : aliased Elements_Array (1 .. Capacity); - end record; - - -- The primary reason Vector is limited is that in the unbounded case, once - -- Elements_Ptr is in use, assignment statements won't work. "X := Y;" will - -- cause X and Y to share state; that is, X.Elements_Ptr = Y.Elements_Ptr, - -- so for example "Append (X, ...);" will modify BOTH X and Y. That would - -- allow SPARK to "prove" things that are false. We could fix that by - -- making Vector a controlled type, and override Adjust to make a deep - -- copy, but finalization is not allowed in SPARK. - -- - -- Note that (unfortunately) this means that 'Old and 'Loop_Entry are not - -- allowed on Vectors. +package Ada.Containers.Formal_Indefinite_Vectors with SPARK_Mode is - function Empty_Vector return Vector is - ((Capacity => 0, others => <>)); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Indefinite_Vectors; diff --git a/gcc/ada/libgnat/a-cforma.adb b/gcc/ada/libgnat/a-cforma.adb deleted file mode 100644 index 38d15e7..0000000 --- a/gcc/ada/libgnat/a-cforma.adb +++ /dev/null @@ -1,1239 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); - -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 -- - ----------------------------- - - -- These subprograms provide a functional interface to access fields - -- of a node, and a procedural interface for modifying these values. - - function Color - (Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type; - pragma Inline (Color); - - function Left_Son (Node : Node_Type) return Count_Type; - pragma Inline (Left_Son); - - function Parent (Node : Node_Type) return Count_Type; - pragma Inline (Parent); - - function Right_Son (Node : Node_Type) return Count_Type; - pragma Inline (Right_Son); - - procedure Set_Color - (Node : in out Node_Type; - Color : Ada.Containers.Red_Black_Trees.Color_Type); - pragma Inline (Set_Color); - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type); - pragma Inline (Set_Left); - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type); - pragma Inline (Set_Right); - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); - pragma Inline (Set_Parent); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All need comments ??? - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type); - - procedure Free (Tree : in out Map; X : Count_Type); - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Bounded_Operations - (Tree_Types => Tree_Types, - Left => Left_Son, - Right => Right_Son); - - use Tree_Operations; - - package Key_Ops is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Map) return Boolean is - Lst : Count_Type; - Node : Count_Type; - ENode : Count_Type; - - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Is_Empty (Left) then - return True; - end if; - - Lst := Next (Left.Content, Last (Left).Node); - - Node := First (Left).Node; - while Node /= Lst loop - ENode := Find (Right, Left.Content.Nodes (Node).Key).Node; - - if ENode = 0 or else - Left.Content.Nodes (Node).Element /= - Right.Content.Nodes (ENode).Element - then - return False; - end if; - - Node := Next (Left.Content, Node); - end loop; - - return True; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Append_Element (Source_Node : Count_Type); - - procedure Append_Elements is - new Tree_Operations.Generic_Iteration (Append_Element); - - -------------------- - -- Append_Element -- - -------------------- - - procedure Append_Element (Source_Node : Count_Type) is - SN : Node_Type renames Source.Content.Nodes (Source_Node); - - procedure Set_Element (Node : in out Node_Type); - pragma Inline (Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert_Sans_Hint is - new Key_Ops.Generic_Unconditional_Insert (Insert_Post); - - procedure Unconditional_Insert_Avec_Hint is - new Key_Ops.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Unconditional_Insert_Sans_Hint); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Target.Content, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Key := SN.Key; - Node.Element := SN.Element; - end Set_Element; - - Target_Node : Count_Type; - - -- Start of processing for Append_Element - - begin - Unconditional_Insert_Avec_Hint - (Tree => Target.Content, - Hint => 0, - Key => SN.Key, - Node => Target_Node); - end Append_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; - - Tree_Operations.Clear_Tree (Target.Content); - Append_Elements (Source.Content); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Ceiling (Container.Content, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Map) is - begin - Tree_Operations.Clear_Tree (Container.Content); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Type) return Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return not null access constant 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.Content, Position.Node), - "bad cursor in function Constant_Reference"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return not null access constant Element_Type - is - Node : constant Node_Access := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Content.Nodes (Node).Element'Access; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Map; Capacity : Count_Type := 0) return Map is - Node : Count_Type := 1; - N : Count_Type; - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do - if Length (Source) > 0 then - Target.Content.Length := Source.Content.Length; - Target.Content.Root := Source.Content.Root; - Target.Content.First := Source.Content.First; - Target.Content.Last := Source.Content.Last; - Target.Content.Free := Source.Content.Free; - - while Node <= Source.Capacity loop - Target.Content.Nodes (Node).Element := - Source.Content.Nodes (Node).Element; - Target.Content.Nodes (Node).Key := - Source.Content.Nodes (Node).Key; - Target.Content.Nodes (Node).Parent := - Source.Content.Nodes (Node).Parent; - Target.Content.Nodes (Node).Left := - Source.Content.Nodes (Node).Left; - Target.Content.Nodes (Node).Right := - Source.Content.Nodes (Node).Right; - Target.Content.Nodes (Node).Color := - Source.Content.Nodes (Node).Color; - Target.Content.Nodes (Node).Has_Element := - Source.Content.Nodes (Node).Has_Element; - Node := Node + 1; - end loop; - - while Node <= Target.Capacity loop - N := Node; - Free (Tree => Target, X => N); - Node := Node + 1; - end loop; - end if; - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Position : in out Cursor) is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Delete has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "Position cursor of Delete is bad"); - - Tree_Operations.Delete_Node_Sans_Free (Container.Content, - Position.Node); - Free (Container, Position.Node); - Position := No_Element; - end Delete; - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : constant Node_Access := Key_Ops.Find (Container.Content, Key); - - begin - if X = 0 then - raise Constraint_Error with "key not in map"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Map) is - X : constant Node_Access := First (Container).Node; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Map) is - X : constant Node_Access := Last (Container).Node; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element (Container : Map; Position : Cursor) return Element_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of function Element has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "Position cursor of function Element is bad"); - - return Container.Content.Nodes (Position.Node).Element; - - end Element; - - function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - return Container.Content.Nodes (Node).Element; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : constant Node_Access := Key_Ops.Find (Container.Content, Key); - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Find (Container.Content, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - begin - if Length (Container) = 0 then - return No_Element; - end if; - - return (Node => Container.Content.First); - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Map) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Content.Nodes (First (Container).Node).Element; - end First_Element; - - --------------- - -- First_Key -- - --------------- - - function First_Key (Container : Map) return Key_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Content.Nodes (First (Container).Node).Key; - end First_Key; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Floor (Container.Content, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Floor; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ---------- - -- Find -- - ---------- - - function Find - (Container : K.Sequence; - Key : Key_Type) return Count_Type - is - begin - for I in 1 .. K.Length (Container) loop - if Equivalent_Keys (Key, K.Get (Container, I)) then - return I; - elsif Key < K.Get (Container, I) then - return 0; - end if; - end loop; - return 0; - end Find; - - ------------------------- - -- K_Bigger_Than_Range -- - ------------------------- - - function K_Bigger_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (K.Get (Container, I) < Key) then - return False; - end if; - end loop; - return True; - end K_Bigger_Than_Range; - - --------------- - -- K_Is_Find -- - --------------- - - function K_Is_Find - (Container : K.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - is - begin - for I in 1 .. Position - 1 loop - if Key < K.Get (Container, I) then - return False; - end if; - end loop; - - if Position < K.Length (Container) then - for I in Position + 1 .. K.Length (Container) loop - if K.Get (Container, I) < Key then - return False; - end if; - end loop; - end if; - return True; - end K_Is_Find; - - -------------------------- - -- K_Smaller_Than_Range -- - -------------------------- - - function K_Smaller_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Key < K.Get (Container, I)) then - return False; - end if; - end loop; - return True; - end K_Smaller_Than_Range; - - ---------- - -- Keys -- - ---------- - - function Keys (Container : Map) return K.Sequence is - Position : Count_Type := Container.Content.First; - R : K.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := K.Add (R, Container.Content.Nodes (Position).Key); - Position := Tree_Operations.Next (Container.Content, Position); - end loop; - - return R; - end Keys; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Map) is null; - - ----------- - -- Model -- - ----------- - - function Model (Container : Map) return M.Map is - Position : Count_Type := Container.Content.First; - R : M.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - New_Key => Container.Content.Nodes (Position).Key, - New_Item => Container.Content.Nodes (Position).Element); - - Position := Tree_Operations.Next (Container.Content, Position); - end loop; - - return R; - end Model; - - ------------------------- - -- 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; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Map) return P.Map is - I : Count_Type := 1; - Position : Count_Type := Container.Content.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) = Big (I)); - Position := Tree_Operations.Next (Container.Content, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free - (Tree : in out Map; - X : Count_Type) - is - begin - Tree.Content.Nodes (X).Has_Element := False; - Tree_Operations.Free (Tree.Content, X); - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type) - is - procedure Allocate is - new Tree_Operations.Generic_Allocate (Set_Element); - begin - Allocate (Tree, Node); - Tree.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Map; Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return False; - end if; - - return Container.Content.Nodes (Position.Node).Has_Element; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - declare - N : Node_Type renames Container.Content.Nodes (Position.Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end if; - end Include; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node return Node_Access; - -- Comment ??? - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - procedure Initialize (Node : in out Node_Type); - procedure Allocate_Node is new Generic_Allocate (Initialize); - - procedure Initialize (Node : in out Node_Type) is - begin - Node.Key := Key; - Node.Element := New_Item; - end Initialize; - - X : Node_Access; - - begin - Allocate_Node (Container.Content, X); - return X; - end New_Node; - - -- Start of processing for Insert - - begin - Insert_Sans_Hint - (Container.Content, - Key, - Position.Node, - Inserted); - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error with "key already in map"; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - -- k > node same as node < k - - return Right.Key < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Right.Key; - end Is_Less_Key_Node; - - --------- - -- Key -- - --------- - - function Key (Container : Map; Position : Cursor) return Key_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of function Key has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "Position cursor of function Key is bad"); - - return Container.Content.Nodes (Position.Node).Key; - end Key; - - ---------- - -- Last -- - ---------- - - function Last (Container : Map) return Cursor is - begin - if Length (Container) = 0 then - return No_Element; - end if; - - return (Node => Container.Content.Last); - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Map) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Content.Nodes (Last (Container).Node).Element; - end Last_Element; - - -------------- - -- Last_Key -- - -------------- - - function Last_Key (Container : Map) return Key_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Content.Nodes (Last (Container).Node).Key; - end Last_Key; - - -------------- - -- Left_Son -- - -------------- - - function Left_Son (Node : Node_Type) return Count_Type is - begin - return Node.Left; - end Left_Son; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.Content.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Map; Source : in out Map) is - NN : Tree_Types.Nodes_Type renames Source.Content.Nodes; - X : Node_Access; - - 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"; - end if; - - Clear (Target); - - loop - X := First (Source).Node; - exit when X = 0; - - -- Here we insert a copy of the source element into the target, and - -- then delete the element from the source. Another possibility is - -- that delete it first (and hang onto its index), then insert it. - -- ??? - - Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? - - Tree_Operations.Delete_Node_Sans_Free (Source.Content, X); - Formal_Ordered_Maps.Free (Source, X); - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Container : Map; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - function Next (Container : Map; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Next"); - - return (Node => Tree_Operations.Next (Container.Content, Position.Node)); - end Next; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Type) return Count_Type is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Container : Map; Position : in out Cursor) is - begin - Position := Previous (Container, Position); - end Previous; - - function Previous (Container : Map; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Previous"); - - declare - Node : constant Count_Type := - Tree_Operations.Previous (Container.Content, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - end Previous; - - -------------- - -- Reference -- - -------------- - - function Reference - (Container : not null access Map; - 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; - - pragma Assert - (Vet (Container.Content, Position.Node), - "bad cursor in function Reference"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Reference; - - function Reference - (Container : not null access Map; - Key : Key_Type) return not null access Element_Type - is - Node : constant Count_Type := Find (Container.all, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Content.Nodes (Node).Element'Access; - end Reference; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - begin - declare - Node : constant Node_Access := Key_Ops.Find (Container.Content, Key); - - begin - if Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - declare - N : Node_Type renames Container.Content.Nodes (Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Replace_Element has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "Position cursor of Replace_Element is bad"); - - Container.Content.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - --------------- - -- Right_Son -- - --------------- - - function Right_Son (Node : Node_Type) return Count_Type is - begin - return Node.Right; - end Right_Son; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color (Node : in out Node_Type; Color : Color_Type) is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is - begin - Node.Right := Right; - end Set_Right; - -end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/libgnat/a-cforma.ads b/gcc/ada/libgnat/a-cforma.ads index 7be2eec..21a5d78 100644 --- a/gcc/ada/libgnat/a-cforma.ads +++ b/gcc/ada/libgnat/a-cforma.ads @@ -29,1124 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- This spec is derived from package Ada.Containers.Bounded_Ordered_Maps in --- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- content of a container: Key, Element, Next, Query_Element, Previous, --- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the --- need to have cursors which are valid on different containers (typically a --- container C and its previous version C'Old) for expressing properties, --- which is not possible if cursors encapsulate an access to the underlying --- container. The operators "<" and ">" that could not be modified that way --- have been removed. - --- Iteration over maps is done using the Iterable aspect, which is SPARK --- compatible. "For of" iteration ranges over keys instead of elements. - -with Ada.Containers.Functional_Vectors; -with Ada.Containers.Functional_Maps; -private with Ada.Containers.Red_Black_Trees; - generic - type Key_Type is private; - type Element_Type is private; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Formal_Ordered_Maps with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -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); - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean with - Global => null, - Post => - Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys); - - type Map (Capacity : Count_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Key), - Default_Initial_Condition => Is_Empty (Map); - pragma Preelaborable_Initialization (Map); - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - Empty_Map : constant Map; - - function Length (Container : Map) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - 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_Maps - (Element_Type => Element_Type, - Key_Type => Key_Type, - Equivalent_Keys => Equivalent_Keys); - - function "=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."="; - - function "<=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."<="; - - package K is new Ada.Containers.Functional_Vectors - (Element_Type => Key_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."="; - - function "<" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<"; - - function "<=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<="; - - function K_Bigger_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= K.Length (Container), - Post => - K_Bigger_Than_Range'Result = - (for all I in Fst .. Lst => K.Get (Container, I) < Key); - pragma Annotate (GNATprove, Inline_For_Proof, K_Bigger_Than_Range); - - function K_Smaller_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= K.Length (Container), - Post => - K_Smaller_Than_Range'Result = - (for all I in Fst .. Lst => Key < K.Get (Container, I)); - pragma Annotate (GNATprove, Inline_For_Proof, K_Smaller_Than_Range); - - function K_Is_Find - (Container : K.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - with - Global => null, - Pre => Position - 1 <= K.Length (Container), - Post => - K_Is_Find'Result = - ((if Position > 0 then - K_Bigger_Than_Range (Container, 1, Position - 1, Key)) - - and - (if Position < K.Length (Container) then - K_Smaller_Than_Range - (Container, - Position + 1, - K.Length (Container), - Key))); - pragma Annotate (GNATprove, Inline_For_Proof, K_Is_Find); - - function Find (Container : K.Sequence; Key : Key_Type) return Count_Type - -- Search for Key in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= K.Length (Container) - and Equivalent_Keys (Key, K.Get (Container, Find'Result))); - - 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 Model (Container : Map) return M.Map with - -- The high-level model of a map is a map from keys to elements. Neither - -- cursors nor order of elements are represented in this model. Keys are - -- modeled up to equivalence. - - Ghost, - Global => null; - - function Keys (Container : Map) return K.Sequence with - -- The Keys sequence represents the underlying list structure of maps - -- that is used for iteration. It stores the actual values of keys in - -- the map. It does not model cursors nor elements. - - Ghost, - Global => null, - Post => - K.Length (Keys'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Key of Keys'Result => - M.Has_Key (Model (Container), Key)) - - -- It contains all the keys contained in Model - - and (for all Key of Model (Container) => - (Find (Keys'Result, Key) > 0 - and then Equivalent_Keys - (K.Get (Keys'Result, Find (Keys'Result, Key)), - Key))) - - -- It is sorted in increasing order - - and (for all I in 1 .. Length (Container) => - Find (Keys'Result, K.Get (Keys'Result, I)) = I - and K_Is_Find (Keys'Result, K.Get (Keys'Result, I), I)); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys); - - function Positions (Container : Map) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps 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 : Map) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access 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 Key of Keys (Container) => - (for some I of Positions (Container) => - K.Get (Keys (Container), P.Get (Positions (Container), I)) = - Key)); - - function Contains - (C : M.Map; - K : Key_Type) return Boolean renames M.Has_Key; - -- To improve readability of contracts, we rename the function used to - -- search for a key in the model to Contains. - - function Element - (C : M.Map; - K : Key_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 : Map) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function Is_Empty (Container : Map) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Map) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - - procedure Assign (Target : in out Map; Source : Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Keys (Target) = Keys (Source) - and Length (Source) = Length (Target); - - function Copy (Source : Map; Capacity : Count_Type := 0) return Map with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Keys (Copy'Result) = Keys (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - - function Key (Container : Map; Position : Cursor) return Key_Type with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Key'Result = - K.Get (Keys (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element - (Container : Map; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = Element (Model (Container), Key (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - - -- Order of keys and cursors is preserved - - Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old - - -- New_Item is now associated with the key at position Position in - -- Container. - - and Element (Container, Position) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key (Container, Position)); - - function At_End - (E : not null access constant Map) return not null access constant Map - 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 : aliased Map; - 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), Key (Container, Position)); - - function Reference - (Container : not null access Map; - Position : Cursor) return not null access Element_Type - with - Global => null, - Pre => Has_Element (Container.all, Position), - Post => - - -- Order of keys and cursors is preserved - - Keys (At_End (Container).all) = Keys (Container.all) - and Positions (At_End (Container).all) = Positions (Container.all) - - -- The value designated by the result of Reference is now associated - -- with the key at position Position in Container. - - and Element (At_End (Container).all, Position) = - At_End (Reference'Result).all - - -- Elements associated with other keys are preserved - - and M.Same_Keys - (Model (At_End (Container).all), - Model (Container.all)) - and M.Elements_Equal_Except - (Model (At_End (Container).all), - Model (Container.all), - Key (At_End (Container).all, Position)); - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return not null access constant Element_Type - with - Global => null, - Pre => Contains (Container, Key), - Post => - Constant_Reference'Result.all = Element (Model (Container), Key); - - function Reference - (Container : not null access Map; - Key : Key_Type) return not null access Element_Type - with - Global => null, - Pre => Contains (Container.all, Key), - Post => - - -- Order of keys and cursors is preserved - - Keys (At_End (Container).all) = Keys (Container.all) - and Positions (At_End (Container).all) = Positions (Container.all) - - -- The value designated by the result of Reference is now associated - -- with Key in Container. - - and Element (Model (At_End (Container).all), Key) = - At_End (Reference'Result).all - - -- Elements associated with other keys are preserved - - and M.Same_Keys - (Model (At_End (Container).all), - Model (Container.all)) - and M.Elements_Equal_Except - (Model (At_End (Container).all), - Model (Container.all), - Key); - - procedure Move (Target : in out Map; Source : in out Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source)'Old - and Keys (Target) = Keys (Source)'Old - and Length (Source)'Old = Length (Target) - and Length (Source) = 0; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) - and Has_Element (Container, Position) - and Equivalent_Keys - (Formal_Ordered_Maps.Key (Container, Position), Key) - and K_Is_Find - (Keys (Container), - Key, - P.Get (Positions (Container), Position)), - Contract_Cases => - - -- If Key is already in Container, it is not modified and Inserted is - -- set to False. - - (Contains (Container, Key) => - not Inserted - and Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is inserted in Container and Inserted is set to True - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Key now maps to New_Item - - and Formal_Ordered_Maps.Key (Container, Position) = Key - and Element (Model (Container), Key) = New_Item - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- The keys of Container located before Position are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => 1) - - -- 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 Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (not Contains (Container, Key)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, Key) - - -- Key now maps to New_Item - - and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key - and Element (Model (Container), Key) = New_Item - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key) - 1) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => Find (Keys (Container), Key), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Keys (Container), Key)); - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) and Element (Container, Key) = New_Item, - Contract_Cases => - - -- If Key is already in Container, Key is mapped to New_Item - - (Contains (Container, Key) => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get - (Keys (Container), Find (Keys (Container), Key)) = Key - - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - Find (Keys (Container), Key)) - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key), - - -- Otherwise, Key is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Key is inserted in Container - - and K.Get - (Keys (Container), Find (Keys (Container), Key)) = Key - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key) - 1) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => Find (Keys (Container), Key), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Keys (Container), Key))); - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - Find (Keys (Container), Key)) - - -- New_Item is now associated with the Key in Container - - and Element (Model (Container), Key) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key); - - procedure Exclude (Container : in out Map; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key)'Old - 1) - - -- The keys located after Key are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (Container)'Old, - Fst => Find (Keys (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Keys (Container), Key)'Old)); - - procedure Delete (Container : in out Map; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key)'Old - 1) - - -- The keys located after Key are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (Container)'Old, - Fst => Find (Keys (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Keys (Container), Key)'Old); - - procedure Delete (Container : in out Map; Position : in out Cursor) with - Global => null, - Depends => (Container =>+ Position, Position => null), - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The key at position Position is no longer in Container - - and not Contains (Container, Key (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key (Container, Position)'Old) - - -- The keys of Container located before Position are preserved. - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) - - -- The keys located after Position are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (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_First (Container : in out Map) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The first key has been removed from Container - - and not Contains (Container, First_Key (Container)'Old) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - First_Key (Container)'Old) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => 1) - - -- First has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1)); - - procedure Delete_Last (Container : in out Map) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The last key has been removed from Container - - and not Contains (Container, Last_Key (Container)'Old) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Last_Key (Container)'Old) - - -- Others keys of Container are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Length (Container)) - - -- Last cursor has been removed from Container - - and Positions (Container) <= Positions (Container)'Old); - - function First (Container : Map) 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 : Map) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = - Element (Model (Container), First_Key (Container)); - - function First_Key (Container : Map) return Key_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Key'Result = K.Get (Keys (Container), 1) - and K_Smaller_Than_Range - (Keys (Container), 2, Length (Container), First_Key'Result); - - function Last (Container : Map) 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 : Map) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = Element (Model (Container), Last_Key (Container)); - - function Last_Key (Container : Map) return Key_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Key'Result = K.Get (Keys (Container), Length (Container)) - and K_Bigger_Than_Range - (Keys (Container), 1, Length (Container) - 1, Last_Key'Result); - - function Next (Container : Map; 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 : Map; 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 : Map; 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 : Map; 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 : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Key) => - not P.Has_Key (Positions (Container), Find'Result) - and Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Keys (Container), Key) - - -- The key designated by the result of Find is Key - - and Equivalent_Keys - (Formal_Ordered_Maps.Key (Container, Find'Result), Key)); - - function Element (Container : Map; Key : Key_Type) return Element_Type with - Global => null, - Pre => Contains (Container, Key), - Post => Element'Result = Element (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - function Floor (Container : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Key < First_Key (Container) => - Floor'Result = No_Element, - - others => - Has_Element (Container, Floor'Result) - and not (Key < K.Get (Keys (Container), - P.Get (Positions (Container), Floor'Result))) - and K_Is_Find - (Keys (Container), - Key, - P.Get (Positions (Container), Floor'Result))); - - function Ceiling (Container : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Last_Key (Container) < Key => - Ceiling'Result = No_Element, - others => - Has_Element (Container, Ceiling'Result) - and not (K.Get - (Keys (Container), - P.Get (Positions (Container), Ceiling'Result)) < Key) - and K_Is_Find - (Keys (Container), - Key, - P.Get (Positions (Container), Ceiling'Result))); - - function Contains (Container : Map; Key : Key_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Has_Element (Container : Map; 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); - -private - pragma SPARK_Mode (Off); - - pragma Inline (Next); - pragma Inline (Previous); - - subtype Node_Access is Count_Type; - - use Red_Black_Trees; - - type Node_Type is record - Has_Element : Boolean := False; - Parent : Node_Access := 0; - Left : Node_Access := 0; - Right : Node_Access := 0; - Color : Red_Black_Trees.Color_Type := Red; - Key : Key_Type; - Element : aliased Element_Type; - end record; - - package Tree_Types is - new Ada.Containers.Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); - - type Map (Capacity : Count_Type) is record - Content : Tree_Types.Tree_Type (Capacity); - end record; +package Ada.Containers.Formal_Ordered_Maps with SPARK_Mode is - Empty_Map : constant Map := (Capacity => 0, others => <>); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/libgnat/a-cforse.adb b/gcc/ada/libgnat/a-cforse.adb deleted file mode 100644 index e5cddde..0000000 --- a/gcc/ada/libgnat/a-cforse.adb +++ /dev/null @@ -1,1939 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); - -with System; use type System.Address; - -package body Ada.Containers.Formal_Ordered_Sets with - SPARK_Mode => Off -is - - ------------------------------ - -- Access to Fields of Node -- - ------------------------------ - - -- These subprograms provide functional notation for access to fields - -- of a node, and procedural notation for modifiying these fields. - - function Color (Node : Node_Type) return Red_Black_Trees.Color_Type; - pragma Inline (Color); - - function Left_Son (Node : Node_Type) return Count_Type; - pragma Inline (Left_Son); - - function Parent (Node : Node_Type) return Count_Type; - pragma Inline (Parent); - - function Right_Son (Node : Node_Type) return Count_Type; - pragma Inline (Right_Son); - - procedure Set_Color - (Node : in out Node_Type; - Color : Red_Black_Trees.Color_Type); - pragma Inline (Set_Color); - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type); - pragma Inline (Set_Left); - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type); - pragma Inline (Set_Right); - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); - pragma Inline (Set_Parent); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- Comments needed??? - - procedure Assign - (Target : in out Tree_Types.Tree_Type; - Source : Tree_Types.Tree_Type); - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type); - - procedure Free (Tree : in out Set; X : Count_Type); - - procedure Insert_Sans_Hint - (Container : in out Tree_Types.Tree_Type; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean); - - procedure Insert_With_Hint - (Dst_Set : in out Tree_Types.Tree_Type; - Dst_Hint : Count_Type; - Src_Node : Node_Type; - Dst_Node : out Count_Type); - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Element_Node); - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Element_Node); - - function Is_Less_Node_Node (L, R : Node_Type) return Boolean; - pragma Inline (Is_Less_Node_Node); - - procedure Replace_Element - (Tree : in out Set; - Node : Count_Type; - Item : Element_Type); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Bounded_Operations - (Tree_Types, - Left => Left_Son, - Right => Right_Son); - - use Tree_Operations; - - package Element_Keys is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Element_Type, - Is_Less_Key_Node => Is_Less_Element_Node, - Is_Greater_Key_Node => Is_Greater_Element_Node); - - package Set_Ops is - new Red_Black_Trees.Generic_Bounded_Set_Operations - (Tree_Operations => Tree_Operations, - Set_Type => Tree_Types.Tree_Type, - Assign => Assign, - Insert_With_Hint => Insert_With_Hint, - Is_Less => Is_Less_Node_Node); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - Lst : Count_Type; - Node : Count_Type; - ENode : Count_Type; - - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Is_Empty (Left) then - return True; - end if; - - Lst := Next (Left.Content, Last (Left).Node); - - Node := First (Left).Node; - while Node /= Lst loop - ENode := Find (Right, Left.Content.Nodes (Node).Element).Node; - if ENode = 0 - or else Left.Content.Nodes (Node).Element /= - Right.Content.Nodes (ENode).Element - then - return False; - end if; - - Node := Next (Left.Content, Node); - end loop; - - return True; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign - (Target : in out Tree_Types.Tree_Type; - Source : Tree_Types.Tree_Type) - is - procedure Append_Element (Source_Node : Count_Type); - - procedure Append_Elements is - new Tree_Operations.Generic_Iteration (Append_Element); - - -------------------- - -- Append_Element -- - -------------------- - - procedure Append_Element (Source_Node : Count_Type) is - SN : Node_Type renames Source.Nodes (Source_Node); - - procedure Set_Element (Node : in out Node_Type); - pragma Inline (Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert_Sans_Hint is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - procedure Unconditional_Insert_Avec_Hint is - new Element_Keys.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Unconditional_Insert_Sans_Hint); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Target, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := SN.Element; - end Set_Element; - - -- Local variables - - Target_Node : Count_Type; - - -- Start of processing for Append_Element - - begin - Unconditional_Insert_Avec_Hint - (Tree => Target, - Hint => 0, - Key => SN.Element, - Node => Target_Node); - end Append_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error - with "Target capacity is less than Source length"; - end if; - - Tree_Operations.Clear_Tree (Target); - Append_Elements (Source); - end Assign; - - procedure Assign (Target : in out Set; Source : Set) is - begin - Assign (Target.Content, Source.Content); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Item : Element_Type) return Cursor is - Node : constant Count_Type := - Element_Keys.Ceiling (Container.Content, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Set) is - begin - Tree_Operations.Clear_Tree (Container.Content); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return not null access constant 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.Content, Position.Node), - "bad cursor in Element"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Set; Capacity : Count_Type := 0) return Set is - Node : Count_Type; - N : Count_Type; - Target : Set (Count_Type'Max (Source.Capacity, Capacity)); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - if Length (Source) > 0 then - Target.Content.Length := Source.Content.Length; - Target.Content.Root := Source.Content.Root; - Target.Content.First := Source.Content.First; - Target.Content.Last := Source.Content.Last; - Target.Content.Free := Source.Content.Free; - - Node := 1; - while Node <= Source.Capacity loop - Target.Content.Nodes (Node).Element := - Source.Content.Nodes (Node).Element; - Target.Content.Nodes (Node).Parent := - Source.Content.Nodes (Node).Parent; - Target.Content.Nodes (Node).Left := - Source.Content.Nodes (Node).Left; - Target.Content.Nodes (Node).Right := - Source.Content.Nodes (Node).Right; - Target.Content.Nodes (Node).Color := - Source.Content.Nodes (Node).Color; - Target.Content.Nodes (Node).Has_Element := - Source.Content.Nodes (Node).Has_Element; - Node := Node + 1; - end loop; - - while Node <= Target.Capacity loop - N := Node; - Free (Tree => Target, X => N); - Node := Node + 1; - end loop; - end if; - - return Target; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Position : in out Cursor) is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Delete"); - - Tree_Operations.Delete_Node_Sans_Free (Container.Content, - Position.Node); - Free (Container, Position.Node); - Position := No_Element; - end Delete; - - procedure Delete (Container : in out Set; Item : Element_Type) is - X : constant Count_Type := Element_Keys.Find (Container.Content, Item); - - begin - if X = 0 then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Set) is - X : constant Count_Type := Container.Content.First; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Set) is - X : constant Count_Type := Container.Content.Last; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Delete_Last; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Difference (Target.Content, Source.Content); - end Difference; - - function Difference (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Length (Left) = 0 then - return Empty_Set; - end if; - - if Length (Right) = 0 then - return Copy (Left); - end if; - - return S : Set (Length (Left)) do - Assign - (S.Content, Set_Ops.Set_Difference (Left.Content, Right.Content)); - end return; - end Difference; - - ------------- - -- Element -- - ------------- - - function Element (Container : Set; Position : Cursor) return 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.Content, Position.Node), - "bad cursor in Element"); - - return Container.Content.Nodes (Position.Node).Element; - end Element; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Elements; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - function Is_Equivalent_Node_Node - (L, R : Node_Type) return Boolean; - pragma Inline (Is_Equivalent_Node_Node); - - function Is_Equivalent is - new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); - - ----------------------------- - -- Is_Equivalent_Node_Node -- - ----------------------------- - - function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is - begin - if L.Element < R.Element then - return False; - elsif R.Element < L.Element then - return False; - else - return True; - end if; - end Is_Equivalent_Node_Node; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left.Content, Right.Content); - end Equivalent_Sets; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Item : Element_Type) is - X : constant Count_Type := Element_Keys.Find (Container.Content, Item); - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Item : Element_Type) return Cursor is - Node : constant Count_Type := - Element_Keys.Find (Container.Content, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - begin - if Length (Container) = 0 then - return No_Element; - end if; - - return (Node => Container.Content.First); - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Set) return Element_Type is - Fst : constant Count_Type := First (Container).Node; - begin - if Fst = 0 then - raise Constraint_Error with "set is empty"; - end if; - - declare - N : Tree_Types.Nodes_Type renames Container.Content.Nodes; - begin - return N (Fst).Element; - end; - end First_Element; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Item : Element_Type) return Cursor is - begin - declare - Node : constant Count_Type := - Element_Keys.Floor (Container.Content, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - end Floor; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- E_Bigger_Than_Range -- - ------------------------- - - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (E.Get (Container, I) < Item) then - return False; - end if; - end loop; - - return True; - end E_Bigger_Than_Range; - - ------------------------- - -- E_Elements_Included -- - ------------------------- - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I)) - then - return False; - end if; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - declare - Item : constant Element_Type := E.Get (Left, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Container) loop - declare - Item : constant Element_Type := E.Get (Container, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Left, 1, E.Length (Left), Item) then - return False; - end if; - else - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - --------------- - -- E_Is_Find -- - --------------- - - function E_Is_Find - (Container : E.Sequence; - Item : Element_Type; - Position : Count_Type) return Boolean - is - begin - for I in 1 .. Position - 1 loop - if Item < E.Get (Container, I) then - return False; - end if; - end loop; - - if Position < E.Length (Container) then - for I in Position + 1 .. E.Length (Container) loop - if E.Get (Container, I) < Item then - return False; - end if; - end loop; - end if; - - return True; - end E_Is_Find; - - -------------------------- - -- E_Smaller_Than_Range -- - -------------------------- - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Item < E.Get (Container, I)) then - return False; - end if; - end loop; - - return True; - end E_Smaller_Than_Range; - - ---------- - -- Find -- - ---------- - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - is - begin - for I in 1 .. E.Length (Container) loop - if Equivalent_Elements (Item, E.Get (Container, I)) then - return I; - end if; - end loop; - - return 0; - end Find; - - -------------- - -- Elements -- - -------------- - - function Elements (Container : Set) return E.Sequence is - Position : Count_Type := Container.Content.First; - R : E.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := E.Add (R, Container.Content.Nodes (Position).Element); - Position := Tree_Operations.Next (Container.Content, Position); - end loop; - - return R; - end Elements; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Set) is null; - - ----------------------- - -- Mapping_Preserved -- - ----------------------- - - function Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.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) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ------------------------------ - -- Mapping_Preserved_Except -- - ------------------------------ - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - is - begin - for C of P_Left loop - if C /= Position - and (not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C))) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved_Except; - - ------------------------- - -- 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; - - ----------- - -- Model -- - ----------- - - function Model (Container : Set) return M.Set is - Position : Count_Type := Container.Content.First; - R : M.Set; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - Item => Container.Content.Nodes (Position).Element); - - Position := Tree_Operations.Next (Container.Content, Position); - end loop; - - return R; - end Model; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Set) return P.Map is - I : Count_Type := 1; - Position : Count_Type := Container.Content.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) = Big (I)); - Position := Tree_Operations.Next (Container.Content, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (Tree : in out Set; X : Count_Type) is - begin - Tree.Content.Nodes (X).Has_Element := False; - Tree_Operations.Free (Tree.Content, X); - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type) - is - procedure Allocate is - new Tree_Operations.Generic_Allocate (Set_Element); - begin - Allocate (Tree, Node); - Tree.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - ------------------ - -- Generic_Keys -- - ------------------ - - package body Generic_Keys with SPARK_Mode => Off is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := - Key_Keys.Ceiling (Container.Content, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Ceiling; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Key : Key_Type) is - X : constant Count_Type := Key_Keys.Find (Container.Content, Key); - - begin - if X = 0 then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Count_Type := Key_Keys.Find (Container.Content, Key); - - begin - if Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - declare - N : Tree_Types.Nodes_Type renames Container.Content.Nodes; - begin - return N (Node).Element; - end; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Key : Key_Type) is - X : constant Count_Type := Key_Keys.Find (Container.Content, Key); - begin - if X /= 0 then - Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Keys.Find (Container.Content, Key); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end Find; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Keys.Floor (Container.Content, Key); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end Floor; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- E_Bigger_Than_Range -- - ------------------------- - - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Generic_Keys.Key (E.Get (Container, I)) < Key) then - return False; - end if; - end loop; - return True; - end E_Bigger_Than_Range; - - --------------- - -- E_Is_Find -- - --------------- - - function E_Is_Find - (Container : E.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - is - begin - for I in 1 .. Position - 1 loop - if Key < Generic_Keys.Key (E.Get (Container, I)) then - return False; - end if; - end loop; - - if Position < E.Length (Container) then - for I in Position + 1 .. E.Length (Container) loop - if Generic_Keys.Key (E.Get (Container, I)) < Key then - return False; - end if; - end loop; - end if; - return True; - end E_Is_Find; - - -------------------------- - -- E_Smaller_Than_Range -- - -------------------------- - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Key < Generic_Keys.Key (E.Get (Container, I))) then - return False; - end if; - end loop; - return True; - end E_Smaller_Than_Range; - - ---------- - -- Find -- - ---------- - - function Find - (Container : E.Sequence; - Key : Key_Type) return Count_Type - is - begin - for I in 1 .. E.Length (Container) loop - if Equivalent_Keys - (Key, Generic_Keys.Key (E.Get (Container, I))) - then - return I; - end if; - end loop; - return 0; - end Find; - - ----------------------- - -- M_Included_Except -- - ----------------------- - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - is - begin - for E of Left loop - if not Contains (Right, E) - and not Equivalent_Keys (Generic_Keys.Key (E), Key) - then - return False; - end if; - end loop; - return True; - end M_Included_Except; - end Formal_Model; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Key (Right.Element) < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Key (Right.Element); - end Is_Less_Key_Node; - - --------- - -- Key -- - --------- - - function Key (Container : Set; Position : Cursor) return Key_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.Content, Position.Node), - "bad cursor in Key"); - - declare - N : Tree_Types.Nodes_Type renames Container.Content.Nodes; - begin - return Key (N (Position.Node).Element); - end; - end Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Keys.Find (Container.Content, Key); - begin - if not Has_Element (Container, (Node => Node)) then - raise Constraint_Error with - "attempt to replace key not in set"; - else - Replace_Element (Container, Node, New_Item); - end if; - end Replace; - - end Generic_Keys; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Set; Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return False; - else - return Container.Content.Nodes (Position.Node).Has_Element; - end if; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include (Container : in out Set; New_Item : Element_Type) is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - declare - N : Tree_Types.Nodes_Type renames Container.Content.Nodes; - begin - N (Position.Node).Element := New_Item; - end; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert_Sans_Hint (Container.Content, New_Item, Position.Node, Inserted); - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - ---------------------- - -- Insert_Sans_Hint -- - ---------------------- - - procedure Insert_Sans_Hint - (Container : in out Tree_Types.Tree_Type; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - procedure Set_Element (Node : in out Node_Type); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Conditional_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := New_Item; - end Set_Element; - - -- Start of processing for Insert_Sans_Hint - - begin - Conditional_Insert_Sans_Hint - (Container, - New_Item, - Node, - Inserted); - end Insert_Sans_Hint; - - ---------------------- - -- Insert_With_Hint -- - ---------------------- - - procedure Insert_With_Hint - (Dst_Set : in out Tree_Types.Tree_Type; - Dst_Hint : Count_Type; - Src_Node : Node_Type; - Dst_Node : out Count_Type) - is - Success : Boolean; - - procedure Set_Element (Node : in out Node_Type); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Insert_Post, Insert_Sans_Hint); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Dst_Set, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := Src_Node.Element; - end Set_Element; - - -- Start of processing for Insert_With_Hint - - begin - Local_Insert_With_Hint - (Dst_Set, - Dst_Hint, - Src_Node.Element, - Dst_Node, - Success); - end Insert_With_Hint; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Intersection (Target.Content, Source.Content); - end Intersection; - - function Intersection (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Copy (Left); - end if; - - return S : Set (Count_Type'Min (Length (Left), Length (Right))) do - Assign (S.Content, - Set_Ops.Set_Intersection (Left.Content, Right.Content)); - end return; - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ----------------------------- - -- Is_Greater_Element_Node -- - ----------------------------- - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean - is - begin - -- Compute e > node same as node < e - - return Right.Element < Left; - end Is_Greater_Element_Node; - - -------------------------- - -- Is_Less_Element_Node -- - -------------------------- - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Right.Element; - end Is_Less_Element_Node; - - ----------------------- - -- Is_Less_Node_Node -- - ----------------------- - - function Is_Less_Node_Node (L, R : Node_Type) return Boolean is - begin - return L.Element < R.Element; - end Is_Less_Node_Node; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - begin - return Set_Ops.Set_Subset (Subset.Content, Of_Set => Of_Set.Content); - end Is_Subset; - - ---------- - -- Last -- - ---------- - - function Last (Container : Set) return Cursor is - begin - return (if Length (Container) = 0 - then No_Element - else (Node => Container.Content.Last)); - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Set) return Element_Type is - begin - if Last (Container).Node = 0 then - raise Constraint_Error with "set is empty"; - end if; - - declare - N : Tree_Types.Nodes_Type renames Container.Content.Nodes; - begin - return N (Last (Container).Node).Element; - end; - end Last_Element; - - -------------- - -- Left_Son -- - -------------- - - function Left_Son (Node : Node_Type) return Count_Type is - begin - return Node.Left; - end Left_Son; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Content.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Set; Source : in out Set) is - N : Tree_Types.Nodes_Type renames Source.Content.Nodes; - X : 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"; - end if; - - Clear (Target); - - loop - X := Source.Content.First; - exit when X = 0; - - Insert (Target, N (X).Element); -- optimize??? - - Tree_Operations.Delete_Node_Sans_Free (Source.Content, X); - Free (Source, X); - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Container : Set; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Next"); - return (Node => Tree_Operations.Next (Container.Content, Position.Node)); - end Next; - - procedure Next (Container : Set; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - begin - return Set_Ops.Set_Overlap (Left.Content, Right.Content); - end Overlap; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Type) return Count_Type is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - function Previous (Container : Set; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Previous"); - - declare - Node : constant Count_Type := - Tree_Operations.Previous (Container.Content, Position.Node); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end; - end Previous; - - procedure Previous (Container : Set; Position : in out Cursor) is - begin - Position := Previous (Container, Position); - end Previous; - - ------------- - -- Replace -- - ------------- - - procedure Replace (Container : in out Set; New_Item : Element_Type) is - Node : constant Count_Type := - Element_Keys.Find (Container.Content, New_Item); - - begin - if Node = 0 then - raise Constraint_Error with - "attempt to replace element not in set"; - end if; - - Container.Content.Nodes (Node).Element := New_Item; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Tree : in out Set; - Node : Count_Type; - Item : Element_Type) - is - pragma Assert (Node /= 0); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Local_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Local_Insert_Post, - Local_Insert_Sans_Hint); - - NN : Tree_Types.Nodes_Type renames Tree.Content.Nodes; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - N : Node_Type renames NN (Node); - begin - N.Element := Item; - N.Color := Red; - N.Parent := 0; - N.Right := 0; - N.Left := 0; - return Node; - end New_Node; - - Hint : Count_Type; - Result : Count_Type; - Inserted : Boolean; - - -- Start of processing for Insert - - begin - if Item < NN (Node).Element - or else NN (Node).Element < Item - then - null; - - else - NN (Node).Element := Item; - return; - end if; - - Hint := Element_Keys.Ceiling (Tree.Content, Item); - - if Hint = 0 then - null; - - elsif Item < NN (Hint).Element then - if Hint = Node then - NN (Node).Element := Item; - return; - end if; - - else - pragma Assert (not (NN (Hint).Element < Item)); - raise Program_Error with "attempt to replace existing element"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Tree.Content, Node); - - Local_Insert_With_Hint - (Tree => Tree.Content, - Position => Hint, - Key => Item, - Node => Result, - Inserted => Inserted); - - pragma Assert (Inserted); - pragma Assert (Result = Node); - end Replace_Element; - - procedure Replace_Element - (Container : in out Set; - 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.Content, Position.Node), - "bad cursor in Replace_Element"); - - Replace_Element (Container, Position.Node, New_Item); - end Replace_Element; - - --------------- - -- Right_Son -- - --------------- - - function Right_Son (Node : Node_Type) return Count_Type is - begin - return Node.Right; - end Right_Son; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color - (Node : in out Node_Type; - Color : Red_Black_Trees.Color_Type) - is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is - begin - Node.Right := Right; - end Set_Right; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Symmetric_Difference (Target.Content, Source.Content); - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Length (Right) = 0 then - return Copy (Left); - end if; - - if Length (Left) = 0 then - return Copy (Right); - end if; - - return S : Set (Length (Left) + Length (Right)) do - Assign - (S.Content, - Set_Ops.Set_Symmetric_Difference (Left.Content, Right.Content)); - end return; - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - Node : Count_Type; - Inserted : Boolean; - - begin - return S : Set (Capacity => 1) do - Insert_Sans_Hint (S.Content, New_Item, Node, Inserted); - pragma Assert (Inserted); - end return; - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Union (Target.Content, Source.Content); - end Union; - - function Union (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Copy (Left); - end if; - - if Length (Left) = 0 then - return Copy (Right); - end if; - - if Length (Right) = 0 then - return Copy (Left); - end if; - - return S : Set (Length (Left) + Length (Right)) do - Assign (S, Source => Left); - Union (S, Right); - end return; - end Union; - -end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/libgnat/a-cforse.ads b/gcc/ada/libgnat/a-cforse.ads index ff96d8e..fe5de2b 100644 --- a/gcc/ada/libgnat/a-cforse.ads +++ b/gcc/ada/libgnat/a-cforse.ads @@ -29,1785 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- This spec is derived from package Ada.Containers.Bounded_Ordered_Sets in --- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- content of a container: Key, Element, Next, Query_Element, Previous, --- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the --- need to have cursors which are valid on different containers (typically --- a container C and its previous version C'Old) for expressing properties, --- which is not possible if cursors encapsulate an access to the underlying --- container. The operators "<" and ">" that could not be modified that way --- have been removed. - -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 - type Element_Type is private; - - with function "<" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Formal_Ordered_Sets with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -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); - - -- 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, - Post => - Equivalent_Elements'Result = - (not (Left < Right) and not (Right < Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Elements); - - type Set (Capacity : Count_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Element), - Default_Initial_Condition => Is_Empty (Set); - pragma Preelaborable_Initialization (Set); - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - function Length (Container : Set) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - 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_Sets - (Element_Type => Element_Type, - Equivalent_Elements => Equivalent_Elements); - - function "=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."="; - - function "<=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."<="; - - package E is new Ada.Containers.Functional_Vectors - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."="; - - function "<" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<"; - - function "<=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<="; - - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Bigger_Than_Range'Result = - (for all I in Fst .. Lst => E.Get (Container, I) < Item); - pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range); - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Smaller_Than_Range'Result = - (for all I in Fst .. Lst => Item < E.Get (Container, I)); - pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range); - - function E_Is_Find - (Container : E.Sequence; - Item : Element_Type; - Position : Count_Type) return Boolean - with - Global => null, - Pre => Position - 1 <= E.Length (Container), - Post => - E_Is_Find'Result = - - ((if Position > 0 then - E_Bigger_Than_Range (Container, 1, Position - 1, Item)) - - and (if Position < E.Length (Container) then - E_Smaller_Than_Range - (Container, - Position + 1, - E.Length (Container), - Item))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find); - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - -- Search for Item in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= E.Length (Container) - and Equivalent_Elements (Item, E.Get (Container, Find'Result))); - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Left are contained in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I)); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - (if M.Contains (Model, E.Get (Left, I)) then - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Left and others - -- are in Right. - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Container) => - (if M.Contains (Model, E.Get (Container, I)) then - Find (Left, E.Get (Container, I)) > 0 - and then E.Get (Left, Find (Left, E.Get (Container, I))) = - E.Get (Container, I) - else - Find (Right, E.Get (Container, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Container, I))) = - E.Get (Container, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - 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 Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Right contains all the elements of Left - - and E_Elements_Included (E_Left, E_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same. - - and (for all C of P_Left => - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C)))); - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved_Except'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same except for Position. - - and (for all C of P_Left => - (if C /= Position then - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C))))); - - function Model (Container : Set) return M.Set with - -- The high-level model of a set is a set of elements. Neither cursors - -- nor order of elements are represented in this model. Elements are - -- modeled up to equivalence. - - Ghost, - Global => null, - 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 - -- sets that is used for iteration. It stores the actual values of - -- elements in the set. It does not model cursors. - - Ghost, - Global => null, - Post => - E.Length (Elements'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Item of Elements'Result => - M.Contains (Model (Container), Item)) - - -- It contains all the elements contained in Model - - and (for all Item of Model (Container) => - (Find (Elements'Result, Item) > 0 - and then Equivalent_Elements - (E.Get (Elements'Result, Find (Elements'Result, Item)), - Item))) - - -- It is sorted in increasing order - - and (for all I in 1 .. Length (Container) => - Find (Elements'Result, E.Get (Elements'Result, I)) = I - and - E_Is_Find - (Elements'Result, E.Get (Elements'Result, I), I)); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements); - - function Positions (Container : Set) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps 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 : Set) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access 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 Item of Elements (Container) => - (for some I of Positions (Container) => - E.Get (Elements (Container), P.Get (Positions (Container), I)) = - Item)); - - function Contains - (C : M.Set; - K : Element_Type) return Boolean renames M.Contains; - -- To improve readability of contracts, we rename the function used to - -- search for an element in the model to Contains. - - end Formal_Model; - use Formal_Model; - - Empty_Set : constant Set; - - function "=" (Left, Right : Set) return Boolean with - Global => null, - Post => - - -- If two sets are equal, they contain the same elements in the same - -- order. - - (if "="'Result then Elements (Left) = Elements (Right) - - -- If they are different, then they do not contain the same elements - - else - not E_Elements_Included (Elements (Left), Elements (Right)) - or not E_Elements_Included (Elements (Right), Elements (Left))); - - function Equivalent_Sets (Left, Right : Set) return Boolean with - Global => null, - Post => Equivalent_Sets'Result = (Model (Left) = Model (Right)); - - function To_Set (New_Item : Element_Type) return Set with - Global => null, - Post => - M.Is_Singleton (Model (To_Set'Result), New_Item) - and Length (To_Set'Result) = 1 - and E.Get (Elements (To_Set'Result), 1) = New_Item; - - function Is_Empty (Container : Set) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Set) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - - procedure Assign (Target : in out Set; Source : Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Elements (Target) = Elements (Source) - and Length (Target) = Length (Source); - - function Copy (Source : Set; Capacity : Count_Type := 0) return Set with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Elements (Copy'Result) = Elements (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - - function Element - (Container : Set; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = - E.Get (Elements (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Position) - and Positions (Container) = Positions (Container)'Old; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return not null access constant Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Constant_Reference'Result.all = - E.Get (Elements (Container), P.Get (Positions (Container), Position)); - - procedure Move (Target : in out Set; Source : in out Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source)'Old - and Elements (Target) = Elements (Source)'Old - and Length (Source)'Old = Length (Target) - and Length (Source) = 0; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => - Contains (Container, New_Item) - and Has_Element (Container, Position) - and Equivalent_Elements (Element (Container, Position), New_Item) - and E_Is_Find - (Elements (Container), - New_Item, - P.Get (Positions (Container), Position)), - Contract_Cases => - - -- If New_Item is already in Container, it is not modified and Inserted - -- is set to False. - - (Contains (Container, New_Item) => - not Inserted - and Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, New_Item is inserted in Container and Inserted is set to - -- True - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- The elements of Container located before Position are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => 1) - - -- 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 Set; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (not Contains (Container, New_Item)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, New_Item) - - -- New_Item is inserted in the set - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- The elements of Container located before New_Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), New_Item) - 1) - - -- Other elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => Find (Elements (Container), New_Item), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Elements (Container), New_Item)); - - procedure Include - (Container : in out Set; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => Contains (Container, New_Item), - Contract_Cases => - - -- If New_Item is already in Container - - (Contains (Container, New_Item) => - - -- Elements are preserved - - Model (Container)'Old = Model (Container) - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The element equivalent to New_Item in Container is replaced by - -- New_Item. - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - Find (Elements (Container), New_Item)), - - -- Otherwise, New_Item is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- New_Item is inserted in Container - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - - -- The Elements of Container located before New_Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), New_Item) - 1) - - -- Other Elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => Find (Elements (Container), New_Item), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Elements (Container), New_Item))); - - procedure Replace - (Container : in out Set; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, New_Item), - Post => - - -- Elements are preserved - - Model (Container)'Old = Model (Container) - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The element equivalent to New_Item in Container is replaced by - -- New_Item. - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - Find (Elements (Container), New_Item)); - - procedure Exclude - (Container : in out Set; - Item : Element_Type) - with - Global => null, - Post => not Contains (Container, Item), - Contract_Cases => - - -- If Item is not in Container, nothing is changed - - (not Contains (Container, Item) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Item is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- The elements of Container located before Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Item)'Old - 1) - - -- The elements located after Item are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Item)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Item)'Old)); - - procedure Delete - (Container : in out Set; - Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Item), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Item is no longer in Container - - and not Contains (Container, Item) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- The elements of Container located before Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Item)'Old - 1) - - -- The elements located after Item are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Item)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Item)'Old); - - procedure Delete - (Container : in out Set; - Position : in out Cursor) - with - Global => null, - Depends => (Container =>+ Position, Position => null), - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The element at position Position is no longer in Container - - and not Contains (Container, Element (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - - -- The elements of Container located before Position are preserved. - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) - - -- The elements located after Position are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (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_First (Container : in out Set) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The first element has been removed from Container - - and not Contains (Container, First_Element (Container)'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - First_Element (Container)'Old) - - -- Other elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => 1) - - -- First has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1)); - - procedure Delete_Last (Container : in out Set) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The last element has been removed from Container - - and not Contains (Container, Last_Element (Container)'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Last_Element (Container)'Old) - - -- Others elements of Container are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Length (Container)) - - -- Last cursor has been removed from Container - - and Positions (Container) <= Positions (Container)'Old); - - procedure Union (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target), - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - + Big (Length (Source)) - - -- Elements already in Target are still in Target - - and Model (Target)'Old <= Model (Target) - - -- Elements of Source are included in Target - - and Model (Source) <= Model (Target) - - -- Elements of Target come from either Source or Target - - and - M.Included_In_Union - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - and - E_Elements_Included - (Elements (Target)'Old, Model (Target)'Old, Elements (Target)) - and - E_Elements_Included - (Elements (Source), - Model (Target)'Old, - Elements (Source), - Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target)'Old, - E_Right => Elements (Target), - P_Left => Positions (Target)'Old, - P_Right => Positions (Target)); - - function Union (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Big (Length (Union'Result)) = Big (Length (Left)) - - M.Num_Overlaps (Model (Left), Model (Right)) - + Big (Length (Right)) - - -- Elements of Left and Right are in the result of Union - - and Model (Left) <= Model (Union'Result) - and Model (Right) <= Model (Union'Result) - - -- Elements of the result of union come from either Left or Right - - and - M.Included_In_Union - (Model (Union'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Union'Result), - Model (Left), - Elements (Left), - Elements (Right)) - and - E_Elements_Included - (Elements (Left), Model (Left), Elements (Union'Result)) - and - E_Elements_Included - (Elements (Right), - Model (Left), - Elements (Right), - Elements (Union'Result)); - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set) with - Global => null, - Post => - Big (Length (Target)) = - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are in Source - - and Model (Target) <= Model (Source) - - -- Elements both in Source and Target are in the intersection - - and - M.Includes_Intersection - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and - E_Elements_Included - (Elements (Target)'Old, Model (Source), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - - function Intersection (Left, Right : Set) return Set with - Global => null, - Post => - Big (Length (Intersection'Result)) = - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements in the result of Intersection are in Left and Right - - and Model (Intersection'Result) <= Model (Left) - and Model (Intersection'Result) <= Model (Right) - - -- Elements both in Left and Right are in the result of Intersection - - and - M.Includes_Intersection - (Model (Intersection'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from Left - - and - E_Elements_Included - (Elements (Intersection'Result), Elements (Left)) - and - E_Elements_Included - (Elements (Left), Model (Right), Elements (Intersection'Result)); - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set) with - Global => null, - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are not in Source - - and M.No_Overlap (Model (Target), Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and - M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and - E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - - function Difference (Left, Right : Set) return Set with - Global => null, - Post => - Big (Length (Difference'Result)) = Big (Length (Left)) - - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements of the result of Difference are in Left - - and Model (Difference'Result) <= Model (Left) - - -- Elements of the result of Difference are in Right - - and M.No_Overlap (Model (Difference'Result), Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and - M.Included_In_Union - (Model (Left), Model (Difference'Result), Model (Right)) - - -- Actual value of elements come from Left - - and - E_Elements_Included (Elements (Difference'Result), Elements (Left)) - and - E_Elements_Included - (Elements (Left), - Model (Difference'Result), - Elements (Difference'Result)); - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target) + Length (Target and Source), - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) + - Big (Length (Source)) - - -- Elements of the difference were not both in Source and in Target - - and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and - M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Elements in Source but not in Target are in the difference - - and - M.Included_In_Union - (Model (Source), Model (Target), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - and - E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - and - E_Elements_Included - (Elements (Source), Model (Target), Elements (Target)); - - function Symmetric_Difference (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Big (Length (Symmetric_Difference'Result)) = Big (Length (Left)) - - 2 * M.Num_Overlaps (Model (Left), Model (Right)) + - Big (Length (Right)) - - -- Elements of the difference were not both in Left and Right - - and - M.Not_In_Both - (Model (Symmetric_Difference'Result), Model (Left), Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and - M.Included_In_Union - (Model (Left), Model (Symmetric_Difference'Result), Model (Right)) - - -- Elements in Right but not in Left are in the difference - - and - M.Included_In_Union - (Model (Right), Model (Symmetric_Difference'Result), Model (Left)) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Symmetric_Difference'Result), - Model (Left), - Elements (Left), - Elements (Right)) - and - E_Elements_Included - (Elements (Left), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)) - and - E_Elements_Included - (Elements (Right), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)); - - function "xor" (Left, Right : Set) return Set - renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean with - Global => null, - Post => - Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right))); - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with - Global => null, - Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set)); - - function First (Container : Set) 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 : Set) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = E.Get (Elements (Container), 1) - and E_Smaller_Than_Range - (Elements (Container), - 2, - Length (Container), - First_Element'Result); - - function Last (Container : Set) 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 : Set) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = E.Get (Elements (Container), Length (Container)) - and E_Bigger_Than_Range - (Elements (Container), - 1, - Length (Container) - 1, - Last_Element'Result); - - function Next (Container : Set; 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 : Set; 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 : Set; 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 : Set; 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 : Set; Item : Element_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Item) => - not P.Has_Key (Positions (Container), Find'Result) - and Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Elements (Container), Item) - - -- The element designated by the result of Find is Item - - and Equivalent_Elements - (Element (Container, Find'Result), Item)); - - function Floor (Container : Set; Item : Element_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Item < First_Element (Container) => - Floor'Result = No_Element, - others => - Has_Element (Container, Floor'Result) - and - not (Item < E.Get (Elements (Container), - P.Get (Positions (Container), Floor'Result))) - and E_Is_Find - (Elements (Container), - Item, - P.Get (Positions (Container), Floor'Result))); - - function Ceiling (Container : Set; Item : Element_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Last_Element (Container) < Item => - Ceiling'Result = No_Element, - others => - Has_Element (Container, Ceiling'Result) - and - not (E.Get (Elements (Container), - P.Get (Positions (Container), Ceiling'Result)) < - Item) - and E_Is_Find - (Elements (Container), - Item, - P.Get (Positions (Container), Ceiling'Result))); - - function Contains (Container : Set; Item : Element_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Item); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Has_Element (Container : Set; 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 - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - - package Generic_Keys with SPARK_Mode is - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean with - Global => null, - Post => - Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys); - - package Formal_Model with Ghost is - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Bigger_Than_Range'Result = - (for all I in Fst .. Lst => - Generic_Keys.Key (E.Get (Container, I)) < Key); - pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range); - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Smaller_Than_Range'Result = - (for all I in Fst .. Lst => - Key < Generic_Keys.Key (E.Get (Container, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range); - - function E_Is_Find - (Container : E.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - with - Global => null, - Pre => Position - 1 <= E.Length (Container), - Post => - E_Is_Find'Result = - - ((if Position > 0 then - E_Bigger_Than_Range (Container, 1, Position - 1, Key)) - - and (if Position < E.Length (Container) then - E_Smaller_Than_Range - (Container, - Position + 1, - E.Length (Container), - Key))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find); - - function Find - (Container : E.Sequence; - Key : Key_Type) return Count_Type - -- Search for Key in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= E.Length (Container) - and Equivalent_Keys - (Key, Generic_Keys.Key (E.Get (Container, Find'Result))) - and E_Is_Find (Container, Key, Find'Result)); - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - with - Global => null, - Post => - M_Included_Except'Result = - (for all E of Left => - Contains (Right, E) - or Equivalent_Keys (Generic_Keys.Key (E), Key)); - end Formal_Model; - use Formal_Model; - - function Key (Container : Set; Position : Cursor) return Key_Type with - Global => null, - Post => Key'Result = Key (Element (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element (Container : Set; Key : Key_Type) return Element_Type - with - Global => null, - Pre => Contains (Container, Key), - Post => - Element'Result = Element (Container, Find (Container, Key)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - - -- Key now maps to New_Item - - and Element (Container, Key) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Find (Container, Key)) - and Positions (Container) = Positions (Container)'Old; - - procedure Exclude (Container : in out Set; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The elements of Container located before Key are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Key)'Old - 1) - - -- The elements located after Key are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Key)'Old)); - - procedure Delete (Container : in out Set; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The elements of Container located before Key are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Key)'Old - 1) - - -- The elements located after Key are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Key)'Old); - - function Find (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - ((for all E of Model (Container) => - not Equivalent_Keys (Key, Generic_Keys.Key (E))) => - not P.Has_Key (Positions (Container), Find'Result) - and Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Elements (Container), Key) - - -- The element designated by the result of Find is Key - - and Equivalent_Keys - (Generic_Keys.Key (Element (Container, Find'Result)), Key)); - - function Floor (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 - or else Key < Generic_Keys.Key (First_Element (Container)) => - Floor'Result = No_Element, - others => - Has_Element (Container, Floor'Result) - and - not (Key < - Generic_Keys.Key - (E.Get (Elements (Container), - P.Get (Positions (Container), Floor'Result)))) - and E_Is_Find - (Elements (Container), - Key, - P.Get (Positions (Container), Floor'Result))); - - function Ceiling (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 - or else Generic_Keys.Key (Last_Element (Container)) < Key => - Ceiling'Result = No_Element, - others => - Has_Element (Container, Ceiling'Result) - and - not (Generic_Keys.Key - (E.Get (Elements (Container), - P.Get (Positions (Container), Ceiling'Result))) - < Key) - and E_Is_Find - (Elements (Container), - Key, - P.Get (Positions (Container), Ceiling'Result))); - - function Contains (Container : Set; Key : Key_Type) return Boolean with - Global => null, - Post => - Contains'Result = - (for some E of Model (Container) => - Equivalent_Keys (Key, Generic_Keys.Key (E))); - - end Generic_Keys; - -private - pragma SPARK_Mode (Off); - - pragma Inline (Next); - pragma Inline (Previous); - - type Node_Type is record - Has_Element : Boolean := False; - Parent : Count_Type := 0; - Left : Count_Type := 0; - Right : Count_Type := 0; - Color : Red_Black_Trees.Color_Type; - Element : aliased Element_Type; - end record; - - package Tree_Types is - new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); - - type Set (Capacity : Count_Type) is record - Content : Tree_Types.Tree_Type (Capacity); - end record; - - use Red_Black_Trees; +package Ada.Containers.Formal_Ordered_Sets with SPARK_Mode is - Empty_Set : constant Set := (Capacity => 0, others => <>); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/libgnat/a-cofove.adb b/gcc/ada/libgnat/a-cofove.adb deleted file mode 100644 index c921184..0000000 --- a/gcc/ada/libgnat/a-cofove.adb +++ /dev/null @@ -1,1311 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Generic_Array_Sort; - -with System; use type System.Address; - -package body Ada.Containers.Formal_Vectors with - SPARK_Mode => Off -is - - subtype Int is Long_Long_Integer; - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - --------- - -- "=" -- - --------- - - function "=" (Left : Vector; Right : Vector) return Boolean is - begin - if Left'Address = Right'Address then - return True; - end if; - - if Length (Left) /= Length (Right) then - return False; - end if; - - for J in 1 .. Length (Left) loop - if Left.Elements (J) /= Right.Elements (J) then - return False; - end if; - end loop; - - return True; - end "="; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; New_Item : Vector) is - begin - if Is_Empty (New_Item) then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item); - end Append; - - procedure Append (Container : in out Vector; New_Item : Element_Type) is - begin - Append (Container, New_Item, 1); - end Append; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - if Count = 0 then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Vector; Source : Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Vector) return Capacity_Range is - begin - return Container.Capacity; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Vector) is - begin - Container.Last := No_Index; - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return not null access constant Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - return Container.Elements (To_Array_Index (Index))'Access; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - is - begin - return Find_Index (Container, Item) /= No_Index; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - is - LS : constant Capacity_Range := Length (Source); - C : Capacity_Range; - - begin - if Capacity = 0 then - C := LS; - elsif Capacity >= LS then - C := Capacity; - else - raise Capacity_Error with "Capacity too small"; - end if; - - return Target : Vector (C) do - Target.Elements (1 .. LS) := Source.Elements (1 .. LS); - Target.Last := Source.Last; - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Vector; Index : Extended_Index) is - begin - Delete (Container, Index, 1); - end Delete; - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - is - Old_Last : constant Index_Type'Base := Container.Last; - Old_Len : constant Count_Type := Length (Container); - New_Last : Index_Type'Base; - Count2 : Count_Type'Base; -- count of items from Index to Old_Last - Off : Count_Type'Base; -- Index expressed as offset from IT'First - - begin - -- Delete removes items from the vector, the number of which is the - -- minimum of the specified Count and the items (if any) that exist from - -- Index to Container.Last. There are no constraints on the specified - -- value of Count (it can be larger than what's available at this - -- position in the vector, for example), but there are constraints on - -- the allowed values of the Index. - - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying which items - -- should be deleted, so we must manually check. (That the user is - -- allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Index < Index_Type'First then - raise Constraint_Error with "Index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows the - -- corner case of deleting no items from the back end of the vector to - -- be treated as a no-op. (It is assumed that specifying an index value - -- greater than Last + 1 indicates some deeper flaw in the caller's - -- algorithm, so that case is treated as a proper error.) - - if Index > Old_Last then - if Index > Old_Last + 1 then - raise Constraint_Error with "Index is out of range (too large)"; - end if; - - return; - end if; - - if Count = 0 then - return; - end if; - - -- We first calculate what's available for deletion starting at - -- Index. Here and elsewhere we use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. (See function - -- Length for more information.) - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else - Count2 := Count_Type'Base (Old_Last - Index + 1); - end if; - - -- If more elements are requested (Count) for deletion than are - -- available (Count2) for deletion beginning at Index, then everything - -- from Index is deleted. There are no elements to slide down, and so - -- all we need to do is set the value of Container.Last. - - if Count >= Count2 then - Container.Last := Index - 1; - return; - end if; - - -- There are some elements aren't being deleted (the requested count was - -- less than the available count), so we must slide them down to Index. - -- We first calculate the index values of the respective array slices, - -- using the wider of Index_Type'Base and Count_Type'Base as the type - -- for intermediate calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Off := Count_Type'Base (Index - Index_Type'First); - New_Last := Old_Last - Index_Type'Base (Count); - else - Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); - New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); - end if; - - -- The array index values for each slice have already been determined, - -- so we just slide down to Index the elements that weren't deleted. - - declare - EA : Elements_Array renames Container.Elements; - Idx : constant Count_Type := EA'First + Off; - begin - EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); - Container.Last := New_Last; - end; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Vector) is - begin - Delete_First (Container, 1); - end Delete_First; - - procedure Delete_First (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - - elsif Count >= Length (Container) then - Clear (Container); - return; - - else - Delete (Container, Index_Type'First, Count); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Vector) is - begin - Delete_Last (Container, 1); - end Delete_Last; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - end if; - - -- There is no restriction on how large Count can be when deleting - -- items. If it is equal or greater than the current length, then this - -- is equivalent to clearing the vector. (In particular, there's no need - -- for us to actually calculate the new value for Last.) - - -- If the requested count is less than the current length, then we must - -- calculate the new value for Last. For the type we use the widest of - -- Index_Type'Base and Count_Type'Base for the intermediate values of - -- our calculation. (See the comments in Length for more information.) - - if Count >= Length (Container) then - Container.Last := No_Index; - - elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := Container.Last - Index_Type'Base (Count); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (Container.Last) - Count); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Vector; - Index : Extended_Index) return Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - begin - return Container.Elements (I); - end; - end Element; - - ---------------- - -- Find_Index -- - ---------------- - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - is - K : Count_Type; - Last : constant Extended_Index := Last_Index (Container); - - begin - K := Capacity_Range (Int (Index) - Int (No_Index)); - for Indx in Index .. Last loop - if Container.Elements (K) = Item then - return Indx; - end if; - - K := K + 1; - end loop; - - return No_Index; - end Find_Index; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Container.Elements (1); - end if; - end First_Element; - - ----------------- - -- First_Index -- - ----------------- - - function First_Index (Container : Vector) return Index_Type is - pragma Unreferenced (Container); - begin - return Index_Type'First; - end First_Index; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- 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 Index_Type'First .. M.Last (Container) loop - Elem := Element (Container, Index); - - if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem) - and then - not M.Contains (Right, Index_Type'First, M.Last (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 : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) return Boolean - is - begin - for I in L_Fst .. L_Lst loop - declare - Found : Boolean := False; - J : Extended_Index := 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 Index_Type := M.Last (Left); - - begin - if L /= M.Last (Right) then - return False; - end if; - - for I in Index_Type'First .. 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 : Index_Type; - Y : Index_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 Index_Type'First .. M.Last (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 : Vector) return M.Sequence is - R : M.Sequence; - - begin - for Position in 1 .. Length (Container) loop - R := M.Add (R, Container.Elements (Position)); - end loop; - - return R; - end Model; - - end Formal_Model; - - --------------------- - -- 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, Index_Type'First); - - begin - for I in Index_Type'First + 1 .. M.Last (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 : Vector) return Boolean is - L : constant Capacity_Range := Length (Container); - - begin - for J in 1 .. L - 1 loop - if Container.Elements (J + 1) < - Container.Elements (J) - then - return False; - end if; - end loop; - - return True; - end Is_Sorted; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out Vector) is - procedure Sort is - new Generic_Array_Sort - (Index_Type => Array_Index, - Element_Type => Element_Type, - Array_Type => Elements_Array, - "<" => "<"); - - Len : constant Capacity_Range := Length (Container); - - begin - if Container.Last <= Index_Type'First then - return; - else - Sort (Container.Elements (1 .. Len)); - end if; - end Sort; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target : in out Vector; Source : in out Vector) is - I : Count_Type; - J : Count_Type; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Length (Source) = 0 then - return; - end if; - - if Length (Target) = 0 then - Move (Target => Target, Source => Source); - return; - end if; - - I := Length (Target); - - declare - New_Length : constant Count_Type := I + Length (Source); - - begin - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Target.Last := No_Index + Index_Type'Base (New_Length); - - else - Target.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end; - - declare - TA : Elements_Array renames Target.Elements; - SA : Elements_Array renames Source.Elements; - - begin - J := Length (Target); - while Length (Source) /= 0 loop - if I = 0 then - TA (1 .. J) := SA (1 .. Length (Source)); - Source.Last := No_Index; - exit; - end if; - - if SA (Length (Source)) < TA (I) then - TA (J) := TA (I); - I := I - 1; - - else - TA (J) := SA (Length (Source)); - Source.Last := Source.Last - 1; - end if; - - J := J - 1; - end loop; - end; - end Merge; - - end Generic_Sorting; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - is - begin - return Position in First_Index (Container) .. Last_Index (Container); - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - is - begin - Insert (Container, Before, New_Item, 1); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - is - J : Count_Type'Base; -- scratch - - begin - -- Use Insert_Space to create the "hole" (the destination slice) - - Insert_Space (Container, Before, Count); - - J := To_Array_Index (Before); - - Container.Elements (J .. J - 1 + Count) := [others => New_Item]; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - is - N : constant Count_Type := Length (New_Item); - B : Count_Type; -- index Before converted to Count_Type - - begin - if Container'Address = New_Item'Address then - raise Program_Error with - "Container and New_Item denote same container"; - end if; - - -- Use Insert_Space to create the "hole" (the destination slice) into - -- which we copy the source items. - - Insert_Space (Container, Before, Count => N); - - if N = 0 then - - -- There's nothing else to do here (vetting of parameters was - -- performed already in Insert_Space), so we simply return. - - return; - end if; - - B := To_Array_Index (Before); - - Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N); - end Insert; - - ------------------ - -- Insert_Space -- - ------------------ - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Length (Container); - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Before > Container.Last - and then Before - 1 > Container.Last - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - - -- We treat inserting 0 items into the container as a no-op, so we - -- simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion count. - -- Note that the value cannot be simply added because the result may - -- overflow. - - if Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last) - then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - - -- Raise Capacity_Error if the new length exceeds the container's - -- capacity. - - elsif New_Length > Container.Capacity then - raise Capacity_Error with "New length is larger than capacity"; - end if; - - J := To_Array_Index (Before); - - declare - EA : Elements_Array renames Container.Elements; - - begin - if Before <= Container.Last then - - -- The new items are being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. - - EA (J + Count .. New_Length) := EA (J .. Old_Length); - end if; - end; - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := No_Index + Index_Type'Base (New_Length); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end Insert_Space; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Vector) return Boolean is - begin - return Last_Index (Container) < Index_Type'First; - end Is_Empty; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Container.Elements (Length (Container)); - end if; - end Last_Element; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - ------------ - -- Length -- - ------------ - - function Length (Container : Vector) return Capacity_Range is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; - - begin - return Capacity_Range (N); - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Vector; Source : in out Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - Clear (Source); - end Move; - - ------------ - -- Prepend -- - ------------ - - procedure Prepend (Container : in out Vector; New_Item : Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) is - begin - Prepend (Container, New_Item, 1); - end Prepend; - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, Index_Type'First, New_Item, Count); - end Prepend; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - Container.Elements (I) := New_Item; - end; - end Replace_Element; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : not null access Vector; - Index : Index_Type) return not null access Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - return Container.Elements (To_Array_Index (Index))'Access; - end Reference; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - is - begin - if Capacity > Container.Capacity then - raise Capacity_Error with "Capacity is out of range"; - end if; - end Reserve_Capacity; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out Vector) is - begin - if Length (Container) <= 1 then - return; - end if; - - declare - I, J : Capacity_Range; - E : Elements_Array renames - Container.Elements (1 .. Length (Container)); - - begin - I := 1; - J := Length (Container); - while I < J loop - declare - EI : constant Element_Type := E (I); - - begin - E (I) := E (J); - E (J) := EI; - end; - - I := I + 1; - J := J - 1; - end loop; - end; - end Reverse_Elements; - - ------------------------ - -- Reverse_Find_Index -- - ------------------------ - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - is - Last : Index_Type'Base; - K : Count_Type'Base; - - begin - if Index > Last_Index (Container) then - Last := Last_Index (Container); - else - Last := Index; - end if; - - K := Capacity_Range (Int (Last) - Int (No_Index)); - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements (K) = Item then - return Indx; - end if; - - K := K - 1; - end loop; - - return No_Index; - end Reverse_Find_Index; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - is - begin - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; - - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; - end if; - - if I = J then - return; - end if; - - declare - II : constant Int'Base := Int (I) - Int (No_Index); - JJ : constant Int'Base := Int (J) - Int (No_Index); - - EI : Element_Type renames Container.Elements (Capacity_Range (II)); - EJ : Element_Type renames Container.Elements (Capacity_Range (JJ)); - - EI_Copy : constant Element_Type := EI; - - begin - EI := EJ; - EJ := EI_Copy; - end; - end Swap; - - -------------------- - -- To_Array_Index -- - -------------------- - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is - Offset : Count_Type'Base; - - begin - -- We know that - -- Index >= Index_Type'First - -- hence we also know that - -- Index - Index_Type'First >= 0 - - -- The issue is that even though 0 is guaranteed to be a value in - -- the type Index_Type'Base, there's no guarantee that the difference - -- is a value in that type. To prevent overflow we use the wider - -- of Count_Type'Base and Index_Type'Base to perform intermediate - -- calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Offset := Count_Type'Base (Index - Index_Type'First); - - else - Offset := - Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); - end if; - - -- The array index subtype for all container element arrays always - -- starts with 1. - - return 1 + Offset; - end To_Array_Index; - - --------------- - -- To_Vector -- - --------------- - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - is - begin - if Length = 0 then - return Empty_Vector; - end if; - - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; -- ??? - end if; - - Last := Index_Type (Last_As_Int); - - return - (Capacity => Length, - Last => Last, - Elements => [others => New_Item]); - end; - end To_Vector; - -end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/libgnat/a-cofove.ads b/gcc/ada/libgnat/a-cofove.ads index 6413375..fb9301f 100644 --- a/gcc/ada/libgnat/a-cofove.ads +++ b/gcc/ada/libgnat/a-cofove.ads @@ -29,954 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- This spec is derived from package Ada.Containers.Bounded_Vectors in the Ada --- 2012 RM. The modifications are meant to facilitate formal proofs by making --- it easier to express properties, and by making the specification of this --- unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - -with Ada.Containers.Functional_Vectors; - generic - type Index_Type is range <>; - type Element_Type is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -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. - - pragma Assertion_Policy (Pre => Ignore); - pragma Assertion_Policy (Post => Ignore); - pragma Assertion_Policy (Contract_Cases => Ignore); - pragma Annotate (CodePeer, Skip_Analysis); - - subtype Extended_Index is Index_Type'Base - range Index_Type'First - 1 .. - Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; - - No_Index : constant Extended_Index := Extended_Index'First; - - Last_Count : constant Count_Type := - (if Index_Type'Last < Index_Type'First then - 0 - elsif Index_Type'Last < -1 - or else Index_Type'Pos (Index_Type'First) > - Index_Type'Pos (Index_Type'Last) - Count_Type'Last - then - Index_Type'Pos (Index_Type'Last) - - Index_Type'Pos (Index_Type'First) + 1 - else - Count_Type'Last); - -- Maximal capacity of any vector. It is the minimum of the size of the - -- index range and the last possible Count_Type. - - subtype Capacity_Range is Count_Type range 0 .. Last_Count; - - type Vector (Capacity : Capacity_Range) is private with - Default_Initial_Condition => Is_Empty (Vector), - Iterable => (First => Iter_First, - Has_Element => Iter_Has_Element, - Next => Iter_Next, - Element => Element); - - function Length (Container : Vector) return Capacity_Range with - Global => null, - Post => Length'Result <= Capacity (Container); - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - - package M is new Ada.Containers.Functional_Vectors - (Index_Type => Index_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 Index_Type'First .. M.Last (Container) => - (for some J in Index_Type'First .. M.Last (Left) => - Element (Container, I) = Element (Left, J)) - or (for some J in Index_Type'First .. M.Last (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 : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) 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.Last (Left) and R_Lst <= M.Last (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 Index_Type'First .. M.Last (Left) => - Element (Left, I) = - Element (Right, M.Last (Left) - I + 1)) - and (for all I in Index_Type'First .. M.Last (Right) => - Element (Right, I) = - Element (Left, M.Last (Left) - I + 1))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - -- Elements stored at X and Y are reversed in Left and Right - with - Global => null, - Pre => X <= M.Last (Left) and Y <= M.Last (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); - - function Model (Container : Vector) return M.Sequence with - -- The high-level model of a vector is a sequence of elements. The - -- sequence really is similar to the vector itself. However, it is not - -- limited which allows usage of 'Old and 'Loop_Entry attributes. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model); - - function Element - (S : M.Sequence; - I : Index_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 Empty_Vector return Vector with - Global => null, - Post => Length (Empty_Vector'Result) = 0; - - function "=" (Left, Right : Vector) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - with - Global => null, - Post => - Formal_Vectors.Length (To_Vector'Result) = Length - and M.Constant_Range - (Container => Model (To_Vector'Result), - Fst => Index_Type'First, - Lst => Last_Index (To_Vector'Result), - Item => New_Item); - - function Capacity (Container : Vector) return Capacity_Range with - Global => null, - Post => - Capacity'Result = Container.Capacity; - pragma Annotate (GNATprove, Inline_For_Proof, Capacity); - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - with - Global => null, - Pre => Capacity <= Container.Capacity, - Post => Model (Container) = Model (Container)'Old; - - function Is_Empty (Container : Vector) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Vector) with - Global => null, - Post => Length (Container) = 0; - - procedure Assign (Target : in out Vector; Source : Vector) with - Global => null, - Pre => Length (Source) <= Target.Capacity, - Post => Model (Target) = Model (Source); - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - with - Global => null, - Pre => (Capacity = 0 or Length (Source) <= Capacity), - Post => - Model (Copy'Result) = Model (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Length (Source) - else - Copy'Result.Capacity = Capacity); - - procedure Move (Target : in out Vector; Source : in out Vector) - with - Global => null, - Pre => Length (Source) <= Capacity (Target), - Post => Model (Target) = Model (Source)'Old and Length (Source) = 0; - - function Element - (Container : Vector; - Index : Extended_Index) return Element_Type - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => Element'Result = Element (Model (Container), Index); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - - -- Container now has New_Item at index Index - - and Element (Model (Container), Index) = New_Item - - -- All other elements are preserved - - and M.Equal_Except - (Left => Model (Container)'Old, - Right => Model (Container), - Position => Index); - - function At_End (E : access constant Vector) return access constant Vector - 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 : aliased Vector; - Index : Index_Type) return not null access constant Element_Type - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Constant_Reference'Result.all = Element (Model (Container), Index); - - function Reference - (Container : not null access Vector; - Index : Index_Type) return not null access Element_Type - with - Global => null, - Pre => - Index in First_Index (Container.all) .. Last_Index (Container.all), - Post => - Length (Container.all) = Length (At_End (Container).all) - - -- Container will have Result.all at index Index - - and At_End (Reference'Result).all = - Element (Model (At_End (Container).all), Index) - - -- All other elements are preserved - - and M.Equal_Except - (Left => Model (Container.all), - Right => Model (At_End (Container).all), - Position => Index); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item) - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Elements of New_Item are inserted at position Before - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => Count_Type (Before - Index_Type'First))) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Capacity (Container) - and then (Before in Index_Type'First .. Last_Index (Container) + 1), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Container now has New_Item at index Before - - and Element (Model (Container), Before) = New_Item - - -- Elements located after Before in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Count - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- New_Item is inserted Count times at position Before - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Before, - Lst => Before + Index_Type'Base (Count - 1), - Item => New_Item)) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Prepend (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements of New_Item are inserted at the beginning of Container - - and M.Range_Equal - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item)) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Container now has New_Item at Index_Type'First - - and Element (Model (Container), Index_Type'First) = New_Item - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- New_Item is inserted Count times at the beginning of Container - - and M.Constant_Range - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Index_Type'First + Index_Type'Base (Count - 1), - Item => New_Item) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Append (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- The elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- Elements of New_Item are inserted at the end of Container - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => - Count_Type - (Last_Index (Container)'Old - Index_Type'First + 1))); - - procedure Append (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements of Container are preserved - - and Model (Container)'Old < Model (Container) - - -- Container now has New_Item at the end of Container - - and Element - (Model (Container), Last_Index (Container)'Old + 1) = New_Item; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- New_Item is inserted Count times at the end of Container - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Last_Index (Container)'Old + 1, - Lst => - Last_Index (Container)'Old + Index_Type'Base (Count), - Item => New_Item)); - - procedure Delete (Container : in out Vector; Index : Extended_Index) with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements located before Index in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1) - - -- Elements located after Index in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - with - Global => null, - Pre => - Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) in - Length (Container)'Old - Count .. Length (Container)'Old - - -- The elements of Container located before Index are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1), - - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) - Count <= Count_Type (Index - Index_Type'First) => - Length (Container) = Count_Type (Index - Index_Type'First), - - 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 => Index, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_First (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index_Type'First, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete_First (Container : in out Vector; 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 => Index_Type'First, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_Last (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are preserved - - and Model (Container) < Model (Container)'Old; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements after Position 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); - - procedure Reverse_Elements (Container : in out Vector) with - Global => null, - Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - with - Global => null, - Pre => - I in First_Index (Container) .. Last_Index (Container) - and then J in First_Index (Container) .. Last_Index (Container), - Post => - M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J); - - function First_Index (Container : Vector) return Index_Type with - Global => null, - Post => First_Index'Result = Index_Type'First; - pragma Annotate (GNATprove, Inline_For_Proof, First_Index); - - function First_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = Element (Model (Container), Index_Type'First); - pragma Annotate (GNATprove, Inline_For_Proof, First_Element); - - function Last_Index (Container : Vector) return Extended_Index with - Global => null, - Post => Last_Index'Result = M.Last (Model (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Index); - - function Last_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = - Element (Model (Container), Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Element); - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container after Index, Find_Index - -- returns No_Index. - - (Index > Last_Index (Container) - or else not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Last_Index (Container), - Item => Item) - => - Find_Index'Result = No_Index, - - -- Otherwise, Find_Index returns a valid index greater than Index - - others => - Find_Index'Result in Index .. Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Find_Index'Result) = Item - - -- It is the first occurrence of Item after Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Find_Index'Result - 1, - Item => Item)); - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container before Index, - -- Reverse_Find_Index returns No_Index. - - (not M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => (if Index <= Last_Index (Container) then Index - else Last_Index (Container)), - Item => Item) - => - Reverse_Find_Index'Result = No_Index, - - -- Otherwise, Reverse_Find_Index returns a valid index smaller than - -- Index - - others => - Reverse_Find_Index'Result in Index_Type'First .. Index - and Reverse_Find_Index'Result <= Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Reverse_Find_Index'Result) = Item - - -- It is the last occurrence of Item before Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Reverse_Find_Index'Result + 1, - Lst => - (if Index <= Last_Index (Container) then - Index - else - Last_Index (Container)), - Item => Item)); - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - with - Global => null, - Post => - Contains'Result = - M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container), - Item => Item); - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - with - Global => null, - Post => - Has_Element'Result = - (Position in Index_Type'First .. Last_Index (Container)); - 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 Index_Type'First .. M.Last (Container) => - (for all J in I .. M.Last (Container) => - Element (Container, I) = Element (Container, J) - or Element (Container, I) < Element (Container, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); - - end Formal_Model; - use Formal_Model; - - function Is_Sorted (Container : Vector) return Boolean with - Global => null, - Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); - - procedure Sort (Container : in out Vector) 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 => Last_Index (Container), - Right => Model (Container), - R_Lst => Last_Index (Container)) - and M_Elements_Included - (Left => Model (Container), - L_Lst => Last_Index (Container), - Right => Model (Container)'Old, - R_Lst => Last_Index (Container)); - - procedure Merge (Target : in out Vector; Source : in out Vector) with - -- Target and Source should not be aliased - Global => null, - Pre => Length (Source) <= Capacity (Target) - Length (Target), - 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 => Last_Index (Target)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Last_Index (Source)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_In_Union - (Model (Target), - Model (Source)'Old, - Model (Target)'Old); - end Generic_Sorting; - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - function Iter_First (Container : Vector) return Extended_Index with - Global => null; - - function Iter_Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - with - Global => null, - Post => - Iter_Has_Element'Result = - (Position in Index_Type'First .. Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element); - - function Iter_Next - (Container : Vector; - Position : Extended_Index) return Extended_Index - with - Global => null, - Pre => Iter_Has_Element (Container, Position); - -private - pragma SPARK_Mode (Off); - - pragma Inline (First_Index); - pragma Inline (Last_Index); - pragma Inline (Element); - pragma Inline (First_Element); - pragma Inline (Last_Element); - pragma Inline (Replace_Element); - pragma Inline (Contains); - - subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last; - type Elements_Array is array (Array_Index range <>) of aliased Element_Type; - function "=" (L, R : Elements_Array) return Boolean is abstract; - - type Vector (Capacity : Capacity_Range) is record - Last : Extended_Index := No_Index; - Elements : Elements_Array (1 .. Capacity); - end record; - - function Empty_Vector return Vector is - ((Capacity => 0, others => <>)); - - function Iter_First (Container : Vector) return Extended_Index is - (Index_Type'First); - - function Iter_Next - (Container : Vector; - Position : Extended_Index) return Extended_Index - is - (if Position = Extended_Index'Last then - Extended_Index'First - else - Extended_Index'Succ (Position)); +package Ada.Containers.Formal_Vectors with SPARK_Mode is - function Iter_Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - is - (Position in Index_Type'First .. Container.Last); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/libgnat/a-cofuba.adb b/gcc/ada/libgnat/a-cofuba.adb deleted file mode 100644 index 68cf2ae..0000000 --- a/gcc/ada/libgnat/a-cofuba.adb +++ /dev/null @@ -1,432 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_BASE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-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; -with Ada.Unchecked_Deallocation; - -package body Ada.Containers.Functional_Base with SPARK_Mode => Off is - - function To_Count (Idx : Extended_Index) return Count_Type is - (Count_Type - (Extended_Index'Pos (Idx) - - Extended_Index'Pos (Extended_Index'First))); - - function To_Index (Position : Count_Type) return Extended_Index is - (Extended_Index'Val - (Position + Extended_Index'Pos (Extended_Index'First))); - -- Conversion functions between Index_Type and Count_Type - - function Find (C : Container; E : access Element_Type) return Count_Type; - -- Search a container C for an element equal to E.all, returning the - -- position in the underlying array. - - procedure Resize (Base : Array_Base_Access); - -- 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; - - --------- - -- "=" -- - --------- - - function "=" (C1 : Container; C2 : Container) return Boolean is - begin - if C1.Length /= C2.Length then - return False; - end if; - for I in 1 .. C1.Length loop - if Get (Elements (C1), I).all /= Get (Elements (C2), I).all then - return False; - end if; - end loop; - - return True; - end "="; - - ---------- - -- "<=" -- - ---------- - - function "<=" (C1 : Container; C2 : Container) return Boolean is - begin - for I in 1 .. C1.Length loop - if Find (C2, Get (Elements (C1), I)) = 0 then - return False; - end if; - end loop; - - return True; - end "<="; - - --------- - -- Add -- - --------- - - function Add - (C : Container; - 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_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_B.Max_Length, - Controlled_Base => C.Controlled_Base); - else - declare - A : constant Array_Base_Controlled_Access := - Content_Init (C.Length); - P : Count_Type := 0; - begin - 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.Base.Elements (J) := C_B.Elements (P); - else - A.Base.Elements (J) := Element_Init (E); - end if; - end loop; - - 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_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 (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 -- - ---------- - - function Find (C : Container; E : access Element_Type) return Count_Type is - begin - for I in 1 .. C.Length loop - if Get (Elements (C), I).all = E.all then - return I; - end if; - end loop; - - return 0; - end Find; - - function Find (C : Container; E : Element_Type) return Extended_Index is - (To_Index (Find (C, E'Unrestricted_Access))); - - --------- - -- Get -- - --------- - - function Get (C : Container; I : Index_Type) return Element_Type is - (Get (Elements (C), To_Count (I)).all); - - ------------------ - -- Intersection -- - ------------------ - - function Intersection (C1 : Container; C2 : Container) return Container is - L : constant Count_Type := Num_Overlaps (C1, C2); - A : constant Array_Base_Controlled_Access := Content_Init (L); - P : Count_Type := 0; - - begin - A.Base.Max_Length := L; - for I in 1 .. C1.Length loop - if Find (C2, Get (Elements (C1), I)) > 0 then - P := P + 1; - A.Base.Elements (P) := Elements (C1) (I); - end if; - end loop; - - return Container'(Length => P, Controlled_Base => A); - end Intersection; - - ------------ - -- Length -- - ------------ - - function Length (C : Container) return Count_Type is (C.Length); - --------------------- - -- Num_Overlaps -- - --------------------- - - function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type is - P : Count_Type := 0; - - begin - for I in 1 .. C1.Length loop - if Find (C2, Get (Elements (C1), I)) > 0 then - P := P + 1; - end if; - end loop; - - return P; - end Num_Overlaps; - - ------------ - -- Remove -- - ------------ - - function Remove (C : Container; I : Index_Type) return Container is - begin - if To_Count (I) = C.Length then - return Container'(Length => C.Length - 1, - Controlled_Base => C.Controlled_Base); - else - declare - A : constant Array_Base_Controlled_Access - := Content_Init (C.Length - 1); - P : Count_Type := 0; - begin - A.Base.Max_Length := C.Length - 1; - for J in 1 .. C.Length loop - if J /= To_Count (I) then - P := P + 1; - A.Base.Elements (P) := Elements (C) (J); - end if; - end loop; - - return Container'(Length => C.Length - 1, Controlled_Base => A); - end; - end if; - end Remove; - - ------------ - -- Resize -- - ------------ - - procedure Resize (Base : Array_Base_Access) is - begin - if Base.Max_Length < Base.Elements'Length then - return; - end if; - - pragma Assert (Base.Max_Length = Base.Elements'Length); - - if Base.Max_Length = Count_Type'Last then - raise Constraint_Error; - end if; - - declare - procedure Finalize is new Ada.Unchecked_Deallocation - (Object => Element_Array, - Name => Element_Array_Access_Base); - - New_Length : constant Positive_Count_Type := - (if Base.Max_Length > Count_Type'Last / 2 then Count_Type'Last - else 2 * Base.Max_Length); - Elements : constant Element_Array_Access := - new Element_Array (1 .. New_Length); - Old_Elmts : Element_Array_Access_Base := Base.Elements; - begin - Elements (1 .. Base.Max_Length) := Base.Elements.all; - Base.Elements := Elements; - Finalize (Old_Elmts); - end; - end Resize; - - --------- - -- Set -- - --------- - - function Set - (C : Container; - I : Index_Type; - E : Element_Type) return Container - is - Result : constant Container := - Container'(Length => C.Length, - Controlled_Base => Content_Init (C.Length)); - R_Base : Array_Base_Access renames Result.Controlled_Base.Base; - - begin - 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; - - ----------- - -- Union -- - ----------- - - function Union (C1 : Container; C2 : Container) return Container is - N : constant Count_Type := Num_Overlaps (C1, C2); - - begin - -- if C2 is completely included in C1 then return C1 - - if N = Length (C2) then - return C1; - end if; - - -- else loop through C2 to find the remaining elements - - declare - L : constant Count_Type := Length (C1) - N + Length (C2); - A : constant Array_Base_Controlled_Access := Content_Init (L); - P : Count_Type := Length (C1); - begin - 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, Get (Elements (C2), I)) = 0 then - P := P + 1; - A.Base.Elements (P) := Elements (C2) (I); - end if; - end loop; - - return Container'(Length => L, Controlled_Base => A); - end; - end Union; - -end Ada.Containers.Functional_Base; diff --git a/gcc/ada/libgnat/a-cofuba.ads b/gcc/ada/libgnat/a-cofuba.ads deleted file mode 100644 index 8a99a43..0000000 --- a/gcc/ada/libgnat/a-cofuba.ads +++ /dev/null @@ -1,198 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_BASE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2016-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/>. -- ------------------------------------------------------------------------------- --- Functional containers are neither controlled nor limited. This is safe, as --- no primitives are provided to modify them. --- Memory allocated inside functional containers is never reclaimed. - -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 - -- should have at least one more element at the low end than Index_Type. - - type Element_Type (<>) is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Functional_Base with SPARK_Mode => Off is - - subtype Extended_Index is Index_Type'Base range - Index_Type'Pred (Index_Type'First) .. Index_Type'Last; - - type Container is private; - - function "=" (C1 : Container; C2 : Container) return Boolean; - -- Return True if C1 and C2 contain the same elements at the same position - - function Length (C : Container) return Count_Type; - -- Number of elements stored in C - - function Get (C : Container; I : Index_Type) return Element_Type; - -- Access to the element at index I in C - - function Set - (C : Container; - I : Index_Type; - E : Element_Type) return Container; - -- Return a new container which is equal to C except for the element at - -- index I, which is set to E. - - function Add - (C : Container; - I : Index_Type; - E : Element_Type) return Container; - -- Return a new container that is C with E inserted at index I - - function Remove (C : Container; I : Index_Type) return Container; - -- Return a new container that is C without the element at index I - - function Find (C : Container; E : Element_Type) return Extended_Index; - -- Return the first index for which the element stored in C is I. If there - -- are no such indexes, return Extended_Index'First. - - -------------------- - -- Set Operations -- - -------------------- - - function "<=" (C1 : Container; C2 : Container) return Boolean; - -- Return True if every element of C1 is in C2 - - function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type; - -- Return the number of elements that are in both C1 and C2 - - function Union (C1 : Container; C2 : Container) return Container; - -- Return a container which is C1 plus all the elements of C2 that are not - -- in C1. - - function Intersection (C1 : Container; C2 : Container) return Container; - -- Return a container which is C1 minus all the elements that are also in - -- C2. - -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 Controlled_Element_Access; - - type Element_Array_Access_Base is access Element_Array; - - subtype Element_Array_Access is Element_Array_Access_Base; - - type Array_Base is record - 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; - - 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_Controlled_Access; - -- Used to initialize the content of an array base with length L - - type Container is record - 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 deleted file mode 100644 index f83b4d8..0000000 --- a/gcc/ada/libgnat/a-cofuma.adb +++ /dev/null @@ -1,306 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_MAPS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-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_Maps with SPARK_Mode => Off is - use Key_Containers; - use Element_Containers; - - package Conversions is new Signed_Conversions (Int => Count_Type); - use Conversions; - - --------- - -- "=" -- - --------- - - function "=" (Left : Map; Right : Map) return Boolean is - (Left.Keys <= Right.Keys and Right <= Left); - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left : Map; Right : Map) return Boolean is - I2 : Count_Type; - - begin - for I1 in 1 .. Length (Left.Keys) loop - I2 := Find (Right.Keys, Get (Left.Keys, I1)); - if I2 = 0 - or else Get (Right.Elements, I2) /= Get (Left.Elements, I1) - then - return False; - end if; - end loop; - return True; - end "<="; - - --------- - -- Add -- - --------- - - function Add - (Container : Map; - New_Key : Key_Type; - New_Item : Element_Type) return Map - is - begin - return - (Keys => - Add (Container.Keys, Length (Container.Keys) + 1, New_Key), - Elements => - Add - (Container.Elements, Length (Container.Elements) + 1, New_Item)); - end Add; - - --------------------------- - -- Elements_Equal_Except -- - --------------------------- - - function Elements_Equal_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - is - begin - for J in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, J); - begin - if not Equivalent_Keys (K, New_Key) - and then - (Find (Right.Keys, K) = 0 - or else Get (Right.Elements, Find (Right.Keys, K)) /= - Get (Left.Elements, J)) - then - return False; - end if; - end; - end loop; - return True; - end Elements_Equal_Except; - - function Elements_Equal_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - is - begin - for J in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, J); - begin - if not Equivalent_Keys (K, X) - and then not Equivalent_Keys (K, Y) - and then - (Find (Right.Keys, K) = 0 - or else Get (Right.Elements, Find (Right.Keys, K)) /= - Get (Left.Elements, J)) - then - return False; - end if; - end; - end loop; - return True; - end Elements_Equal_Except; - - --------------- - -- Empty_Map -- - --------------- - - function Empty_Map return Map is - ((others => <>)); - - --------- - -- Get -- - --------- - - function Get (Container : Map; Key : Key_Type) return Element_Type is - begin - return Get (Container.Elements, Find (Container.Keys, Key)); - end Get; - - ------------- - -- Has_Key -- - ------------- - - function Has_Key (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container.Keys, Key) > 0; - end Has_Key; - - ----------------- - -- Has_Witness -- - ----------------- - - function Has_Witness - (Container : Map; - Witness : Count_Type) return Boolean - is - (Witness in 1 .. Length (Container.Keys)); - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Length (Container.Keys) = 0; - end Is_Empty; - - ------------------- - -- Keys_Included -- - ------------------- - - function Keys_Included (Left : Map; Right : Map) return Boolean is - begin - for J in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, J); - begin - if Find (Right.Keys, K) = 0 then - return False; - end if; - end; - end loop; - - return True; - end Keys_Included; - - -------------------------- - -- Keys_Included_Except -- - -------------------------- - - function Keys_Included_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - is - begin - for J in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, J); - begin - if not Equivalent_Keys (K, New_Key) - and then Find (Right.Keys, K) = 0 - then - return False; - end if; - end; - end loop; - - return True; - end Keys_Included_Except; - - function Keys_Included_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - is - begin - for J in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, J); - begin - if not Equivalent_Keys (K, X) - and then not Equivalent_Keys (K, Y) - and then Find (Right.Keys, K) = 0 - then - return False; - end if; - end; - end loop; - - return True; - end Keys_Included_Except; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Big_Natural is - begin - return To_Big_Integer (Length (Container.Elements)); - end Length; - - ------------ - -- Remove -- - ------------ - - function Remove (Container : Map; Key : Key_Type) return Map is - J : constant Extended_Index := Find (Container.Keys, Key); - begin - return - (Keys => Remove (Container.Keys, J), - Elements => Remove (Container.Elements, J)); - end Remove; - - --------------- - -- Same_Keys -- - --------------- - - function Same_Keys (Left : Map; Right : Map) return Boolean is - (Keys_Included (Left, Right) - and Keys_Included (Left => Right, Right => Left)); - - --------- - -- Set -- - --------- - - function Set - (Container : Map; - Key : Key_Type; - New_Item : Element_Type) return Map - is - (Keys => Container.Keys, - Elements => - Set (Container.Elements, Find (Container.Keys, Key), New_Item)); - - ----------- - -- W_Get -- - ----------- - - function W_Get - (Container : Map; - Witness : Count_Type) return Element_Type - is - (Get (Container.Elements, Witness)); - - ------------- - -- Witness -- - ------------- - - function Witness (Container : Map; Key : Key_Type) return Count_Type is - (Find (Container.Keys, Key)); - -end Ada.Containers.Functional_Maps; diff --git a/gcc/ada/libgnat/a-cofuma.ads b/gcc/ada/libgnat/a-cofuma.ads index f863cdc..9b4863a 100644 --- a/gcc/ada/libgnat/a-cofuma.ads +++ b/gcc/ada/libgnat/a-cofuma.ads @@ -29,368 +29,12 @@ -- <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 Key_Type (<>) is private; - type Element_Type (<>) is private; - - with function Equivalent_Keys - (Left : Key_Type; - Right : Key_Type) return Boolean is "="; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - - Enable_Handling_Of_Equivalence : Boolean := True; - -- This constant should only be set to False when no particular handling - -- of equivalence over keys is needed, that is, Equivalent_Keys defines a - -- key uniquely. - -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, - Iterable => (First => Iter_First, - Next => Iter_Next, - Has_Element => Iter_Has_Element, - Element => Iter_Element); - -- Maps are empty when default initialized. - -- "For in" quantification over maps should not be used. - -- "For of" quantification over maps iterates over keys. - -- Note that, for proof, "for of" quantification is understood modulo - -- equivalence (the range of quantification comprises all the keys that are - -- equivalent to any key of the map). - - ----------------------- - -- Basic operations -- - ----------------------- - - -- Maps are axiomatized using Has_Key and Get, encoding respectively the - -- presence of a key in a map and an accessor to elements associated with - -- its keys. The length of a map is also added to protect Add against - -- overflows but it is not actually modeled. - - function Has_Key (Container : Map; Key : Key_Type) return Boolean with - -- Return True if Key is present in Container - - Global => null, - Post => - (if Enable_Handling_Of_Equivalence then - - -- Has_Key returns the same result on all equivalent keys - - (if (for some K of Container => Equivalent_Keys (K, Key)) then - Has_Key'Result)); - - function Get (Container : Map; Key : Key_Type) return Element_Type with - -- Return the element associated with Key in Container - - Global => null, - Pre => Has_Key (Container, Key), - Post => - (if Enable_Handling_Of_Equivalence then - - -- Get returns the same result on all equivalent keys - - Get'Result = W_Get (Container, Witness (Container, Key)) - and (for all K of Container => - (Equivalent_Keys (K, Key) = - (Witness (Container, Key) = Witness (Container, K))))); - - function Length (Container : Map) return Big_Natural with - Global => null; - -- Return the number of mappings in Container - - ------------------------ - -- Property Functions -- - ------------------------ - - function "<=" (Left : Map; Right : Map) return Boolean with - -- Map inclusion - - Global => null, - Post => - "<="'Result = - (for all Key of Left => - Has_Key (Right, Key) and then Get (Right, Key) = Get (Left, Key)); - - function "=" (Left : Map; Right : Map) return Boolean with - -- Extensional equality over maps - - Global => null, - Post => - "="'Result = - ((for all Key of Left => - Has_Key (Right, Key) - and then Get (Right, Key) = Get (Left, Key)) - and (for all Key of Right => Has_Key (Left, Key))); - - pragma Warnings (Off, "unused variable ""Key"""); - function Is_Empty (Container : Map) return Boolean with - -- A map is empty if it contains no key - - Global => null, - Post => Is_Empty'Result = (for all Key of Container => False); - pragma Warnings (On, "unused variable ""Key"""); - - function Keys_Included (Left : Map; Right : Map) return Boolean - -- Returns True if every Key of Left is in Right - - with - Global => null, - Post => - Keys_Included'Result = (for all Key of Left => Has_Key (Right, Key)); - - function Same_Keys (Left : Map; Right : Map) return Boolean - -- Returns True if Left and Right have the same keys - - with - Global => null, - Post => - Same_Keys'Result = - (Keys_Included (Left, Right) - and Keys_Included (Left => Right, Right => Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Same_Keys); - - function Keys_Included_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - -- Returns True if Left contains only keys of Right and possibly New_Key - - with - Global => null, - Post => - Keys_Included_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, New_Key) then - Has_Key (Right, Key))); - - function Keys_Included_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - -- Returns True if Left contains only keys of Right and possibly X and Y - - with - Global => null, - Post => - Keys_Included_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, X) - and not Equivalent_Keys (Key, Y) - then - Has_Key (Right, Key))); - - function Elements_Equal_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - -- Returns True if all the keys of Left are mapped to the same elements in - -- Left and Right except New_Key. - - with - Global => null, - Post => - Elements_Equal_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, New_Key) then - Has_Key (Right, Key) - and then Get (Left, Key) = Get (Right, Key))); - - function Elements_Equal_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - -- Returns True if all the keys of Left are mapped to the same elements in - -- Left and Right except X and Y. - - with - Global => null, - Post => - Elements_Equal_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, X) - and not Equivalent_Keys (Key, Y) - then - Has_Key (Right, Key) - and then Get (Left, Key) = Get (Right, Key))); - - ---------------------------- - -- Construction Functions -- - ---------------------------- - - -- For better efficiency of both proofs and execution, avoid using - -- construction functions in annotations and rather use property functions. - - function Add - (Container : Map; - New_Key : Key_Type; - New_Item : Element_Type) return Map - -- Returns Container augmented with the mapping Key -> New_Item - - with - Global => null, - Pre => not Has_Key (Container, New_Key), - Post => - Length (Container) + 1 = Length (Add'Result) - and Has_Key (Add'Result, New_Key) - and Get (Add'Result, New_Key) = New_Item - 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 - -- Returns Container without any mapping for Key - - with - Global => null, - Pre => Has_Key (Container, Key), - Post => - Length (Container) = Length (Remove'Result) + 1 - and not Has_Key (Remove'Result, Key) - and Remove'Result <= Container - and Keys_Included_Except (Container, Remove'Result, Key); - - function Set - (Container : Map; - Key : Key_Type; - New_Item : Element_Type) return Map - -- Returns Container, where the element associated with Key has been - -- replaced by New_Item. - - with - Global => null, - Pre => Has_Key (Container, Key), - Post => - Length (Container) = Length (Set'Result) - and Get (Set'Result, Key) = New_Item - and Same_Keys (Container, Set'Result) - and Elements_Equal_Except (Container, Set'Result, Key); - - ------------------------------ - -- Handling of Equivalence -- - ------------------------------ - - -- These functions are used to specify that Get returns the same value on - -- equivalent keys. They should not be used directly in user code. - - function Has_Witness (Container : Map; Witness : Count_Type) return Boolean - with - Ghost, - Global => null; - -- Returns True if there is a key with witness Witness in Container - - function Witness (Container : Map; Key : Key_Type) return Count_Type with - -- Returns the witness of Key in Container - - Ghost, - Global => null, - Pre => Has_Key (Container, Key), - Post => Has_Witness (Container, Witness'Result); - - function W_Get (Container : Map; Witness : Count_Type) return Element_Type - with - -- Returns the element associated with a witness in Container - - Ghost, - Global => null, - Pre => Has_Witness (Container, Witness); - - function Copy_Key (Key : Key_Type) return Key_Type is (Key); - function Copy_Element (Item : Element_Type) return Element_Type is (Item); - -- Elements and Keys of maps 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). - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - type Private_Key is private; - - function Iter_First (Container : Map) return Private_Key with - Global => null; - - function Iter_Has_Element - (Container : Map; - Key : Private_Key) return Boolean - with - Global => null; - - function Iter_Next (Container : Map; Key : Private_Key) return Private_Key - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - - function Iter_Element (Container : Map; Key : Private_Key) return Key_Type - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Has_Key); - -private - - pragma SPARK_Mode (Off); - - function "=" - (Left : Key_Type; - Right : Key_Type) return Boolean renames Equivalent_Keys; - - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package Element_Containers is new Ada.Containers.Functional_Base - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - package Key_Containers is new Ada.Containers.Functional_Base - (Element_Type => Key_Type, - Index_Type => Positive_Count_Type); - - type Map is record - Keys : Key_Containers.Container; - Elements : Element_Containers.Container; - end record; - - type Private_Key is new Count_Type; - - function Iter_First (Container : Map) return Private_Key is (1); - - function Iter_Has_Element - (Container : Map; - Key : Private_Key) return Boolean - is - (Count_Type (Key) in 1 .. Key_Containers.Length (Container.Keys)); - - function Iter_Next - (Container : Map; - Key : Private_Key) return Private_Key - is - (if Key = Private_Key'Last then 0 else Key + 1); +package Ada.Containers.Functional_Maps with SPARK_Mode is - function Iter_Element - (Container : Map; - Key : Private_Key) return Key_Type - is - (Key_Containers.Get (Container.Keys, Count_Type (Key))); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Functional_Maps; diff --git a/gcc/ada/libgnat/a-cofuse.adb b/gcc/ada/libgnat/a-cofuse.adb deleted file mode 100644 index bbb3f7e..0000000 --- a/gcc/ada/libgnat/a-cofuse.adb +++ /dev/null @@ -1,184 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_SETS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-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_Sets with SPARK_Mode => Off is - use Containers; - - package Conversions is new Signed_Conversions (Int => Count_Type); - use Conversions; - - --------- - -- "=" -- - --------- - - function "=" (Left : Set; Right : Set) return Boolean is - (Left.Content <= Right.Content and Right.Content <= Left.Content); - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left : Set; Right : Set) return Boolean is - (Left.Content <= Right.Content); - - --------- - -- Add -- - --------- - - function Add (Container : Set; Item : Element_Type) return Set is - (Content => - Add (Container.Content, Length (Container.Content) + 1, Item)); - - -------------- - -- Contains -- - -------------- - - 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 -- - --------------------- - - function Included_Except - (Left : Set; - Right : Set; - Item : Element_Type) return Boolean - is - (for all E of Left => - Equivalent_Elements (E, Item) or Contains (Right, E)); - - ----------------------- - -- Included_In_Union -- - ----------------------- - - function Included_In_Union - (Container : Set; - Left : Set; - Right : Set) return Boolean - is - (for all Item of Container => - Contains (Left, Item) or Contains (Right, Item)); - - --------------------------- - -- Includes_Intersection -- - --------------------------- - - function Includes_Intersection - (Container : Set; - Left : Set; - Right : Set) return Boolean - is - (for all Item of Left => - (if Contains (Right, Item) then Contains (Container, Item))); - - ------------------ - -- Intersection -- - ------------------ - - function Intersection (Left : Set; Right : Set) return Set is - (Content => Intersection (Left.Content, Right.Content)); - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - (Length (Container.Content) = 0); - - ------------------ - -- Is_Singleton -- - ------------------ - - function Is_Singleton - (Container : Set; - New_Item : Element_Type) return Boolean - is - (Length (Container.Content) = 1 - and New_Item = Get (Container.Content, 1)); - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Big_Natural is - (To_Big_Integer (Length (Container.Content))); - - ----------------- - -- Not_In_Both -- - ----------------- - - function Not_In_Both - (Container : Set; - Left : Set; - Right : Set) return Boolean - is - (for all Item of Container => - not Contains (Right, Item) or not Contains (Left, Item)); - - ---------------- - -- No_Overlap -- - ---------------- - - function No_Overlap (Left : Set; Right : Set) return Boolean is - (Num_Overlaps (Left.Content, Right.Content) = 0); - - ------------------ - -- Num_Overlaps -- - ------------------ - - function Num_Overlaps (Left : Set; Right : Set) return Big_Natural is - (To_Big_Integer (Num_Overlaps (Left.Content, Right.Content))); - - ------------ - -- Remove -- - ------------ - - function Remove (Container : Set; Item : Element_Type) return Set is - (Content => Remove (Container.Content, Find (Container.Content, Item))); - - ----------- - -- Union -- - ----------- - - function Union (Left : Set; Right : Set) return Set is - (Content => Union (Left.Content, Right.Content)); - -end Ada.Containers.Functional_Sets; diff --git a/gcc/ada/libgnat/a-cofuse.ads b/gcc/ada/libgnat/a-cofuse.ads index ce52f61..9c57ba1 100644 --- a/gcc/ada/libgnat/a-cofuse.ads +++ b/gcc/ada/libgnat/a-cofuse.ads @@ -29,308 +29,12 @@ -- <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 Equivalent_Elements - (Left : Element_Type; - Right : Element_Type) return Boolean is "="; - - Enable_Handling_Of_Equivalence : Boolean := True; - -- This constant should only be set to False when no particular handling - -- of equivalence over elements is needed, that is, Equivalent_Elements - -- defines an element uniquely. - -package Ada.Containers.Functional_Sets with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is - - type Set is private with - Default_Initial_Condition => Is_Empty (Set), - Iterable => (First => Iter_First, - Next => Iter_Next, - Has_Element => Iter_Has_Element, - Element => Iter_Element); - -- Sets are empty when default initialized. - -- "For in" quantification over sets should not be used. - -- "For of" quantification over sets iterates over elements. - -- Note that, for proof, "for of" quantification is understood modulo - -- equivalence (the range of quantification comprises all the elements that - -- are equivalent to any element of the set). - - ----------------------- - -- Basic operations -- - ----------------------- - - -- Sets are axiomatized using Contains, which encodes whether an element is - -- contained in a set. The length of a set is also added to protect Add - -- against overflows but it is not actually modeled. - - function Contains (Container : Set; Item : Element_Type) return Boolean with - -- Return True if Item is contained in Container - - Global => null, - Post => - (if Enable_Handling_Of_Equivalence then - - -- Contains returns the same result on all equivalent elements - - (if (for some E of Container => Equivalent_Elements (E, Item)) then - Contains'Result)); - - function Length (Container : Set) return Big_Natural with - Global => null; - -- Return the number of elements in Container - - ------------------------ - -- Property Functions -- - ------------------------ - - function "<=" (Left : Set; Right : Set) return Boolean with - -- Set inclusion - - Global => null, - Post => "<="'Result = (for all Item of Left => Contains (Right, Item)); - - function "=" (Left : Set; Right : Set) return Boolean with - -- Extensional equality over sets - - Global => null, - Post => "="'Result = (Left <= Right and Right <= Left); - - pragma Warnings (Off, "unused variable ""Item"""); - function Is_Empty (Container : Set) return Boolean with - -- A set is empty if it contains no element - - Global => null, - Post => - Is_Empty'Result = (for all Item of Container => False) - and Is_Empty'Result = (Length (Container) = 0); - pragma Warnings (On, "unused variable ""Item"""); - - function Included_Except - (Left : Set; - Right : Set; - Item : Element_Type) return Boolean - -- Return True if Left contains only elements of Right except possibly - -- Item. - - with - Global => null, - Post => - Included_Except'Result = - (for all E of Left => - Contains (Right, E) or Equivalent_Elements (E, Item)); - - function Includes_Intersection - (Container : Set; - Left : Set; - Right : Set) return Boolean - with - -- Return True if every element of the intersection of Left and Right is - -- in Container. - - Global => null, - Post => - Includes_Intersection'Result = - (for all Item of Left => - (if Contains (Right, Item) then Contains (Container, Item))); - - function Included_In_Union - (Container : Set; - Left : Set; - Right : Set) return Boolean - with - -- Return True if every element of Container is the union of Left and Right - - Global => null, - Post => - Included_In_Union'Result = - (for all Item of Container => - Contains (Left, Item) or Contains (Right, Item)); - - function Is_Singleton - (Container : Set; - New_Item : Element_Type) return Boolean - with - -- Return True Container only contains New_Item - - Global => null, - Post => - Is_Singleton'Result = - (for all Item of Container => Equivalent_Elements (Item, New_Item)); - - function Not_In_Both - (Container : Set; - Left : Set; - Right : Set) return Boolean - -- Return True if there are no elements in Container that are in Left and - -- Right. - - with - Global => null, - Post => - Not_In_Both'Result = - (for all Item of Container => - not Contains (Left, Item) or not Contains (Right, Item)); - - function No_Overlap (Left : Set; Right : Set) return Boolean with - -- Return True if there are no equivalent elements in Left and Right - - Global => null, - Post => - No_Overlap'Result = - (for all Item of Left => not Contains (Right, Item)); - - function Num_Overlaps (Left : Set; Right : Set) return Big_Natural with - -- Number of elements that are both in Left and Right - - Global => null, - Post => - Num_Overlaps'Result = Length (Intersection (Left, Right)) - and (if Left <= Right then Num_Overlaps'Result = Length (Left) - else Num_Overlaps'Result < Length (Left)) - and (if Right <= Left then Num_Overlaps'Result = Length (Right) - else Num_Overlaps'Result < Length (Right)) - and (Num_Overlaps'Result = 0) = No_Overlap (Left, Right); - - ---------------------------- - -- Construction Functions -- - ---------------------------- - - -- For better efficiency of both proofs and execution, avoid using - -- construction functions in annotations and rather use property functions. - - function Add (Container : Set; Item : Element_Type) return Set with - -- Return a new set containing all the elements of Container plus E - - Global => null, - 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 - - Global => null, - Pre => Contains (Container, Item), - Post => - Length (Remove'Result) = Length (Container) - 1 - and not Contains (Remove'Result, Item) - and Remove'Result <= Container - and Included_Except (Container, Remove'Result, Item); - - function Intersection (Left : Set; Right : Set) return Set with - -- Returns the intersection of Left and Right - - Global => null, - Post => - Intersection'Result <= Left - and Intersection'Result <= Right - and Includes_Intersection (Intersection'Result, Left, Right); - - function Union (Left : Set; Right : Set) return Set with - -- Returns the union of Left and Right - - Global => null, - Post => - Length (Union'Result) = - Length (Left) - Num_Overlaps (Left, Right) + Length (Right) - and Left <= Union'Result - and Right <= Union'Result - and Included_In_Union (Union'Result, Left, Right); - - 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). - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - type Private_Key is private; - - function Iter_First (Container : Set) return Private_Key with - Global => null; - - function Iter_Has_Element - (Container : Set; - Key : Private_Key) return Boolean - with - Global => null; - - function Iter_Next - (Container : Set; - Key : Private_Key) return Private_Key - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - - function Iter_Element - (Container : Set; - Key : Private_Key) return Element_Type - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Contains); - -private - - pragma SPARK_Mode (Off); - - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - function "=" - (Left : Element_Type; - Right : Element_Type) return Boolean renames Equivalent_Elements; - - package Containers is new Ada.Containers.Functional_Base - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - type Set is record - Content : Containers.Container; - end record; - - type Private_Key is new Count_Type; - - function Iter_First (Container : Set) return Private_Key is (1); - - function Iter_Has_Element - (Container : Set; - Key : Private_Key) return Boolean - is - (Count_Type (Key) in 1 .. Containers.Length (Container.Content)); - - function Iter_Next - (Container : Set; - Key : Private_Key) return Private_Key - is - (if Key = Private_Key'Last then 0 else Key + 1); +package Ada.Containers.Functional_Sets with SPARK_Mode is - function Iter_Element - (Container : Set; - Key : Private_Key) return Element_Type - is - (Containers.Get (Container.Content, Count_Type (Key))); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Functional_Sets; diff --git a/gcc/ada/libgnat/a-cofuve.adb b/gcc/ada/libgnat/a-cofuve.adb deleted file mode 100644 index 0d91da5..0000000 --- a/gcc/ada/libgnat/a-cofuve.adb +++ /dev/null @@ -1,262 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_VECTORS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-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_Vectors with SPARK_Mode => Off is - use Containers; - - --------- - -- "<" -- - --------- - - function "<" (Left : Sequence; Right : Sequence) return Boolean is - (Length (Left.Content) < Length (Right.Content) - and then (for all I in Index_Type'First .. Last (Left) => - Get (Left.Content, I) = Get (Right.Content, I))); - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left : Sequence; Right : Sequence) return Boolean is - (Length (Left.Content) <= Length (Right.Content) - and then (for all I in Index_Type'First .. Last (Left) => - Get (Left.Content, I) = Get (Right.Content, I))); - - --------- - -- "=" -- - --------- - - function "=" (Left : Sequence; Right : Sequence) return Boolean is - (Left.Content = Right.Content); - - --------- - -- Add -- - --------- - - function Add - (Container : Sequence; - New_Item : Element_Type) return Sequence - is - (Content => - Add (Container.Content, - Index_Type'Val (Index_Type'Pos (Index_Type'First) + - Length (Container.Content)), - New_Item)); - - function Add - (Container : Sequence; - Position : Index_Type; - New_Item : Element_Type) return Sequence - is - (Content => Add (Container.Content, Position, New_Item)); - - -------------------- - -- Constant_Range -- - -------------------- - - function Constant_Range - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Item : Element_Type) return Boolean is - begin - for I in Fst .. Lst loop - if Get (Container.Content, I) /= Item then - return False; - end if; - end loop; - - return True; - end Constant_Range; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Item : Element_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if Get (Container.Content, I) = Item then - return True; - end if; - end loop; - - return False; - end Contains; - - -------------------- - -- Empty_Sequence -- - -------------------- - - function Empty_Sequence return Sequence is - ((others => <>)); - - ------------------ - -- Equal_Except -- - ------------------ - - function Equal_Except - (Left : Sequence; - Right : Sequence; - Position : Index_Type) return Boolean - is - begin - if Length (Left.Content) /= Length (Right.Content) then - return False; - end if; - - for I in Index_Type'First .. Last (Left) loop - if I /= Position - and then Get (Left.Content, I) /= Get (Right.Content, I) - then - return False; - end if; - end loop; - - return True; - end Equal_Except; - - function Equal_Except - (Left : Sequence; - Right : Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - is - begin - if Length (Left.Content) /= Length (Right.Content) then - return False; - end if; - - for I in Index_Type'First .. Last (Left) loop - if I /= X and then I /= Y - and then Get (Left.Content, I) /= Get (Right.Content, I) - then - return False; - end if; - end loop; - - return True; - end Equal_Except; - - --------- - -- Get -- - --------- - - function Get (Container : Sequence; - Position : Extended_Index) return Element_Type - is - (Get (Container.Content, Position)); - - ---------- - -- Last -- - ---------- - - function Last (Container : Sequence) return Extended_Index is - (Index_Type'Val - ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container))); - - ------------ - -- Length -- - ------------ - - function Length (Container : Sequence) return Count_Type is - (Length (Container.Content)); - - ----------------- - -- Range_Equal -- - ----------------- - - function Range_Equal - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index) return Boolean - is - begin - for I in Fst .. Lst loop - if Get (Left, I) /= Get (Right, I) then - return False; - end if; - end loop; - - return True; - end Range_Equal; - - ------------------- - -- Range_Shifted -- - ------------------- - - function Range_Shifted - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Offset : Count_Type'Base) return Boolean - is - begin - for I in Fst .. Lst loop - if Get (Left, I) /= - Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset)) - then - return False; - end if; - end loop; - return True; - end Range_Shifted; - - ------------ - -- Remove -- - ------------ - - function Remove - (Container : Sequence; - Position : Index_Type) return Sequence - is - (Content => Remove (Container.Content, Position)); - - --------- - -- Set -- - --------- - - function Set - (Container : Sequence; - Position : Index_Type; - New_Item : Element_Type) return Sequence - is - (Content => Set (Container.Content, Position, New_Item)); - -end Ada.Containers.Functional_Vectors; diff --git a/gcc/ada/libgnat/a-cofuve.ads b/gcc/ada/libgnat/a-cofuve.ads index 8622221..da0611e 100644 --- a/gcc/ada/libgnat/a-cofuve.ads +++ b/gcc/ada/libgnat/a-cofuve.ads @@ -29,383 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -pragma Ada_2012; -private with Ada.Containers.Functional_Base; - generic - type Index_Type is (<>); - -- To avoid Constraint_Error being raised at run time, Index_Type'Base - -- should have at least one more element at the low end than Index_Type. - - type Element_Type (<>) is private; - with function "=" (Left, Right : Element_Type) return Boolean 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; - -- Index_Type with one more element at the low end of the range. - -- This type is never used but it forces GNATprove to check that there is - -- room for one more element at the low end of Index_Type. - - 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 Count_Type with - -- Length of a sequence - - Global => null, - Post => - (Index_Type'Pos (Index_Type'First) - 1) + Length'Result <= - Index_Type'Pos (Index_Type'Last); - - function Get - (Container : Sequence; - Position : Extended_Index) return Element_Type - -- Access the Element at position Position in Container - - with - Global => null, - Pre => Position in Index_Type'First .. Last (Container); - - function Last (Container : Sequence) return Extended_Index with - -- Last index of a sequence - - Global => null, - Post => - Last'Result = - Index_Type'Val ((Index_Type'Pos (Index_Type'First) - 1) + - Length (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last); - - function First return Extended_Index is (Index_Type'First) with - Global => null; - -- First index of a sequence - - ------------------------ - -- 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 Index_Type'First .. Last (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 Index_Type'First .. Last (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 Index_Type'First .. Last (Left) => - Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "<="); - - function Contains - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - 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 I in Fst .. Lst => Get (Container, I) = Item); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Constant_Range - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - 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 I in Fst .. Lst => Get (Container, I) = Item); - pragma Annotate (GNATprove, Inline_For_Proof, Constant_Range); - - function Equal_Except - (Left : Sequence; - Right : Sequence; - Position : Index_Type) 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 I in Index_Type'First .. Last (Left) => - (if I /= Position then Get (Left, I) = Get (Right, I)))); - pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); - - function Equal_Except - (Left : Sequence; - Right : Sequence; - X : Index_Type; - Y : Index_Type) 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 I in Index_Type'First .. Last (Left) => - (if I /= X and I /= Y then - Get (Left, I) = Get (Right, I)))); - pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); - - function Range_Equal - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index) 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 I in Fst .. Lst => Get (Left, I) = Get (Right, I)); - pragma Annotate (GNATprove, Inline_For_Proof, Range_Equal); - - function Range_Shifted - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Offset : Count_Type'Base) 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 Offset < 0 then - Index_Type'Pos (Index_Type'Base'First) - Offset <= - Index_Type'Pos (Index_Type'First)) - and then - (if Fst <= Lst then - Offset in - Index_Type'Pos (Index_Type'First) - Index_Type'Pos (Fst) .. - (Index_Type'Pos (Index_Type'First) - 1) + Length (Right) - - Index_Type'Pos (Lst)), - Post => - Range_Shifted'Result = - ((for all I in Fst .. Lst => - Get (Left, I) = - Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset))) - and - (for all I in Index_Type'Val (Index_Type'Pos (Fst) + Offset) .. - Index_Type'Val (Index_Type'Pos (Lst) + Offset) - => - Get (Left, Index_Type'Val (Index_Type'Pos (I) - Offset)) = - Get (Right, I))); - 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 : Index_Type; - 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 in Index_Type'First .. 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, - Pre => - Length (Container) < Count_Type'Last - and then Last (Container) < Index_Type'Last, - 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 : Index_Type; - 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 => - Length (Container) < Count_Type'Last - and then Last (Container) < Index_Type'Last - and then Position <= Extended_Index'Succ (Last (Container)), - 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 => Index_Type'First, - Lst => Index_Type'Pred (Position)) - and then Range_Shifted - (Left => Container, - Right => Add'Result, - Fst => Position, - Lst => Last (Container), - Offset => 1); - - function Remove - (Container : Sequence; - Position : Index_Type) 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 in Index_Type'First .. Last (Container), - Post => - Length (Remove'Result) = Length (Container) - 1 - and then Range_Equal - (Left => Container, - Right => Remove'Result, - Fst => Index_Type'First, - Lst => Index_Type'Pred (Position)) - 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 Extended_Index with - Global => null; - - function Iter_Has_Element - (Container : Sequence; - Position : Extended_Index) return Boolean - with - Global => null, - Post => - Iter_Has_Element'Result = - (Position in Index_Type'First .. Last (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element); - - function Iter_Next - (Container : Sequence; - Position : Extended_Index) return Extended_Index - with - Global => null, - Pre => Iter_Has_Element (Container, Position); - -private - - pragma SPARK_Mode (Off); - - package Containers is new Ada.Containers.Functional_Base - (Index_Type => Index_Type, - Element_Type => Element_Type); - - type Sequence is record - Content : Containers.Container; - end record; - - function Iter_First (Container : Sequence) return Extended_Index is - (Index_Type'First); - - function Iter_Next - (Container : Sequence; - Position : Extended_Index) return Extended_Index - is - (if Position = Extended_Index'Last then - Extended_Index'First - else - Extended_Index'Succ (Position)); +package Ada.Containers.Functional_Vectors with SPARK_Mode is - function Iter_Has_Element - (Container : Sequence; - Position : Extended_Index) return Boolean - is - (Position in Index_Type'First .. - (Index_Type'Val - ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container)))); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Functional_Vectors; diff --git a/gcc/ada/libgnat/a-coinve.adb b/gcc/ada/libgnat/a-coinve.adb index c84175a..46d6730 100644 --- a/gcc/ada/libgnat/a-coinve.adb +++ b/gcc/ada/libgnat/a-coinve.adb @@ -197,12 +197,29 @@ is Count : Count_Type) is begin - -- In the general case, we pass the buck to Insert, but for efficiency, - -- we check for the usual case where Count = 1 and the vector has enough - -- room for at least one more element. + -- In the general case, we take the slow path; for efficiency, + -- we check for the common case where Count = 1 . - if Count = 1 - and then Container.Elements /= null + if Count = 1 then + Append (Container, New_Item); + else + Append_Slow_Path (Container, New_Item, Count); + end if; + end Append; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out Vector; + New_Item : Element_Type) + is + begin + -- For performance, check for the common special case where the + -- container already has room for at least one more element. + -- In the general case, pass the buck to Insert. + + if Container.Elements /= null and then Container.Last /= Container.Elements.Last then TC_Check (Container.TC); @@ -223,23 +240,11 @@ is Container.Elements.EA (New_Last) := new Element_Type'(New_Item); Container.Last := New_Last; end; - else - Append_Slow_Path (Container, New_Item, Count); + Insert (Container, Last_Index (Container) + 1, New_Item, 1); end if; end Append; - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; - New_Item : Element_Type) - is - begin - Insert (Container, Last_Index (Container) + 1, New_Item, 1); - end Append; - ---------------------- -- Append_Slow_Path -- ---------------------- diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb index 3a2adae..751d468 100644 --- a/gcc/ada/libgnat/a-convec.adb +++ b/gcc/ada/libgnat/a-convec.adb @@ -173,27 +173,11 @@ is Count : Count_Type) is begin - -- In the general case, we pass the buck to Insert, but for efficiency, - -- we check for the usual case where Count = 1 and the vector has enough - -- room for at least one more element. - - if Count = 1 - and then Container.Elements /= null - and then Container.Last /= Container.Elements.Last - then - TC_Check (Container.TC); - - -- Increment Container.Last after assigning the New_Item, so we - -- leave the Container unmodified in case Finalize/Adjust raises - -- an exception. - - declare - New_Last : constant Index_Type := Container.Last + 1; - begin - Container.Elements.EA (New_Last) := New_Item; - Container.Last := New_Last; - end; + -- In the general case, we take the slow path; for efficiency, + -- we check for the common case where Count = 1 . + if Count = 1 then + Append (Container, New_Item); else Append_Slow_Path (Container, New_Item, Count); end if; @@ -222,7 +206,28 @@ is New_Item : Element_Type) is begin - Insert (Container, Last_Index (Container) + 1, New_Item, 1); + -- For performance, check for the common special case where the + -- container already has room for at least one more element. + -- In the general case, pass the buck to Insert. + + if Container.Elements /= null + and then Container.Last /= Container.Elements.Last + then + TC_Check (Container.TC); + + -- Increment Container.Last after assigning the New_Item, so we + -- leave the Container unmodified in case Finalize/Adjust raises + -- an exception. + + declare + New_Last : constant Index_Type := Container.Last + 1; + begin + Container.Elements.EA (New_Last) := New_Item; + Container.Last := New_Last; + end; + else + Insert (Container, Last_Index (Container) + 1, New_Item, 1); + end if; end Append; ---------------------- diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads index 8888a8c..fed41ec 100644 --- a/gcc/ada/libgnat/a-coorse.ads +++ b/gcc/ada/libgnat/a-coorse.ads @@ -57,9 +57,9 @@ is type Set is tagged private with Constant_Indexing => Constant_Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; - -- Aggregate => (Empty => Empty, - -- Add_Unnamed => Include); + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Include); pragma Preelaborable_Initialization (Set); diff --git a/gcc/ada/libgnat/a-nbnbig.ads b/gcc/ada/libgnat/a-nbnbig.ads index f574e78..3979f14 100644 --- a/gcc/ada/libgnat/a-nbnbig.ads +++ b/gcc/ada/libgnat/a-nbnbig.ads @@ -32,6 +32,8 @@ package Ada.Numerics.Big_Numbers.Big_Integers_Ghost with Ghost, Pure is + pragma Annotate (GNATprove, Always_Return, Big_Integers_Ghost); + type Big_Integer is private with Integer_Literal => From_Universal_Image; diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb index 77780f9..e092db0 100644 --- a/gcc/ada/libgnat/a-strmap.adb +++ b/gcc/ada/libgnat/a-strmap.adb @@ -290,6 +290,7 @@ is loop pragma Loop_Invariant (Seq1 (Seq1'First .. J) = Seq2 (Seq2'First .. J)); + pragma Loop_Variant (Increases => J); if J = Positive'Last then return; @@ -440,6 +441,7 @@ is (Character'Pos (C) >= Character'Pos (C'Loop_Entry)); pragma Loop_Invariant (for all Char in C'Loop_Entry .. C => not Set (Char)); + pragma Loop_Variant (Increases => C); exit when C = Character'Last; C := Character'Succ (C); end loop; @@ -457,6 +459,7 @@ is pragma Loop_Invariant (for all Char in C'Loop_Entry .. C => (if Char /= C then Set (Char))); + pragma Loop_Variant (Increases => C); exit when not Set (C) or else C = Character'Last; C := Character'Succ (C); end loop; @@ -491,6 +494,7 @@ is pragma Loop_Invariant (for all Span of Max_Ranges (1 .. Range_Num) => (for all Char in Span.Low .. Span.High => Set (Char))); + pragma Loop_Variant (Increases => Range_Num); end loop; return Max_Ranges (1 .. Range_Num); diff --git a/gcc/ada/libgnat/a-strsea.adb b/gcc/ada/libgnat/a-strsea.adb index 71a415f..652c797 100644 --- a/gcc/ada/libgnat/a-strsea.adb +++ b/gcc/ada/libgnat/a-strsea.adb @@ -113,6 +113,7 @@ package body Ada.Strings.Search with SPARK_Mode is pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); pragma Loop_Invariant (Ind >= Source'First); + pragma Loop_Variant (Increases => Ind); end loop; -- Mapped case @@ -142,6 +143,7 @@ package body Ada.Strings.Search with SPARK_Mode is null; pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); pragma Loop_Invariant (Ind >= Source'First); + pragma Loop_Variant (Increases => Ind); end loop; end if; @@ -200,6 +202,7 @@ package body Ada.Strings.Search with SPARK_Mode is null; pragma Loop_Invariant (Num <= Ind - (Source'First - 1)); pragma Loop_Invariant (Ind >= Source'First); + pragma Loop_Variant (Increases => Ind); end loop; return Num; diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb index e301564..831a18e 100644 --- a/gcc/ada/libgnat/a-strsup.adb +++ b/gcc/ada/libgnat/a-strsup.adb @@ -1651,10 +1651,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is raise Index_Error; end if; - if High >= Low then - Result.Data (1 .. High - Low + 1) := Source.Data (Low .. High); - Result.Current_Length := High - Low + 1; - end if; + Result.Current_Length := (if Low > High then 0 else High - Low + 1); + Result.Data (1 .. Result.Current_Length) := + Source.Data (Low .. High); end return; end Super_Slice; @@ -1671,12 +1670,8 @@ package body Ada.Strings.Superbounded with SPARK_Mode is raise Index_Error; end if; - if High >= Low then - Target.Data (1 .. High - Low + 1) := Source.Data (Low .. High); - Target.Current_Length := High - Low + 1; - else - Target.Current_Length := 0; - end if; + Target.Current_Length := (if Low > High then 0 else High - Low + 1); + Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); end Super_Slice; ---------------- diff --git a/gcc/ada/libgnat/a-stwisu.adb b/gcc/ada/libgnat/a-stwisu.adb index a615ff3..d325676 100644 --- a/gcc/ada/libgnat/a-stwisu.adb +++ b/gcc/ada/libgnat/a-stwisu.adb @@ -1497,7 +1497,7 @@ package body Ada.Strings.Wide_Superbounded is raise Index_Error; end if; - Result.Current_Length := High - Low + 1; + Result.Current_Length := (if Low > High then 0 else High - Low + 1); Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); end return; end Super_Slice; @@ -1513,10 +1513,10 @@ package body Ada.Strings.Wide_Superbounded is or else High > Source.Current_Length then raise Index_Error; - else - Target.Current_Length := High - Low + 1; - Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); end if; + + Target.Current_Length := (if Low > High then 0 else High - Low + 1); + Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); end Super_Slice; ---------------- diff --git a/gcc/ada/libgnat/a-stzsup.adb b/gcc/ada/libgnat/a-stzsup.adb index d973993..6153bbe 100644 --- a/gcc/ada/libgnat/a-stzsup.adb +++ b/gcc/ada/libgnat/a-stzsup.adb @@ -1498,11 +1498,11 @@ package body Ada.Strings.Wide_Wide_Superbounded is or else High > Source.Current_Length then raise Index_Error; - else - Result.Current_Length := High - Low + 1; - Result.Data (1 .. Result.Current_Length) := - Source.Data (Low .. High); end if; + + Result.Current_Length := (if Low > High then 0 else High - Low + 1); + Result.Data (1 .. Result.Current_Length) := + Source.Data (Low .. High); end return; end Super_Slice; @@ -1517,10 +1517,10 @@ package body Ada.Strings.Wide_Wide_Superbounded is or else High > Source.Current_Length then raise Index_Error; - else - Target.Current_Length := High - Low + 1; - Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); end if; + + Target.Current_Length := (if Low > High then 0 else High - Low + 1); + Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); end Super_Slice; ---------------- diff --git a/gcc/ada/libgnat/s-aridou.adb b/gcc/ada/libgnat/s-aridou.adb index b40e4c3..52f2360 100644 --- a/gcc/ada/libgnat/s-aridou.adb +++ b/gcc/ada/libgnat/s-aridou.adb @@ -126,7 +126,7 @@ is Pre => B /= 0; -- Length doubling remainder - function Big_2xx (N : Natural) return Big_Integer is + function Big_2xx (N : Natural) return Big_Positive is (Big (Double_Uns'(2 ** N))) with Ghost, @@ -141,6 +141,13 @@ is with Ghost; -- X1&X2&X3 as a big integer + function Big3 (X1, X2, X3 : Big_Integer) return Big_Integer is + (Big_2xxSingle * Big_2xxSingle * X1 + + Big_2xxSingle * X2 + + X3) + with Ghost; + -- Version of Big3 on big integers + function Le3 (X1, X2, X3, Y1, Y2, Y3 : Single_Uns) return Boolean with Post => Le3'Result = (Big3 (X1, X2, X3) <= Big3 (Y1, Y2, Y3)); @@ -234,6 +241,17 @@ is Pre => X /= Double_Uns'Last, Post => Big (X + Double_Uns'(1)) = Big (X) + 1; + procedure Lemma_Big_Of_Double_Uns (X : Double_Uns) + with + Ghost, + Post => Big (X) < Big_2xxDouble; + + procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns) + with + Ghost, + Post => Big (Double_Uns (X)) >= 0 + and then Big (Double_Uns (X)) < Big_2xxSingle; + procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural) with Ghost, @@ -447,9 +465,9 @@ is 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; + Pre => (X >= 0 and then Y >= 0) + or else (X <= 0 and then Y <= 0), + Post => X * Y >= 0; procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) with @@ -458,6 +476,13 @@ is or else (X >= Big_0 and then Y <= Big_0), Post => X * Y <= Big_0; + procedure Lemma_Mult_Positive (X, Y : Big_Integer) + with + Ghost, + Pre => (X > Big_0 and then Y > Big_0) + or else (X < Big_0 and then Y < Big_0), + Post => X * Y > Big_0; + procedure Lemma_Neg_Div (X, Y : Big_Integer) with Ghost, @@ -604,6 +629,8 @@ is procedure Lemma_Abs_Range (X : Big_Integer) is null; procedure Lemma_Add_Commutation (X : Double_Uns; Y : Single_Uns) is null; procedure Lemma_Add_One (X : Double_Uns) is null; + procedure Lemma_Big_Of_Double_Uns (X : Double_Uns) is null; + procedure Lemma_Big_Of_Double_Uns_Of_Single_Uns (X : Single_Uns) is null; procedure Lemma_Bounded_Powers_Of_2_Increasing (M, N : Natural) is null; procedure Lemma_Deep_Mult_Commutation (Factor : Big_Integer; @@ -638,6 +665,7 @@ is procedure Lemma_Mult_Distribution (X, Y, Z : Big_Integer) is null; procedure Lemma_Mult_Non_Negative (X, Y : Big_Integer) is null; procedure Lemma_Mult_Non_Positive (X, Y : Big_Integer) is null; + procedure Lemma_Mult_Positive (X, Y : Big_Integer) is null; procedure Lemma_Neg_Rem (X, Y : Big_Integer) is null; procedure Lemma_Not_In_Range_Big2xx64 is null; procedure Lemma_Powers (A : Big_Natural; B, C : Natural) is null; @@ -1888,7 +1916,7 @@ is -- Local ghost variables - Mult : constant Big_Integer := abs (Big (X) * Big (Y)) with Ghost; + Mult : constant Big_Natural := abs (Big (X) * Big (Y)) with Ghost; Quot : Big_Integer with Ghost; Big_R : Big_Integer with Ghost; Big_Q : Big_Integer with Ghost; @@ -1955,6 +1983,15 @@ is -- Proves correctness of the multiplication of divisor by quotient to -- compute amount to subtract. + procedure Prove_Mult_Decomposition_Split3 + (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer) + with + Ghost, + Pre => Is_Mult_Decomposition (D1, D2, D3, D4) + and then D3 = Big_2xxSingle * D3_Hi + D3_Lo, + Post => Is_Mult_Decomposition (D1, D2 + D3_Hi, D3_Lo, D4); + -- Proves decomposition of Mult after splitting third component + procedure Prove_Negative_Dividend with Ghost, @@ -2066,6 +2103,27 @@ is else abs Quot); -- Proves correctness of the rounding of the unsigned quotient + procedure Prove_Scaled_Mult_Decomposition_Regroup24 + (D1, D2, D3, D4 : Big_Integer) + with + Ghost, + Pre => Scale < Double_Size + and then Is_Scaled_Mult_Decomposition (D1, D2, D3, D4), + Post => Is_Scaled_Mult_Decomposition + (0, Big_2xxSingle * D1 + D2, 0, Big_2xxSingle * D3 + D4); + -- Proves scaled decomposition of Mult after regrouping on second and + -- fourth component. + + procedure Prove_Scaled_Mult_Decomposition_Regroup3 + (D1, D2, D3, D4 : Big_Integer) + with + Ghost, + Pre => Scale < Double_Size + and then Is_Scaled_Mult_Decomposition (D1, D2, D3, D4), + Post => Is_Scaled_Mult_Decomposition (0, 0, Big3 (D1, D2, D3), D4); + -- Proves scaled decomposition of Mult after regrouping on third + -- component. + procedure Prove_Sign_R with Ghost, @@ -2315,6 +2373,14 @@ is + Big (Double_Uns (S3)))); end Prove_Multiplication; + ------------------------------------- + -- Prove_Mult_Decomposition_Split3 -- + ------------------------------------- + + procedure Prove_Mult_Decomposition_Split3 + (D1, D2, D3, D3_Hi, D3_Lo, D4 : Big_Integer) + is null; + ----------------------------- -- Prove_Negative_Dividend -- ----------------------------- @@ -2413,6 +2479,22 @@ is end if; end Prove_Rounding_Case; + ----------------------------------------------- + -- Prove_Scaled_Mult_Decomposition_Regroup24 -- + ----------------------------------------------- + + procedure Prove_Scaled_Mult_Decomposition_Regroup24 + (D1, D2, D3, D4 : Big_Integer) + is null; + + ---------------------------------------------- + -- Prove_Scaled_Mult_Decomposition_Regroup3 -- + ---------------------------------------------- + + procedure Prove_Scaled_Mult_Decomposition_Regroup3 + (D1, D2, D3, D4 : Big_Integer) + is null; + ------------------ -- Prove_Sign_R -- ------------------ @@ -2585,29 +2667,15 @@ is 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)))))); + Prove_Mult_Decomposition_Split3 + (D1 => 0, + D2 => Big (Double_Uns'(Xhi * Yhi)) + Big (Double_Uns (D (2))) + + Big (Double_Uns (Hi (T1))), + D3 => Big (T2), + D3_Hi => Big (Double_Uns (Hi (T2))), + D3_Lo => Big (Double_Uns (Lo (T2))), + D4 => Big (Double_Uns (D (4)))); D (3) := Lo (T2); T3 := D (2) + Hi (T1); @@ -2807,8 +2875,20 @@ is pragma Assert (Mult >= Big_2xxSingle * Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (1)))); + Lemma_Double_Big_2xxSingle; + Lemma_Mult_Positive (Big_2xxDouble, Big_2xxSingle); + Lemma_Ge_Mult (Big (Double_Uns (D (1))), + 1, + Big_2xxDouble * Big_2xxSingle, + Big_2xxDouble * Big_2xxSingle); + Lemma_Mult_Positive (Big_2xxSingle, Big (Double_Uns (D (1)))); + Lemma_Ge_Mult (Big_2xxSingle * Big_2xxSingle, Big_2xxDouble, + Big_2xxSingle * Big (Double_Uns (D (1))), + Big_2xxDouble * Big_2xxSingle); pragma Assert (Mult >= Big_2xxDouble * Big_2xxSingle); Lemma_Ge_Commutation (2 ** Single_Size, Zu); + Lemma_Ge_Mult (Big_2xxSingle, Big (Zu), Big_2xxDouble, + Big_2xxDouble * Big (Zu)); pragma Assert (Mult >= Big_2xxDouble * Big (Zu)); else Lemma_Ge_Commutation (Double_Uns (D (2)), Zu); @@ -2887,6 +2967,13 @@ is Post => Shift / 2 = 2 ** (Log_Single_Size - (Inter + 1)) and then (Shift = 2 or (Shift / 2) mod 2 = 0); + procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns) + with + Ghost, + Pre => Prev /= 0 + and then (Prev and Mask) = 0, + Post => (Prev and not Mask) /= 0; + procedure Prove_Shift_Progress with Ghost, @@ -2918,6 +3005,7 @@ is -- Local lemma null bodies -- ----------------------------- + procedure Prove_Prev_And_Mask (Prev, Mask : Single_Uns) is null; procedure Prove_Power is null; procedure Prove_Shifting is null; procedure Prove_Shift_Progress is null; @@ -2941,6 +3029,15 @@ is if (Hi (Zu) and Mask) = 0 then Zu := Shift_Left (Zu, Shift); + pragma Assert ((Hi (Zu_Prev) and Mask_Prev) /= 0); + pragma Assert + (By ((Hi (Zu_Prev) and Mask_Prev and Mask) = 0, + (Hi (Zu_Prev) and Mask) = 0 + and then + (Hi (Zu_Prev) and Mask_Prev and Mask) + = (Hi (Zu_Prev) and Mask and Mask_Prev) + )); + Prove_Prev_And_Mask (Hi (Zu_Prev) and Mask_Prev, Mask); Prove_Shifting; pragma Assert (Big (Zu_Prev) = Big (Double_Uns'(abs Z)) * Big_2xx (Scale)); @@ -2986,6 +3083,7 @@ is -- not change the invariant that (D (1) & D (2)) < Zu. Lemma_Lt_Commutation (D (1) & D (2), abs Z); + Lemma_Big_Of_Double_Uns (Zu); Lemma_Lt_Mult (Big (D (1) & D (2)), Big (Double_Uns'(abs Z)), Big_2xx (Scale), Big_2xxDouble); @@ -3007,82 +3105,21 @@ is * 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))) - + Big_2xxSingle * Big (Double_Uns (D (2))) - + 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)); + pragma Assert (Mult >= Big_0); + pragma Assert (Big_2xx (Scale) >= Big_0); + Lemma_Mult_Non_Negative (Mult, Big_2xx (Scale)); Lemma_Div_Lt (Mult * Big_2xx (Scale), Big (Zu), Big_2xxDouble); Lemma_Concat_Definition (D (1), D (2)); Lemma_Double_Big_2xxSingle; - 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))))); + Prove_Scaled_Mult_Decomposition_Regroup24 + (Big (Double_Uns (D (1))), + Big (Double_Uns (D (2))), + Big (Double_Uns (D (3))), + Big (Double_Uns (D (4)))); Lemma_Substitution (Mult * Big_2xx (Scale), Big_2xxSingle * Big_2xxSingle, Big_2xxSingle * Big (Double_Uns (D (1))) @@ -3115,10 +3152,20 @@ is -- Local ghost variables Qd1 : Single_Uns := 0 with Ghost; + D234 : Big_Integer := 0 with Ghost; D123 : constant Big_Integer := Big3 (D (1), D (2), D (3)) with Ghost; + D4 : constant Big_Integer := Big (Double_Uns (D (4))) + with Ghost; begin + Prove_Scaled_Mult_Decomposition_Regroup3 + (Big (Double_Uns (D (1))), + Big (Double_Uns (D (2))), + Big (Double_Uns (D (3))), + Big (Double_Uns (D (4)))); + pragma Assert (Mult * Big_2xx (Scale) = Big_2xxSingle * D123 + D4); + for J in 1 .. 2 loop Lemma_Hi_Lo (D (J) & D (J + 1), D (J), D (J + 1)); pragma Assert (Big (D (J) & D (J + 1)) < Big (Zu)); @@ -3138,6 +3185,7 @@ is Qd (J) := Single_Uns'Last; Lemma_Concat_Definition (D (J), D (J + 1)); + Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 2)); pragma Assert (Big_2xxSingle > Big (Double_Uns (D (J + 2)))); pragma Assert (Big3 (D (J), D (J + 1), 0) + Big_2xxSingle > Big3 (D (J), D (J + 1), D (J + 2))); @@ -3158,6 +3206,8 @@ is Lemma_Div_Lt (Big3 (D (J), D (J + 1), D (J + 2)), Big_2xxSingle, Big (Zu)); + pragma Assert (Big (Double_Uns (Qd (J))) >= + Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu)); else Qd (J) := Lo ((D (J) & D (J + 1)) / Zhi); @@ -3165,6 +3215,7 @@ is Prove_Qd_Calculation_Part_1 (J); end if; + pragma Assert (for all K in 1 .. J => Qd (K)'Initialized); Lemma_Gt_Mult (Big (Double_Uns (Qd (J))), Big3 (D (J), D (J + 1), D (J + 2)) / Big (Zu), @@ -3199,7 +3250,9 @@ is Lemma_Hi_Lo_3 (Zu, Zhi, Zlo); while not Le3 (S1, S2, S3, D (J), D (J + 1), D (J + 2)) loop - pragma Loop_Invariant (Qd (J)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. J => Qd (K)'Initialized); + pragma Loop_Invariant (if J = 2 then Qd (1) = Qd1); pragma Loop_Invariant (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu)); pragma Loop_Invariant @@ -3240,6 +3293,7 @@ is -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step + pragma Assert (for all K in 1 .. J => Qd (K)'Initialized); pragma Assert (Big3 (S1, S2, S3) = Big (Double_Uns (Qd (J))) * Big (Zu)); pragma Assert (Big3 (S1, S2, S3) > @@ -3256,19 +3310,32 @@ is * Big_2xxSingle * Big (Double_Uns (D (J))) + Big_2xxSingle * Big (Double_Uns (D (J + 1))) + Big (Double_Uns (D (J + 2)))); - pragma Assert (Big3 (D (J), D (J + 1), D (J + 2)) = - 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); + Lemma_Big_Of_Double_Uns_Of_Single_Uns (D (J + 1)); pragma Assert (Big (Double_Uns (D (J + 1))) >= 0); + Lemma_Mult_Non_Negative + (Big_2xxSingle, Big (Double_Uns (D (J + 1)))); pragma Assert - (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)))); + (By (Big3 (D (J), D (J + 1), D (J + 2)) >= + Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (D (J))), + By (Big3 (D (J), D (J + 1), D (J + 2)) + - Big_2xxSingle * Big_2xxSingle + * Big (Double_Uns (D (J))) + = Big_2xxSingle * Big (Double_Uns (D (J + 1))) + + Big (Double_Uns (D (J + 2))), + Big3 (D (J), D (J + 1), D (J + 2)) = + Big_2xxSingle + * Big_2xxSingle * Big (Double_Uns (D (J))) + + Big_2xxSingle * Big (Double_Uns (D (J + 1))) + + Big (Double_Uns (D (J + 2)))) + and then + By (Big_2xxSingle * Big (Double_Uns (D (J + 1))) + + Big (Double_Uns (D (J + 2))) >= 0, + Big_2xxSingle * Big (Double_Uns (D (J + 1))) >= 0 + and then + Big (Double_Uns (D (J + 2))) >= 0 + ))); Lemma_Ge_Commutation (Double_Uns (D (J)), Double_Uns'(1)); Lemma_Ge_Mult (Big (Double_Uns (D (J))), Big (Double_Uns'(1)), @@ -3283,6 +3350,8 @@ is if J = 1 then Qd1 := Qd (1); + D234 := Big3 (D (2), D (3), D (4)); + pragma Assert (D4 = Big (Double_Uns (D (4)))); Lemma_Substitution (Mult * Big_2xx (Scale), Big_2xxSingle, D123, Big3 (D (1), D (2), D (3)) + Big3 (S1, S2, S3), @@ -3291,23 +3360,38 @@ is Lemma_Substitution (Mult * Big_2xx (Scale), Big_2xxSingle, Big3 (S1, S2, S3), Big (Double_Uns (Qd1)) * Big (Zu), - Big3 (D (2), D (3), D (4))); + D234); else pragma Assert (Qd1 = Qd (1)); pragma Assert - (Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) - = 0); - pragma Assert - (Mult * Big_2xx (Scale) = - Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) + (By (Mult * Big_2xx (Scale) = + Big_2xxSingle * Big (Double_Uns (Qd1)) * Big (Zu) + Big3 (S1, S2, S3) - + Big3 (D (2), D (3), D (4))); + + Big3 (D (2), D (3), D (4)), + Big3 (D (2), D (3), D (4)) = D234 - Big3 (S1, S2, S3))); pragma Assert - (Mult * Big_2xx (Scale) = + (By (Mult * Big_2xx (Scale) = Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) + Big (Double_Uns (Qd (2))) * Big (Zu) + Big_2xxSingle * Big (Double_Uns (D (3))) - + Big (Double_Uns (D (4)))); + + Big (Double_Uns (D (4))), + Big_2xxSingle * Big (Double_Uns (Qd (1))) * Big (Zu) + = Big_2xxSingle * Big (Double_Uns (Qd1)) * Big (Zu) + and then + Big3 (S1, S2, S3) = Big (Double_Uns (Qd (2))) * Big (Zu) + and then + By (Big3 (D (2), D (3), D (4)) + = Big_2xxSingle * Big (Double_Uns (D (3))) + + Big (Double_Uns (D (4))), + Big3 (D (2), D (3), D (4)) + = Big_2xxSingle * Big_2xxSingle * + Big (Double_Uns (D (2))) + + Big_2xxSingle * Big (Double_Uns (D (3))) + + Big (Double_Uns (D (4))) + and then + Big_2xxSingle * Big_2xxSingle * Big (Double_Uns (D (2))) + = 0) + )); end if; end loop; end; @@ -3319,6 +3403,7 @@ is -- We rescale the divisor as well, to make the proper comparison -- for rounding below. + pragma Assert (for all K in 1 .. 2 => Qd (K)'Initialized); Qu := Qd (1) & Qd (2); Ru := D (3) & D (4); @@ -3440,14 +3525,14 @@ is Ghost, Pre => X2 < Y2, Post => Big3 (X1, X2 - Y2, X3) - = Big3 (X1, X2, X3) + Big3 (1, 0, 0) - Big3 (0, Y2, 0); + = Big3 (X1, X2, X3) + Big3 (Single_Uns'(1), 0, 0) - Big3 (0, Y2, 0); procedure Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3 : Single_Uns) with Ghost, Pre => X3 < Y3, Post => Big3 (X1, X2, X3 - Y3) - = Big3 (X1, X2, X3) + Big3 (0, 1, 0) - Big3 (0, 0, Y3); + = Big3 (X1, X2, X3) + Big3 (Single_Uns'(0), 1, 0) - Big3 (0, 0, Y3); ------------------------- -- Lemma_Add3_No_Carry -- @@ -3522,10 +3607,12 @@ is X1 := X1 - 1; pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (1, 0, 0)); + (Big3 (X1, X2, X3) = + Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(1), 0, 0)); pragma Assert (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (0, Single_Uns'Last, 0) - Big3 (0, 1, 0)); + - Big3 (Single_Uns'(0), Single_Uns'Last, 0) + - Big3 (Single_Uns'(0), 1, 0)); Lemma_Add3_No_Carry (X1, X2, X3, 0, Single_Uns'Last, 0); else Lemma_Sub3_No_Carry (X1, X2, X3, 0, 1, 0); @@ -3534,7 +3621,8 @@ is X2 := X2 - 1; pragma Assert - (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - Big3 (0, 1, 0)); + (Big3 (X1, X2, X3) = + Big3 (XX1, XX2, XX3) - Big3 (Single_Uns'(0), 1, 0)); Lemma_Sub3_With_Carry3 (X1, X2, X3, Y3); else Lemma_Sub3_No_Carry (X1, X2, X3, 0, 0, Y3); @@ -3553,7 +3641,7 @@ is pragma Assert (Big3 (X1, X2, X3) = Big3 (XX1, XX2, XX3) - - Big3 (0, 0, Y3) - Big3 (1, 0, 0)); + - Big3 (0, 0, Y3) - Big3 (Single_Uns'(1), 0, 0)); Lemma_Sub3_With_Carry2 (X1, X2, X3, Y2); else Lemma_Sub3_No_Carry (X1, X2, X3, 0, Y2, 0); diff --git a/gcc/ada/libgnat/s-aridou.ads b/gcc/ada/libgnat/s-aridou.ads index 29e13a5..08af4f5 100644 --- a/gcc/ada/libgnat/s-aridou.ads +++ b/gcc/ada/libgnat/s-aridou.ads @@ -69,6 +69,7 @@ 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 Signed_Conversion is diff --git a/gcc/ada/libgnat/s-expmod.adb b/gcc/ada/libgnat/s-expmod.adb index 527338d..f1fdf71 100644 --- a/gcc/ada/libgnat/s-expmod.adb +++ b/gcc/ada/libgnat/s-expmod.adb @@ -106,6 +106,13 @@ is ------------------- procedure Lemma_Add_Mod (X, Y : Big_Natural; B : Big_Positive) is + + procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) with + Pre => F /= 0, + Post => (Q * F + R) mod F = R mod F; + + procedure Lemma_Euclidean_Mod (Q, F, R : Big_Natural) is null; + Left : constant Big_Natural := (X + Y) mod B; Right : constant Big_Natural := ((X mod B) + (Y mod B)) mod B; XQuot : constant Big_Natural := X / B; @@ -119,6 +126,8 @@ is (Left = ((XQuot + YQuot) * B + X mod B + Y mod B) mod B); pragma Assert (X mod B + Y mod B = AQuot * B + Right); pragma Assert (Left = ((XQuot + YQuot + AQuot) * B + Right) mod B); + Lemma_Euclidean_Mod (XQuot + YQuot + AQuot, B, Right); + pragma Assert (Left = (Right mod B)); pragma Assert (Left = Right); end if; end Lemma_Add_Mod; @@ -259,6 +268,7 @@ is pragma Assert (Equal_Modulo ((Big (Result) * Big (Factor)) * Big (Factor) ** (Exp - 1), Big (Left) ** Right)); + pragma Assert (Big (Factor) >= 0); Lemma_Mult_Mod (Big (Result) * Big (Factor), Big (Factor) ** (Exp - 1), Big (Modulus)); diff --git a/gcc/ada/libgnat/s-imagef.adb b/gcc/ada/libgnat/s-imagef.adb index fd8e848..bfe8540 100644 --- a/gcc/ada/libgnat/s-imagef.adb +++ b/gcc/ada/libgnat/s-imagef.adb @@ -31,7 +31,8 @@ with System.Image_I; with System.Img_Util; use System.Img_Util; -with System.Val_Util; +with System.Value_I_Spec; +with System.Value_U_Spec; package body System.Image_F is @@ -69,70 +70,16 @@ 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. - -- 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); + package Uns_Spec is new System.Value_U_Spec (Uns); + package Int_Spec is new System.Value_I_Spec (Int, Uns, Uns_Spec.Uns_Params); + + package Image_I is new System.Image_I + (Int => Int, + Uns => Uns, + Unsigned_Width_Ghost => Unsigned_Width_Ghost, + Int_Params => Int_Spec.Int_Params); procedure Set_Image_Integer (V : Int; diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb index ff853d3..c467777 100644 --- a/gcc/ada/libgnat/s-imagei.adb +++ b/gcc/ada/libgnat/s-imagei.adb @@ -46,42 +46,6 @@ package body System.Image_I is 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 @@ -99,9 +63,9 @@ package body System.Image_I is 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)); + and then UP.Only_Decimal_Ghost (S, From => P'Old + 1, To => P) + and then UP.Scan_Based_Number_Ghost (S, From => P'Old + 1, To => P) + = UP.Wrap_Option (Uns_Of_Non_Positive (T)); -- 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. @@ -182,11 +146,12 @@ package body System.Image_I is 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; + and then UP.Only_Decimal_Ghost (S, From => 2, To => P) + and then UP.Scan_Based_Number_Ghost (S, From => 2, To => P) + = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V)), + Post => not System.Val_Util.Only_Space_Ghost (S, 1, P) + and then IP.Is_Integer_Ghost (S (1 .. P)) + and then IP.Is_Value_Integer_Ghost (S (1 .. P), V); -- Ghost lemma to prove the value of Value_Integer from the value of -- Scan_Based_Number_Ghost and the sign on a decimal string. @@ -198,17 +163,22 @@ package body System.Image_I 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); + pragma Assert (Str (2) /= ' '); + pragma Assert + (UP.Only_Decimal_Ghost (Str, From => 2, To => P)); + UP.Prove_Scan_Based_Number_Ghost_Eq (S, Str, From => 2, To => P); + pragma Assert + (UP.Scan_Based_Number_Ghost (Str, From => 2, To => P) + = UP.Wrap_Option (IP.Abs_Uns_Of_Int (V))); + IP.Prove_Scan_Only_Decimal_Ghost (Str, V); end Prove_Value_Integer; -- Start of processing for Image_Integer begin if V >= 0 then + pragma Annotate (CodePeer, False_Positive, "test always false", + "V can be positive"); S (1) := ' '; P := 1; pragma Assert (P < S'Last); @@ -226,6 +196,8 @@ package body System.Image_I is pragma Assert (P_Prev + Offset = 2); end; + pragma Assert (if V >= 0 then S (1) = ' '); + pragma Assert (S (1) in ' ' | '-'); Prove_Value_Integer; end Image_Integer; @@ -248,42 +220,78 @@ package body System.Image_I is 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) + procedure Prove_Character_Val (RU : Uns; RI : Non_Positive) 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'; + Post => RU rem 10 in 0 .. 9 + and then -(RI rem 10) in 0 .. 9 + and then Character'Val (48 + RU rem 10) in '0' .. '9' + and then Character'Val (48 - RI rem 10) in '0' .. '9'; -- Ghost lemma to prove the value of a character corresponding to the -- next figure. + procedure Prove_Euclidian (Val, Quot, Rest : Uns) + with + Ghost, + Pre => Quot = Val / 10 + and then Rest = Val rem 10, + Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest; + -- Ghost lemma to prove the relation between the quotient/remainder of + -- division by 10 and the initial value. + procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) with Ghost, Pre => RU in 0 .. 9 and then RI in 0 .. 9, - Post => Hexa_To_Unsigned_Ghost (Character'Val (48 + RU)) = RU - and then Hexa_To_Unsigned_Ghost (Character'Val (48 + RI)) = Uns (RI); + Post => UP.Hexa_To_Unsigned_Ghost + (Character'Val (48 + RU)) = RU + and then UP.Hexa_To_Unsigned_Ghost + (Character'Val (48 + RI)) = Uns (RI); -- Ghost lemma to prove that Hexa_To_Unsigned_Ghost returns the source -- figure when applied to the corresponding character. - procedure Prove_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_Scan_Iter + (S, Prev_S : String; + V, Prev_V, Res : Uns; + P, Max : Natural) + with + Ghost, + Pre => + S'First = Prev_S'First and then S'Last = Prev_S'Last + and then S'Last < Natural'Last and then + Max in S'Range and then P in S'First .. Max and then + (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9') + and then (for all I in P + 1 .. Max => Prev_S (I) = S (I)) + and then S (P) in '0' .. '9' + and then V <= Uns'Last / 10 + and then Uns'Last - UP.Hexa_To_Unsigned_Ghost (S (P)) + >= 10 * V + and then Prev_V = + V * 10 + UP.Hexa_To_Unsigned_Ghost (S (P)) + and then + (if P = Max then Prev_V = Res + else UP.Scan_Based_Number_Ghost + (Str => Prev_S, + From => P + 1, + To => Max, + Base => 10, + Acc => Prev_V) = UP.Wrap_Option (Res)), + Post => + (for all I in P .. Max => S (I) in '0' .. '9') + and then UP.Scan_Based_Number_Ghost + (Str => S, + From => P, + To => Max, + Base => 10, + Acc => V) = UP.Wrap_Option (Res); + -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved + -- through an iteration of the loop. procedure Prove_Uns_Of_Non_Positive_Value with @@ -294,50 +302,44 @@ package body System.Image_I is -- 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_Character_Val (RU : Uns; RI : Non_Positive) is null; + procedure Prove_Euclidian (Val, Quot, Rest : Uns) is null; procedure Prove_Hexa_To_Unsigned_Ghost (RU : Uns; RI : Int) is null; - procedure Prove_Unchanged is null; procedure Prove_Uns_Of_Non_Positive_Value is null; --------------------- - -- Prove_Iter_Scan -- + -- Prove_Scan_Iter -- --------------------- - procedure Prove_Iter_Scan - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) + procedure Prove_Scan_Iter + (S, Prev_S : String; + V, Prev_V, Res : Uns; + P, Max : Natural) is + pragma Unreferenced (Res); begin - Prove_Iter_Scan_Based_Number_Ghost (Str1, Str2, From, To, Base, Acc); - end Prove_Iter_Scan; + UP.Lemma_Scan_Based_Number_Ghost_Step + (Str => S, + From => P, + To => Max, + Base => 10, + Acc => V); + if P < Max then + UP.Prove_Scan_Based_Number_Ghost_Eq + (Prev_S, S, P + 1, Max, 10, Prev_V); + else + UP.Lemma_Scan_Based_Number_Ghost_Base + (Str => S, + From => P + 1, + To => Max, + Base => 10, + Acc => Prev_V); + end if; + end Prove_Scan_Iter; -- Start of processing for Set_Digits @@ -383,13 +385,9 @@ package body System.Image_I is 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_Character_Val (Uns_Value, Value); 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; @@ -399,68 +397,44 @@ package body System.Image_I is 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'); + Prove_Euclidian + (Val => Prev_Value, + Quot => Uns_Value, + Rest => UP.Hexa_To_Unsigned_Ghost (S (P + J))); - 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)); + Prove_Scan_Iter + (S, Prev_S, Uns_Value, Prev_Value, Uns_T, P + J, P + Nb_Digits); pragma Loop_Invariant (Uns_Value = Uns_Of_Non_Positive (Value)); pragma Loop_Invariant (Uns_Value <= Uns'Last / 10); pragma Loop_Invariant (for all K in S'First .. P => S (K) = S_Init (K)); - pragma Loop_Invariant (Only_Decimal_Ghost (S, P + J, P + Nb_Digits)); + pragma Loop_Invariant + (UP.Only_Decimal_Ghost (S, P + J, P + Nb_Digits)); pragma Loop_Invariant (for all K in P + J .. P + Nb_Digits => S (K) in '0' .. '9'); pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1)); pragma Loop_Invariant (Big (Uns_Value) = Big (Uns_T) / Pow); pragma Loop_Invariant - (Scan_Based_Number_Ghost + (UP.Scan_Based_Number_Ghost (Str => S, From => P + J, To => P + Nb_Digits, Base => 10, Acc => Uns_Value) - = Wrap_Option (Uns_T)); + = UP.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 + (UP.Scan_Based_Number_Ghost (Str => S, From => P + 1, To => P + Nb_Digits, Base => 10, Acc => Uns_Value) - = Wrap_Option (Uns_T)); + = UP.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 10116d1..575c60a 100644 --- a/gcc/ada/libgnat/s-imagei.ads +++ b/gcc/ada/libgnat/s-imagei.ads @@ -48,19 +48,19 @@ pragma Assertion_Policy (Pre => Ignore, with System.Val_Util; generic + type Int is range <>; + type Uns is mod <>; - with package Int_Params is new System.Val_Util.Int_Params (<>); + Unsigned_Width_Ghost : Natural; -package System.Image_I is - - subtype Int is Int_Params.Int; - use type Int_Params.Int; + with package Int_Params is new System.Val_Util.Int_Params + (Int => Int, Uns => Uns, others => <>) + with Ghost; - 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; +package System.Image_I is + package IP renames Int_Params; + package UP renames IP.Uns_Params; + use type UP.Uns_Option; procedure Image_Integer (V : Int; @@ -69,9 +69,9 @@ package System.Image_I is with Pre => S'First = 1 and then S'Last < Integer'Last - and then S'Last >= Int_Params.Unsigned_Width_Ghost, + and then S'Last >= Unsigned_Width_Ghost, Post => P in S'Range - and then Int_Params.Value_Integer (S (1 .. P)) = V; + and then IP.Is_Value_Integer_Ghost (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. @@ -87,23 +87,23 @@ package System.Image_I is and then S'First <= S'Last and then (if V >= 0 then - P <= S'Last - Int_Params.Unsigned_Width_Ghost + 1 + P <= S'Last - Unsigned_Width_Ghost + 1 else - P <= S'Last - Int_Params.Unsigned_Width_Ghost), + P <= S'Last - Unsigned_Width_Ghost), Post => S (S'First .. P'Old) = S'Old (S'First .. P'Old) and then (declare Minus : constant Boolean := S (P'Old + 1) = '-'; Offset : constant Positive := (if V >= 0 then 1 else 2); - Abs_V : constant Uns := Int_Params.Abs_Uns_Of_Int (V); + Abs_V : constant Uns := IP.Abs_Uns_Of_Int (V); begin Minus = (V < 0) and then P in P'Old + Offset .. S'Last - and then Int_Params.Only_Decimal_Ghost + and then UP.Only_Decimal_Ghost (S, From => P'Old + Offset, To => P) - and then Int_Params.Scan_Based_Number_Ghost + and then UP.Scan_Based_Number_Ghost (S, From => P'Old + Offset, To => P) - = Int_Params.Wrap_Option (Abs_V)); + = UP.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-imageu.adb b/gcc/ada/libgnat/s-imageu.adb index 6932487..0e1c2bb 100644 --- a/gcc/ada/libgnat/s-imageu.adb +++ b/gcc/ada/libgnat/s-imageu.adb @@ -147,11 +147,12 @@ package body System.Image_U is 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; + and then Uns_Params.Only_Decimal_Ghost (S, From => 2, To => P) + and then Uns_Params.Scan_Based_Number_Ghost (S, From => 2, To => P) + = Uns_Params.Wrap_Option (V), + Post => not System.Val_Util.Only_Space_Ghost (S, 1, P) + and then Uns_Params.Is_Unsigned_Ghost (S (1 .. P)) + and then Uns_Params.Is_Value_Unsigned_Ghost (S (1 .. P), V); -- Ghost lemma to prove the value of Value_Unsigned from the value of -- Scan_Based_Number_Ghost on a decimal string. @@ -163,11 +164,15 @@ package body System.Image_U 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); + pragma Assert (S (2) /= ' '); + pragma Assert + (Uns_Params.Only_Decimal_Ghost (Str, From => 2, To => P)); + Uns_Params.Prove_Scan_Based_Number_Ghost_Eq + (S, Str, From => 2, To => P); + pragma Assert + (Uns_Params.Scan_Based_Number_Ghost (Str, From => 2, To => P) + = Uns_Params.Wrap_Option (V)); + Uns_Params.Prove_Scan_Only_Decimal_Ghost (Str, V); end Prove_Value_Unsigned; -- Start of processing for Image_Unsigned @@ -196,7 +201,6 @@ package body System.Image_U is 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; @@ -205,8 +209,8 @@ package body System.Image_U is procedure Prove_Character_Val (R : Uns) with Ghost, - Pre => R in 0 .. 9, - Post => Character'Val (48 + R) in '0' .. '9'; + Post => R rem 10 in 0 .. 9 + and then Character'Val (48 + R rem 10) in '0' .. '9'; -- Ghost lemma to prove the value of a character corresponding to the -- next figure. @@ -215,7 +219,7 @@ package body System.Image_U is Ghost, Pre => Quot = Val / 10 and then Rest = Val rem 10, - Post => Val = 10 * Quot + Rest; + Post => Uns'Last - Rest >= 10 * Quot and then Val = 10 * Quot + Rest; -- Ghost lemma to prove the relation between the quotient/remainder of -- division by 10 and the initial value. @@ -223,42 +227,46 @@ package body System.Image_U is with Ghost, Pre => R in 0 .. 9, - Post => Hexa_To_Unsigned_Ghost (Character'Val (48 + R)) = R; + Post => Uns_Params.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. + procedure Prove_Scan_Iter + (S, Prev_S : String; + V, Prev_V, Res : Uns; + P, Max : Natural) + with + Ghost, + Pre => + S'First = Prev_S'First and then S'Last = Prev_S'Last + and then S'Last < Natural'Last and then + Max in S'Range and then P in S'First .. Max and then + (for all I in P + 1 .. Max => Prev_S (I) in '0' .. '9') + and then (for all I in P + 1 .. Max => Prev_S (I) = S (I)) + and then S (P) in '0' .. '9' + and then V <= Uns'Last / 10 + and then Uns'Last - Uns_Params.Hexa_To_Unsigned_Ghost (S (P)) + >= 10 * V + and then Prev_V = + V * 10 + Uns_Params.Hexa_To_Unsigned_Ghost (S (P)) + and then + (if P = Max then Prev_V = Res + else Uns_Params.Scan_Based_Number_Ghost + (Str => Prev_S, + From => P + 1, + To => Max, + Base => 10, + Acc => Prev_V) = Uns_Params.Wrap_Option (Res)), + Post => + (for all I in P .. Max => S (I) in '0' .. '9') + and then Uns_Params.Scan_Based_Number_Ghost + (Str => S, + From => P, + To => Max, + Base => 10, + Acc => V) = Uns_Params.Wrap_Option (Res); + -- Ghost lemma to prove that Scan_Based_Number_Ghost is preserved + -- through an iteration of the loop. ----------------------------- -- Local lemma null bodies -- @@ -267,21 +275,36 @@ package body System.Image_U is 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 -- + -- Prove_Scan_Iter -- --------------------- - procedure Prove_Iter_Scan - (Str1, Str2 : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) + procedure Prove_Scan_Iter + (S, Prev_S : String; + V, Prev_V, Res : Uns; + P, Max : Natural) is + pragma Unreferenced (Res); begin - Prove_Iter_Scan_Based_Number_Ghost (Str1, Str2, From, To, Base, Acc); - end Prove_Iter_Scan; + Uns_Params.Lemma_Scan_Based_Number_Ghost_Step + (Str => S, + From => P, + To => Max, + Base => 10, + Acc => V); + if P < Max then + Uns_Params.Prove_Scan_Based_Number_Ghost_Eq + (Prev_S, S, P + 1, Max, 10, Prev_V); + else + Uns_Params.Lemma_Scan_Based_Number_Ghost_Base + (Str => S, + From => P + 1, + To => Max, + Base => 10, + Acc => Prev_V); + end if; + end Prove_Scan_Iter; -- Start of processing for Set_Image_Unsigned @@ -313,6 +336,7 @@ package body System.Image_U is Lemma_Non_Zero (Value); pragma Assert (Pow <= Big (Uns'Last)); end loop; + pragma Assert (Big (V) / (Big_10 ** Nb_Digits) = 0); Value := V; Pow := 1; @@ -323,77 +347,43 @@ package body System.Image_U is 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_Character_Val (Value); Prove_Hexa_To_Unsigned_Ghost (Value rem 10); Prev_Value := Value; Prev_S := S; Pow := Pow * 10; - S (P + J) := Character'Val (48 + (Value rem 10)); Value := Value / 10; - 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; + Prove_Euclidian + (Val => Prev_Value, + Quot => Value, + Rest => Uns_Params.Hexa_To_Unsigned_Ghost (S (P + J))); - pragma Assert (Prev = Cur); - pragma Assert (Prev = Wrap_Option (V)); + Prove_Scan_Iter + (S, Prev_S, Value, Prev_Value, V, P + J, P + Nb_Digits); pragma Loop_Invariant (Value <= Uns'Last / 10); pragma Loop_Invariant (for all K in S'First .. P => S (K) = S_Init (K)); - pragma Loop_Invariant (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); + (Uns_Params.Only_Decimal_Ghost + (S, From => P + J, To => P + Nb_Digits)); pragma Loop_Invariant (Pow = Big_10 ** (Nb_Digits - J + 1)); pragma Loop_Invariant (Big (Value) = Big (V) / Pow); pragma Loop_Invariant - (Scan_Based_Number_Ghost + (Uns_Params.Scan_Based_Number_Ghost (Str => S, From => P + J, To => P + Nb_Digits, Base => 10, Acc => Value) - = Wrap_Option (V)); + = Uns_Params.Wrap_Option (V)); end loop; + pragma Assert (Big (Value) = Big (V) / (Big_10 ** Nb_Digits)); 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 789cf65..3d80ea9 100644 --- a/gcc/ada/libgnat/s-imageu.ads +++ b/gcc/ada/libgnat/s-imageu.ads @@ -45,45 +45,22 @@ pragma Assertion_Policy (Pre => Ignore, Ghost => Ignore, Subprogram_Variant => Ignore); +with System.Val_Util; + 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; + with package Uns_Params is new System.Val_Util.Uns_Params + (Uns => Uns, others => <>) + with Ghost; package System.Image_U is + use all type Uns_Params.Uns_Option; procedure Image_Unsigned (V : Uns; @@ -94,7 +71,7 @@ package System.Image_U is 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; + and then Uns_Params.Is_Value_Unsigned_Ghost (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 @@ -112,9 +89,10 @@ package System.Image_U is 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); + and then Uns_Params.Only_Decimal_Ghost (S, From => P'Old + 1, To => P) + and then Uns_Params.Scan_Based_Number_Ghost + (S, From => P'Old + 1, To => P) + = Uns_Params.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-imgint.ads b/gcc/ada/libgnat/s-imgint.ads index fd5bea3..8672e58 100644 --- a/gcc/ada/libgnat/s-imgint.ads +++ b/gcc/ada/libgnat/s-imgint.ads @@ -48,8 +48,6 @@ pragma Assertion_Policy (Pre => 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 @@ -57,27 +55,12 @@ package System.Img_Int is subtype Unsigned is Unsigned_Types.Unsigned; - package Int_Params is new Val_Util.Int_Params - (Int => Integer, - Uns => Unsigned, - Uns_Option => Val_Uns.Impl.Uns_Option, - Unsigned_Width_Ghost => + package Impl is new Image_I + (Int => Integer, + Uns => Unsigned, + 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 (Int_Params); + Int_Params => System.Val_Int.Impl.Spec.Int_Params); procedure Image_Integer (V : Integer; diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads index 20f108c..99c1951 100644 --- a/gcc/ada/libgnat/s-imglli.ads +++ b/gcc/ada/libgnat/s-imglli.ads @@ -48,8 +48,6 @@ pragma Assertion_Policy (Pre => 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 @@ -57,27 +55,13 @@ package System.Img_LLI is subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; - 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 (Int_Params); + package Impl is new Image_I + (Int => Long_Long_Integer, + Uns => Long_Long_Unsigned, + Unsigned_Width_Ghost => + Wid_LLU.Width_Long_Long_Unsigned + (0, Long_Long_Unsigned'Last), + Int_Params => System.Val_LLI.Impl.Spec.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 989c296..931c288 100644 --- a/gcc/ada/libgnat/s-imgllli.ads +++ b/gcc/ada/libgnat/s-imgllli.ads @@ -48,8 +48,6 @@ pragma Assertion_Policy (Pre => 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 @@ -57,28 +55,13 @@ package System.Img_LLLI is subtype Long_Long_Long_Unsigned is Unsigned_Types.Long_Long_Long_Unsigned; - 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 => + package Impl is new Image_I + (Int => Long_Long_Long_Integer, + Uns => Long_Long_Long_Unsigned, + 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 (Int_Params); + Int_Params => System.Val_LLLI.Impl.Spec.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 0116aa8..53b39a8 100644 --- a/gcc/ada/libgnat/s-imglllu.ads +++ b/gcc/ada/libgnat/s-imglllu.ads @@ -56,23 +56,11 @@ is subtype Long_Long_Long_Unsigned is Unsigned_Types.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 => + (Uns => Long_Long_Long_Unsigned, + 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); + Uns_Params => System.Val_LLLU.Impl.Spec.Uns_Params); 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 67372d7..28339cd 100644 --- a/gcc/ada/libgnat/s-imgllu.ads +++ b/gcc/ada/libgnat/s-imgllu.ads @@ -56,22 +56,10 @@ is subtype Long_Long_Unsigned is Unsigned_Types.Long_Long_Unsigned; package Impl is new Image_U - (Uns => Long_Long_Unsigned, - Uns_Option => Val_LLU.Impl.Uns_Option, - Unsigned_Width_Ghost => + (Uns => Long_Long_Unsigned, + 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); + Uns_Params => System.Val_LLU.Impl.Spec.Uns_Params); procedure Image_Long_Long_Unsigned (V : Long_Long_Unsigned; diff --git a/gcc/ada/libgnat/s-imguns.ads b/gcc/ada/libgnat/s-imguns.ads index fa903ce..120bd5d 100644 --- a/gcc/ada/libgnat/s-imguns.ads +++ b/gcc/ada/libgnat/s-imguns.ads @@ -56,22 +56,10 @@ is subtype Unsigned is Unsigned_Types.Unsigned; package Impl is new Image_U - (Uns => Unsigned, - Uns_Option => Val_Uns.Impl.Uns_Option, - Unsigned_Width_Ghost => + (Uns => Unsigned, + 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); + Uns_Params => System.Val_Uns.Impl.Spec.Uns_Params); procedure Image_Unsigned (V : Unsigned; diff --git a/gcc/ada/libgnat/s-maccod.ads b/gcc/ada/libgnat/s-maccod.ads index c3abf07..df7c7df 100644 --- a/gcc/ada/libgnat/s-maccod.ads +++ b/gcc/ada/libgnat/s-maccod.ads @@ -33,7 +33,9 @@ -- operations, and also for machine code statements. See GNAT documentation -- for full details. -package System.Machine_Code is +package System.Machine_Code + with SPARK_Mode => Off +is pragma No_Elaboration_Code_All; pragma Pure; diff --git a/gcc/ada/libgnat/s-powflt.ads b/gcc/ada/libgnat/s-powflt.ads index bf5d66f..24e22c9 100644 --- a/gcc/ada/libgnat/s-powflt.ads +++ b/gcc/ada/libgnat/s-powflt.ads @@ -29,17 +29,41 @@ -- -- ------------------------------------------------------------------------------ --- This package provides a powers of ten table used for real conversions +-- This package provides tables of powers used for real conversions package System.Powten_Flt is pragma Pure; Maxpow_Exact : constant := 10; - -- Largest power of ten exactly representable with Float. It is equal to + -- Largest power of five exactly representable with Float. It is equal to -- floor (M * log 2 / log 5), when M is the size of the mantissa (24). + -- It also works for any number of the form 5*(2**N) and in particular 10. Maxpow : constant := Maxpow_Exact * 2; - -- Largest power of ten exactly representable with a double Float + -- Largest power of five exactly representable with double Float + + Powfive : constant array (0 .. Maxpow, 1 .. 2) of Float := + [00 => [5.0**00, 0.0], + 01 => [5.0**01, 0.0], + 02 => [5.0**02, 0.0], + 03 => [5.0**03, 0.0], + 04 => [5.0**04, 0.0], + 05 => [5.0**05, 0.0], + 06 => [5.0**06, 0.0], + 07 => [5.0**07, 0.0], + 08 => [5.0**08, 0.0], + 09 => [5.0**09, 0.0], + 10 => [5.0**10, 0.0], + 11 => [5.0**11, 5.0**11 - Float'Machine (5.0**11)], + 12 => [5.0**12, 5.0**12 - Float'Machine (5.0**12)], + 13 => [5.0**13, 5.0**13 - Float'Machine (5.0**13)], + 14 => [5.0**14, 5.0**14 - Float'Machine (5.0**14)], + 15 => [5.0**15, 5.0**15 - Float'Machine (5.0**15)], + 16 => [5.0**16, 5.0**16 - Float'Machine (5.0**16)], + 17 => [5.0**17, 5.0**17 - Float'Machine (5.0**17)], + 18 => [5.0**18, 5.0**18 - Float'Machine (5.0**18)], + 19 => [5.0**19, 5.0**19 - Float'Machine (5.0**19)], + 20 => [5.0**20, 5.0**20 - Float'Machine (5.0**20)]]; Powten : constant array (0 .. Maxpow, 1 .. 2) of Float := [00 => [1.0E+00, 0.0], diff --git a/gcc/ada/libgnat/s-powlfl.ads b/gcc/ada/libgnat/s-powlfl.ads index a8612db..a627c0c 100644 --- a/gcc/ada/libgnat/s-powlfl.ads +++ b/gcc/ada/libgnat/s-powlfl.ads @@ -29,17 +29,74 @@ -- -- ------------------------------------------------------------------------------ --- This package provides a powers of ten table used for real conversions +-- This package provides tables of powers used for real conversions package System.Powten_LFlt is pragma Pure; Maxpow_Exact : constant := 22; - -- Largest power of ten exactly representable with Long_Float. It is equal + -- Largest power of five exactly representable with Long_Float. It is equal -- to floor (M * log 2 / log 5), when M is the size of the mantissa (53). + -- It also works for any number of the form 5*(2**N) and in particular 10. Maxpow : constant := Maxpow_Exact * 2; - -- Largest power of ten exactly representable with a double Long_Float + -- Largest power of five exactly representable with double Long_Float + + Powfive : constant array (0 .. Maxpow, 1 .. 2) of Long_Float := + [00 => [5.0**00, 0.0], + 01 => [5.0**01, 0.0], + 02 => [5.0**02, 0.0], + 03 => [5.0**03, 0.0], + 04 => [5.0**04, 0.0], + 05 => [5.0**05, 0.0], + 06 => [5.0**06, 0.0], + 07 => [5.0**07, 0.0], + 08 => [5.0**08, 0.0], + 09 => [5.0**09, 0.0], + 10 => [5.0**10, 0.0], + 11 => [5.0**11, 0.0], + 12 => [5.0**12, 0.0], + 13 => [5.0**13, 0.0], + 14 => [5.0**14, 0.0], + 15 => [5.0**15, 0.0], + 16 => [5.0**16, 0.0], + 17 => [5.0**17, 0.0], + 18 => [5.0**18, 0.0], + 19 => [5.0**19, 0.0], + 20 => [5.0**20, 0.0], + 21 => [5.0**21, 0.0], + 22 => [5.0**22, 0.0], + 23 => [5.0**23, 5.0**23 - Long_Float'Machine (5.0**23)], + 24 => [5.0**24, 5.0**24 - Long_Float'Machine (5.0**24)], + 25 => [5.0**25, 5.0**25 - Long_Float'Machine (5.0**25)], + 26 => [5.0**26, 5.0**26 - Long_Float'Machine (5.0**26)], + 27 => [5.0**27, 5.0**27 - Long_Float'Machine (5.0**27)], + 28 => [5.0**28, 5.0**28 - Long_Float'Machine (5.0**28)], + 29 => [5.0**29, 5.0**29 - Long_Float'Machine (5.0**29)], + 30 => [5.0**30, 5.0**30 - Long_Float'Machine (5.0**30)], + 31 => [5.0**31, 5.0**31 - Long_Float'Machine (5.0**31)], + 32 => [5.0**32, 5.0**32 - Long_Float'Machine (5.0**32)], + 33 => [5.0**33, 5.0**33 - Long_Float'Machine (5.0**33)], + 34 => [5.0**34, 5.0**34 - Long_Float'Machine (5.0**34)], + 35 => [5.0**35, 5.0**35 - Long_Float'Machine (5.0**35)], + 36 => [5.0**36, 5.0**36 - Long_Float'Machine (5.0**36)], + 37 => [5.0**37, 5.0**37 - Long_Float'Machine (5.0**37)], + 38 => [5.0**38, 5.0**38 - Long_Float'Machine (5.0**38)], + 39 => [5.0**39, 5.0**39 - Long_Float'Machine (5.0**39)], + 40 => [5.0**40, 5.0**40 - Long_Float'Machine (5.0**40)], + 41 => [5.0**41, 5.0**41 - Long_Float'Machine (5.0**41)], + 42 => [5.0**42, 5.0**42 - Long_Float'Machine (5.0**42)], + 43 => [5.0**43, 5.0**43 - Long_Float'Machine (5.0**43)], + 44 => [5.0**44, 5.0**44 - Long_Float'Machine (5.0**44)]]; + + Powfive_100 : constant array (1 .. 2) of Long_Float := + [5.0**100, 5.0**100 - Long_Float'Machine (5.0**100)]; + + Powfive_200 : constant array (1 .. 2) of Long_Float := + [5.0**200, 5.0**200 - Long_Float'Machine (5.0**200)]; + + Powfive_300 : constant array (1 .. 2) of Long_Float := + [5.0**300, 5.0**300 - Long_Float'Machine (5.0**300)]; Powten : constant array (0 .. Maxpow, 1 .. 2) of Long_Float := [00 => [1.0E+00, 0.0], diff --git a/gcc/ada/libgnat/s-powllf.ads b/gcc/ada/libgnat/s-powllf.ads index 0640ea4..4b5f1ae 100644 --- a/gcc/ada/libgnat/s-powllf.ads +++ b/gcc/ada/libgnat/s-powllf.ads @@ -29,19 +29,86 @@ -- -- ------------------------------------------------------------------------------ --- This package provides a powers of ten table used for real conversions +-- This package provides tables of powers used for real conversions package System.Powten_LLF is pragma Pure; Maxpow_Exact : constant := (if Long_Long_Float'Machine_Mantissa = 64 then 27 else 22); - -- Largest power of ten exactly representable with Long_Long_Float. It is + -- Largest power of five exactly representable with Long_Long_Float. It is -- equal to floor (M * log 2 / log 5), when M is the size of the mantissa -- assumed to be either 64 for IEEE Extended or 53 for IEEE Double. + -- It also works for any number of the form 5*(2**N) and in particular 10. Maxpow : constant := Maxpow_Exact * 2; - -- Largest power of ten exactly representable with a double Long_Long_Float + -- Largest power of five exactly representable with double Long_Long_Float + + Powfive : constant array (0 .. 54, 1 .. 2) of Long_Long_Float := + [00 => [5.0**00, 0.0], + 01 => [5.0**01, 0.0], + 02 => [5.0**02, 0.0], + 03 => [5.0**03, 0.0], + 04 => [5.0**04, 0.0], + 05 => [5.0**05, 0.0], + 06 => [5.0**06, 0.0], + 07 => [5.0**07, 0.0], + 08 => [5.0**08, 0.0], + 09 => [5.0**09, 0.0], + 10 => [5.0**10, 0.0], + 11 => [5.0**11, 0.0], + 12 => [5.0**12, 0.0], + 13 => [5.0**13, 0.0], + 14 => [5.0**14, 0.0], + 15 => [5.0**15, 0.0], + 16 => [5.0**16, 0.0], + 17 => [5.0**17, 0.0], + 18 => [5.0**18, 0.0], + 19 => [5.0**19, 0.0], + 20 => [5.0**20, 0.0], + 21 => [5.0**21, 0.0], + 22 => [5.0**22, 0.0], + 23 => [5.0**23, 5.0**23 - Long_Long_Float'Machine (5.0**23)], + 24 => [5.0**24, 5.0**24 - Long_Long_Float'Machine (5.0**24)], + 25 => [5.0**25, 5.0**25 - Long_Long_Float'Machine (5.0**25)], + 26 => [5.0**26, 5.0**26 - Long_Long_Float'Machine (5.0**26)], + 27 => [5.0**27, 5.0**27 - Long_Long_Float'Machine (5.0**27)], + 28 => [5.0**28, 5.0**28 - Long_Long_Float'Machine (5.0**28)], + 29 => [5.0**29, 5.0**29 - Long_Long_Float'Machine (5.0**29)], + 30 => [5.0**30, 5.0**30 - Long_Long_Float'Machine (5.0**30)], + 31 => [5.0**31, 5.0**31 - Long_Long_Float'Machine (5.0**31)], + 32 => [5.0**32, 5.0**32 - Long_Long_Float'Machine (5.0**32)], + 33 => [5.0**33, 5.0**33 - Long_Long_Float'Machine (5.0**33)], + 34 => [5.0**34, 5.0**34 - Long_Long_Float'Machine (5.0**34)], + 35 => [5.0**35, 5.0**35 - Long_Long_Float'Machine (5.0**35)], + 36 => [5.0**36, 5.0**36 - Long_Long_Float'Machine (5.0**36)], + 37 => [5.0**37, 5.0**37 - Long_Long_Float'Machine (5.0**37)], + 38 => [5.0**38, 5.0**38 - Long_Long_Float'Machine (5.0**38)], + 39 => [5.0**39, 5.0**39 - Long_Long_Float'Machine (5.0**39)], + 40 => [5.0**40, 5.0**40 - Long_Long_Float'Machine (5.0**40)], + 41 => [5.0**41, 5.0**41 - Long_Long_Float'Machine (5.0**41)], + 42 => [5.0**42, 5.0**42 - Long_Long_Float'Machine (5.0**42)], + 43 => [5.0**43, 5.0**43 - Long_Long_Float'Machine (5.0**43)], + 44 => [5.0**44, 5.0**44 - Long_Long_Float'Machine (5.0**44)], + 45 => [5.0**45, 5.0**45 - Long_Long_Float'Machine (5.0**45)], + 46 => [5.0**46, 5.0**46 - Long_Long_Float'Machine (5.0**46)], + 47 => [5.0**47, 5.0**47 - Long_Long_Float'Machine (5.0**47)], + 48 => [5.0**48, 5.0**48 - Long_Long_Float'Machine (5.0**48)], + 49 => [5.0**49, 5.0**49 - Long_Long_Float'Machine (5.0**49)], + 50 => [5.0**50, 5.0**50 - Long_Long_Float'Machine (5.0**50)], + 51 => [5.0**51, 5.0**51 - Long_Long_Float'Machine (5.0**51)], + 52 => [5.0**52, 5.0**52 - Long_Long_Float'Machine (5.0**52)], + 53 => [5.0**53, 5.0**53 - Long_Long_Float'Machine (5.0**53)], + 54 => [5.0**54, 5.0**54 - Long_Long_Float'Machine (5.0**54)]]; + + Powfive_100 : constant array (1 .. 2) of Long_Long_Float := + [5.0**100, 5.0**100 - Long_Long_Float'Machine (5.0**100)]; + + Powfive_200 : constant array (1 .. 2) of Long_Long_Float := + [5.0**200, 5.0**200 - Long_Long_Float'Machine (5.0**200)]; + + Powfive_300 : constant array (1 .. 2) of Long_Long_Float := + [5.0**300, 5.0**300 - Long_Long_Float'Machine (5.0**300)]; Powten : constant array (0 .. 54, 1 .. 2) of Long_Long_Float := [00 => [1.0E+00, 0.0], diff --git a/gcc/ada/libgnat/s-vaispe.adb b/gcc/ada/libgnat/s-vaispe.adb new file mode 100644 index 0000000..dca2fd7 --- /dev/null +++ b/gcc/ada/libgnat/s-vaispe.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ I _ S P E C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2022-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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore, + Subprogram_Variant => Ignore); + +package body System.Value_I_Spec is + + ----------------------------------- + -- Prove_Scan_Only_Decimal_Ghost -- + ----------------------------------- + + procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) is + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + pragma Assert (Str (Str'First + 1) /= ' '); + pragma Assert + (if Val < 0 then Non_Blank = Str'First + else + Str (Str'First) = ' ' + and then Non_Blank = Str'First + 1); + Minus : constant Boolean := Str (Non_Blank) = '-'; + Fst_Num : constant Positive := + (if Minus then Non_Blank + 1 else Non_Blank); + pragma Assert (Fst_Num = Str'First + 1); + Uval : constant Uns := Abs_Uns_Of_Int (Val); + + procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns) + with + Pre => Minus = (Val < 0) + and then Uval = Abs_Uns_Of_Int (Val), + Post => Uns_Is_Valid_Int (Minus, Uval) + and then Is_Int_Of_Uns (Minus, Uval, Val); + -- Local proof of the unicity of the signed representation + + procedure Prove_Conversion_Is_Identity (Val : Int; Uval : Uns) is null; + + -- Start of processing for Prove_Scan_Only_Decimal_Ghost + + begin + Prove_Conversion_Is_Identity (Val, Uval); + pragma Assert + (Uns_Params.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); + pragma Assert + (Uns_Params.Scan_Split_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); + Uns_Params.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, 10); + pragma Assert + (Uns_Params.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); + pragma Assert (Only_Space_Ghost + (Str, Uns_Params.Raw_Unsigned_Last_Ghost + (Str, Fst_Num, Str'Last), Str'Last)); + pragma Assert (Is_Integer_Ghost (Str)); + pragma Assert (Is_Value_Integer_Ghost (Str, Val)); + end Prove_Scan_Only_Decimal_Ghost; + +end System.Value_I_Spec; diff --git a/gcc/ada/libgnat/s-vaispe.ads b/gcc/ada/libgnat/s-vaispe.ads new file mode 100644 index 0000000..5a5e051 --- /dev/null +++ b/gcc/ada/libgnat/s-vaispe.ads @@ -0,0 +1,199 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ I _ S P E C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-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 contains the specification entities using for the formal +-- verification of the routines for scanning signed integer values. + +-- Preconditions in this unit are meant for analysis only, not for run-time +-- checking, so that the expected exceptions are raised. This is enforced by +-- setting the corresponding assertion policy to Ignore. Postconditions and +-- contract cases should not be executed at runtime as well, in order not to +-- slow down the execution of these functions. + +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore, + Subprogram_Variant => Ignore); + +with System.Val_Util; use System.Val_Util; + +generic + + type Int is range <>; + + type Uns is mod <>; + + -- Additional parameters for specification subprograms on modular Unsigned + -- integers. + + with package Uns_Params is new System.Val_Util.Uns_Params + (Uns => Uns, others => <>) + with Ghost; + +package System.Value_I_Spec with + Ghost, + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is + pragma Preelaborate; + use all type Uns_Params.Uns_Option; + + function Uns_Is_Valid_Int (Minus : Boolean; Uval : Uns) return Boolean is + (if Minus then Uval <= Uns (Int'Last) + 1 + else Uval <= Uns (Int'Last)) + with Post => True; + -- Return True if Uval (or -Uval when Minus is True) is a valid number of + -- type Int. + + function Is_Int_Of_Uns + (Minus : Boolean; + Uval : Uns; + Val : Int) + return Boolean + is + (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First + elsif Minus then Val = -(Int (Uval)) + else Val = Int (Uval)) + with + Pre => Uns_Is_Valid_Int (Minus, Uval), + Post => True; + -- Return True if Uval (or -Uval when Minus is True) is equal to Val + + function Abs_Uns_Of_Int (Val : Int) return Uns is + (if Val = Int'First then Uns (Int'Last) + 1 + elsif Val < 0 then Uns (-Val) + else Uns (Val)); + -- Return the unsigned absolute value of Val + + function Slide_To_1 (Str : String) return String + with + Post => + Only_Space_Ghost (Str, Str'First, Str'Last) = + (for all J in Str'First .. Str'Last => + Slide_To_1'Result (J - Str'First + 1) = ' '); + -- Slides Str so that it starts at 1 + + function Slide_If_Necessary (Str : String) return String is + (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str); + -- If Str'Last = Positive'Last then slides Str so that it starts at 1 + + function Is_Integer_Ghost (Str : String) return Boolean is + (declare + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + Fst_Num : constant Positive := + (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); + begin + Uns_Params.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) + and then Uns_Params.Raw_Unsigned_No_Overflow_Ghost + (Str, Fst_Num, Str'Last) + and then + Uns_Is_Valid_Int + (Minus => Str (Non_Blank) = '-', + Uval => Uns_Params.Scan_Raw_Unsigned_Ghost + (Str, Fst_Num, Str'Last)) + and then Only_Space_Ghost + (Str, Uns_Params.Raw_Unsigned_Last_Ghost + (Str, Fst_Num, Str'Last), Str'Last)) + with + Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Str'Last /= Positive'Last, + Post => True; + -- Ghost function that determines if Str has the correct format for a + -- signed number, consisting in some blank characters, an optional + -- sign, a raw unsigned number which does not overflow and then some + -- more blank characters. + + function Is_Value_Integer_Ghost (Str : String; Val : Int) return Boolean is + (declare + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + Fst_Num : constant Positive := + (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); + Uval : constant Uns := + Uns_Params.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last); + begin + Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', + Uval => Uval, + Val => Val)) + with + Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Str'Last /= Positive'Last + and then Is_Integer_Ghost (Str), + Post => True; + -- Ghost function that returns True if Val is the value corresponding to + -- the signed number represented by Str. + + procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) + with + Ghost, + Pre => Str'Last /= Positive'Last + and then Str'Length >= 2 + and then Str (Str'First) in ' ' | '-' + and then (Str (Str'First) = '-') = (Val < 0) + and then Uns_Params.Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) + and then Uns_Params.Scan_Based_Number_Ghost + (Str, Str'First + 1, Str'Last) + = Uns_Params.Wrap_Option (Abs_Uns_Of_Int (Val)), + Post => Is_Integer_Ghost (Slide_If_Necessary (Str)) + and then Is_Value_Integer_Ghost (Str, Val); + -- Ghost lemma used in the proof of 'Image implementation, to prove that + -- the result of Value_Integer on a decimal string is the same as the + -- signing the result of Scan_Based_Number_Ghost. + + -- 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. + + package Int_Params is new System.Val_Util.Int_Params + (Uns => Uns, + Int => Int, + P_Uns_Params => Uns_Params, + P_Is_Integer_Ghost => Is_Integer_Ghost, + P_Is_Value_Integer_Ghost => Is_Value_Integer_Ghost, + P_Is_Int_Of_Uns => Is_Int_Of_Uns, + P_Abs_Uns_Of_Int => Abs_Uns_Of_Int, + P_Prove_Scan_Only_Decimal_Ghost => Prove_Scan_Only_Decimal_Ghost); + +private + + ---------------- + -- Slide_To_1 -- + ---------------- + + function Slide_To_1 (Str : String) return String is + (declare + Res : constant String (1 .. Str'Length) := Str; + begin + Res); + +end System.Value_I_Spec; diff --git a/gcc/ada/libgnat/s-valflt.ads b/gcc/ada/libgnat/s-valflt.ads index 788dd8a..cc8f583 100644 --- a/gcc/ada/libgnat/s-valflt.ads +++ b/gcc/ada/libgnat/s-valflt.ads @@ -42,7 +42,10 @@ package System.Val_Flt is package Impl is new Val_Real (Float, System.Powten_Flt.Maxpow, - System.Powten_Flt.Powten'Address, + System.Powten_Flt.Powfive'Address, + System.Null_Address, + System.Null_Address, + System.Null_Address, Unsigned_Types.Unsigned); function Scan_Float diff --git a/gcc/ada/libgnat/s-valint.ads b/gcc/ada/libgnat/s-valint.ads index 9e47f1b..3872d7c 100644 --- a/gcc/ada/libgnat/s-valint.ads +++ b/gcc/ada/libgnat/s-valint.ads @@ -54,23 +54,10 @@ package System.Val_Int with SPARK_Mode is subtype Unsigned is Unsigned_Types.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); + (Int => Integer, + Uns => Unsigned, + Scan_Raw_Unsigned => Val_Uns.Scan_Raw_Unsigned, + Uns_Params => System.Val_Uns.Impl.Spec.Uns_Params); procedure Scan_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-vallfl.ads b/gcc/ada/libgnat/s-vallfl.ads index cd894cd..12be755 100644 --- a/gcc/ada/libgnat/s-vallfl.ads +++ b/gcc/ada/libgnat/s-vallfl.ads @@ -42,7 +42,10 @@ package System.Val_LFlt is package Impl is new Val_Real (Long_Float, System.Powten_LFlt.Maxpow, - System.Powten_LFlt.Powten'Address, + System.Powten_LFlt.Powfive'Address, + System.Powten_LFlt.Powfive_100'Address, + System.Powten_LFlt.Powfive_200'Address, + System.Powten_LFlt.Powfive_300'Address, Unsigned_Types.Long_Long_Unsigned); function Scan_Long_Float diff --git a/gcc/ada/libgnat/s-valllf.ads b/gcc/ada/libgnat/s-valllf.ads index 959a27d..80566c3 100644 --- a/gcc/ada/libgnat/s-valllf.ads +++ b/gcc/ada/libgnat/s-valllf.ads @@ -42,7 +42,10 @@ package System.Val_LLF is package Impl is new Val_Real (Long_Long_Float, System.Powten_LLF.Maxpow, - System.Powten_LLF.Powten'Address, + System.Powten_LLF.Powfive'Address, + System.Powten_LLF.Powfive_100'Address, + System.Powten_LLF.Powfive_200'Address, + System.Powten_LLF.Powfive_300'Address, System.Unsigned_Types.Long_Long_Unsigned); function Scan_Long_Long_Float diff --git a/gcc/ada/libgnat/s-vallli.ads b/gcc/ada/libgnat/s-vallli.ads index 5bccb1a..85bf282 100644 --- a/gcc/ada/libgnat/s-vallli.ads +++ b/gcc/ada/libgnat/s-vallli.ads @@ -54,24 +54,10 @@ package System.Val_LLI with SPARK_Mode is subtype Long_Long_Unsigned is Unsigned_Types.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); + (Int => Long_Long_Integer, + Uns => Long_Long_Unsigned, + Scan_Raw_Unsigned => Val_LLU.Scan_Raw_Long_Long_Unsigned, + Uns_Params => System.Val_LLU.Impl.Spec.Uns_Params); procedure Scan_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-valllli.ads b/gcc/ada/libgnat/s-valllli.ads index 586c737..e53fb0b 100644 --- a/gcc/ada/libgnat/s-valllli.ads +++ b/gcc/ada/libgnat/s-valllli.ads @@ -54,24 +54,10 @@ package System.Val_LLLI with SPARK_Mode is subtype Long_Long_Long_Unsigned is Unsigned_Types.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); + (Int => Long_Long_Long_Integer, + Uns => Long_Long_Long_Unsigned, + Scan_Raw_Unsigned => Val_LLLU.Scan_Raw_Long_Long_Long_Unsigned, + Uns_Params => System.Val_LLLU.Impl.Spec.Uns_Params); procedure Scan_Long_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb index c9e5505..079c48b 100644 --- a/gcc/ada/libgnat/s-valrea.adb +++ b/gcc/ada/libgnat/s-valrea.adb @@ -43,18 +43,13 @@ package body System.Val_Real is pragma Assert (Num'Machine_Mantissa <= Uns'Size); -- We need an unsigned type large enough to represent the mantissa - Need_Extra : constant Boolean := Num'Machine_Mantissa > Uns'Size - 4; - -- If the mantissa of the floating-point type is almost as large as the - -- unsigned type, we do not have enough space for an extra digit in the - -- unsigned type so we handle the extra digit separately, at the cost of - -- a bit more work in Integer_to_Real. + Is_Large_Type : constant Boolean := Num'Machine_Mantissa >= 53; + -- True if the floating-point type is at least IEEE Double - Precision_Limit : constant Uns := - (if Need_Extra then 2**Num'Machine_Mantissa - 1 else 2**Uns'Size - 1); - -- If we handle the extra digit separately, we use the precision of the - -- floating-point type so that the conversion is exact. + Precision_Limit : constant Uns := 2**Num'Machine_Mantissa - 1; + -- See below for the rationale - package Impl is new Value_R (Uns, Precision_Limit, Round => Need_Extra); + package Impl is new Value_R (Uns, 2, Precision_Limit, Round => False); subtype Base_T is Unsigned range 2 .. 16; @@ -64,18 +59,21 @@ package body System.Val_Real is Maxexp32 : constant array (Base_T) of Positive := [2 => 127, 3 => 80, 4 => 63, 5 => 55, 6 => 49, - 7 => 45, 8 => 42, 9 => 40, 10 => 38, 11 => 37, + 7 => 45, 8 => 42, 9 => 40, 10 => 55, 11 => 37, 12 => 35, 13 => 34, 14 => 33, 15 => 32, 16 => 31]; + -- The actual value for 10 is 38 but we also use scaling for 10 Maxexp64 : constant array (Base_T) of Positive := [2 => 1023, 3 => 646, 4 => 511, 5 => 441, 6 => 396, - 7 => 364, 8 => 341, 9 => 323, 10 => 308, 11 => 296, + 7 => 364, 8 => 341, 9 => 323, 10 => 441, 11 => 296, 12 => 285, 13 => 276, 14 => 268, 15 => 262, 16 => 255]; + -- The actual value for 10 is 308 but we also use scaling for 10 Maxexp80 : constant array (Base_T) of Positive := [2 => 16383, 3 => 10337, 4 => 8191, 5 => 7056, 6 => 6338, - 7 => 5836, 8 => 5461, 9 => 5168, 10 => 4932, 11 => 4736, + 7 => 5836, 8 => 5461, 9 => 5168, 10 => 7056, 11 => 4736, 12 => 4570, 13 => 4427, 14 => 4303, 15 => 4193, 16 => 4095]; + -- The actual value for 10 is 4932 but we also use scaling for 10 package Double_Real is new System.Double_Real (Num); use type Double_Real.Double_T; @@ -83,17 +81,28 @@ package body System.Val_Real is subtype Double_T is Double_Real.Double_T; -- The double floating-point type + function Exact_Log2 (N : Unsigned) return Positive is + (case N is + when 2 => 1, + when 4 => 2, + when 8 => 3, + when 16 => 4, + when others => raise Program_Error); + -- Return the exponent of a power of 2 + function Integer_to_Real (Str : String; - Val : Uns; + Val : Impl.Value_Array; Base : Unsigned; - Scale : Integer; - Extra : Unsigned; + Scale : Impl.Scale_Array; Minus : Boolean) return Num; -- Convert the real value from integer to real representation - function Large_Powten (Exp : Natural) return Double_T; - -- Return 10.0**Exp as a double number, where Exp > Maxpow + function Large_Powfive (Exp : Natural) return Double_T; + -- Return 5.0**Exp as a double number, where Exp > Maxpow + + function Large_Powfive (Exp : Natural; S : out Natural) return Double_T; + -- Return Num'Scaling (5.0**Exp, -S) as a double number where Exp > Maxexp --------------------- -- Integer_to_Real -- @@ -101,10 +110,9 @@ package body System.Val_Real is function Integer_to_Real (Str : String; - Val : Uns; + Val : Impl.Value_Array; Base : Unsigned; - Scale : Integer; - Extra : Unsigned; + Scale : Impl.Scale_Array; Minus : Boolean) return Num is pragma Assert (Base in 2 .. 16); @@ -120,9 +128,9 @@ package body System.Val_Real is else raise Program_Error); -- Maximum exponent of the base that can fit in Num - R_Val : Num; D_Val : Double_T; - S : Integer := Scale; + R_Val : Num; + S : Integer; begin -- We call the floating-point processor reset routine so we can be sure @@ -134,82 +142,78 @@ package body System.Val_Real is System.Float_Control.Reset; end if; - -- Take into account the extra digit, i.e. do the two computations - - -- (1) R_Val := R_Val * Num (B) + Num (Extra) - -- (2) S := S - 1 + -- First convert the integer mantissa into a double real. The conversion + -- of each part is exact, given the precision limit we used above. Then, + -- if the contribution of the low part might be nonnull, scale the high + -- part appropriately and add the low part to the result. - -- In the first, the three operands are exact, so using an FMA would - -- be ideal, but we are most likely running on the x87 FPU, hence we - -- may not have one. That is why we turn the multiplication into an - -- iterated addition with exact error handling, so that we can do a - -- single rounding at the end. + if Val (2) = 0 then + D_Val := Double_Real.To_Double (Num (Val (1))); + S := Scale (1); - if Need_Extra and then Extra > 0 then + else declare - B : Unsigned := Base; - Acc : Num := 0.0; - Err : Num := 0.0; - Fac : Num := Num (Val); - DS : Double_T; + V1 : constant Num := Num (Val (1)); + V2 : constant Num := Num (Val (2)); + + DS : Positive; begin - loop - -- If B is odd, add one factor. Note that the accumulator is - -- never larger than the factor at this point (it is in fact - -- never larger than the factor minus the initial value). - - if B rem 2 /= 0 then - if Acc = 0.0 then - Acc := Fac; - else - DS := Double_Real.Quick_Two_Sum (Fac, Acc); - Acc := DS.Hi; - Err := Err + DS.Lo; - end if; - exit when B = 1; - end if; + DS := Scale (1) - Scale (2); - -- Now B is (morally) even, halve it and double the factor, - -- which is always an exact operation. + case Base is + -- If the base is a power of two, we use the efficient Scaling + -- attribute up to an amount worth a double mantissa. - B := B / 2; - Fac := Fac * 2.0; - end loop; + when 2 | 4 | 8 | 16 => + declare + L : constant Positive := Exact_Log2 (Base); - -- Add Extra to the error, which are both small integers + begin + if DS <= 2 * Num'Machine_Mantissa / L then + DS := DS * L; + D_Val := + Double_Real.Quick_Two_Sum (Num'Scaling (V1, DS), V2); + S := Scale (2); - D_Val := Double_Real.Quick_Two_Sum (Acc, Err + Num (Extra)); + else + D_Val := Double_Real.To_Double (V1); + S := Scale (1); + end if; + end; - S := S - 1; - end; + -- If the base is 10, we also scale up to an amount worth a + -- double mantissa. - -- Or else, if the Extra digit is zero, do the exact conversion + when 10 => + declare + Powfive : constant array (0 .. Maxpow) of Double_T; + pragma Import (Ada, Powfive); + for Powfive'Address use Powfive_Address; - elsif Need_Extra then - D_Val := Double_Real.To_Double (Num (Val)); + begin + if DS <= Maxpow then + D_Val := Powfive (DS) * Num'Scaling (V1, DS) + V2; + S := Scale (2); - -- Otherwise, the value contains more bits than the mantissa so do the - -- conversion in two steps. + else + D_Val := Double_Real.To_Double (V1); + S := Scale (1); + end if; + end; - else - declare - Mask : constant Uns := 2**(Uns'Size - Num'Machine_Mantissa) - 1; - Hi : constant Uns := Val and not Mask; - Lo : constant Uns := Val and Mask; + -- Inaccurate implementation for other bases - begin - if Hi = 0 then - D_Val := Double_Real.To_Double (Num (Lo)); - else - D_Val := Double_Real.Quick_Two_Sum (Num (Hi), Num (Lo)); - end if; + when others => + D_Val := Double_Real.To_Double (V1); + S := Scale (1); + end case; end; end if; -- Compute the final value by applying the scaling, if any - if Val = 0 or else S = 0 then + if (Val (1) = 0 and then Val (2) = 0) or else S = 0 then R_Val := Double_Real.To_Single (D_Val); else @@ -218,67 +222,58 @@ package body System.Val_Real is -- attribute with an overflow check, if it is not 2, to catch -- ludicrous exponents that would result in an infinity or zero. - when 2 => - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); - - when 4 => - if Integer'First / 2 <= S and then S <= Integer'Last / 2 then - S := S * 2; - end if; - - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); - - when 8 => - if Integer'First / 3 <= S and then S <= Integer'Last / 3 then - S := S * 3; - end if; - - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); - - when 16 => - if Integer'First / 4 <= S and then S <= Integer'Last / 4 then - S := S * 4; - end if; + when 2 | 4 | 8 | 16 => + declare + L : constant Positive := Exact_Log2 (Base); - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); + begin + if Integer'First / L <= S and then S <= Integer'Last / L then + S := S * L; + end if; - -- If the base is 10, use a double implementation for the sake - -- of accuracy, to be removed when exponentiation is improved. + R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); + end; - -- When the exponent is positive, we can do the computation - -- directly because, if the exponentiation overflows, then - -- the final value overflows as well. But when the exponent - -- is negative, we may need to do it in two steps to avoid - -- an artificial underflow. + -- If the base is 10, we use a double implementation for the sake + -- of accuracy combining powers of 5 and scaling attribute. Using + -- this combination is better than using powers of 10 only because + -- the Large_Powfive function may overflow only if the final value + -- will also either overflow or underflow, thus making it possible + -- to use a single division for the case of negative powers of 10. when 10 => declare - Powten : constant array (0 .. Maxpow) of Double_T; - pragma Import (Ada, Powten); - for Powten'Address use Powten_Address; + Powfive : constant array (0 .. Maxpow) of Double_T; + pragma Import (Ada, Powfive); + for Powfive'Address use Powfive_Address; + + RS : Natural; begin if S > 0 then if S <= Maxpow then - D_Val := D_Val * Powten (S); + D_Val := D_Val * Powfive (S); else - D_Val := D_Val * Large_Powten (S); + D_Val := D_Val * Large_Powfive (S); end if; else - if S < -Maxexp then - D_Val := D_Val / Large_Powten (Maxexp); - S := S + Maxexp; - end if; - if S >= -Maxpow then - D_Val := D_Val / Powten (-S); + D_Val := D_Val / Powfive (-S); + + -- For small types, typically IEEE Single, the trick + -- described above does not fully work. + + elsif not Is_Large_Type and then S < -Maxexp then + D_Val := D_Val / Large_Powfive (-S, RS); + S := S - RS; + else - D_Val := D_Val / Large_Powten (-S); + D_Val := D_Val / Large_Powfive (-S); end if; end if; - R_Val := Double_Real.To_Single (D_Val); + R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); end; -- Implementation for other bases with exponentiation @@ -320,14 +315,26 @@ package body System.Val_Real is when Constraint_Error => Bad_Value (Str); end Integer_to_Real; - ------------------ - -- Large_Powten -- - ------------------ + ------------------- + -- Large_Powfive -- + ------------------- + + function Large_Powfive (Exp : Natural) return Double_T is + Powfive : constant array (0 .. Maxpow) of Double_T; + pragma Import (Ada, Powfive); + for Powfive'Address use Powfive_Address; + + Powfive_100 : constant Double_T; + pragma Import (Ada, Powfive_100); + for Powfive_100'Address use Powfive_100_Address; + + Powfive_200 : constant Double_T; + pragma Import (Ada, Powfive_200); + for Powfive_200'Address use Powfive_200_Address; - function Large_Powten (Exp : Natural) return Double_T is - Powten : constant array (0 .. Maxpow) of Double_T; - pragma Import (Ada, Powten); - for Powten'Address use Powten_Address; + Powfive_300 : constant Double_T; + pragma Import (Ada, Powfive_300); + for Powfive_300'Address use Powfive_300_Address; R : Double_T; E : Natural; @@ -335,18 +342,80 @@ package body System.Val_Real is begin pragma Assert (Exp > Maxpow); - R := Powten (Maxpow); + if Is_Large_Type and then Exp >= 300 then + R := Powfive_300; + E := Exp - 300; + + elsif Is_Large_Type and then Exp >= 200 then + R := Powfive_200; + E := Exp - 200; + + elsif Is_Large_Type and then Exp >= 100 then + R := Powfive_100; + E := Exp - 100; + + else + R := Powfive (Maxpow); + E := Exp - Maxpow; + end if; + + while E > Maxpow loop + R := R * Powfive (Maxpow); + E := E - Maxpow; + end loop; + + R := R * Powfive (E); + + return R; + end Large_Powfive; + + function Large_Powfive (Exp : Natural; S : out Natural) return Double_T is + Maxexp : constant Positive := + (if Num'Size = 32 then Maxexp32 (5) + elsif Num'Size = 64 then Maxexp64 (5) + elsif Num'Machine_Mantissa = 64 then Maxexp80 (5) + else raise Program_Error); + -- Maximum exponent of 5 that can fit in Num + + Powfive : constant array (0 .. Maxpow) of Double_T; + pragma Import (Ada, Powfive); + for Powfive'Address use Powfive_Address; + + R : Double_T; + E : Natural; + + begin + pragma Assert (Exp > Maxexp); + + pragma Warnings (Off, "-gnatw.a"); + pragma Assert (not Is_Large_Type); + pragma Warnings (On, "-gnatw.a"); + + R := Powfive (Maxpow); E := Exp - Maxpow; + -- If the exponent is not too large, then scale down the result so that + -- its final value does not overflow but, if it's too large, then do not + -- bother doing it since overflow is just fine. The scaling factor is -3 + -- for every power of 5 above the maximum, in other words division by 8. + + if Exp - Maxexp <= Maxpow then + S := 3 * (Exp - Maxexp); + R.Hi := Num'Scaling (R.Hi, -S); + R.Lo := Num'Scaling (R.Lo, -S); + else + S := 0; + end if; + while E > Maxpow loop - R := R * Powten (Maxpow); + R := R * Powfive (Maxpow); E := E - Maxpow; end loop; - R := R * Powten (E); + R := R * Powfive (E); return R; - end Large_Powten; + end Large_Powfive; --------------- -- Scan_Real -- @@ -358,15 +427,15 @@ package body System.Val_Real is Max : Integer) return Num is Base : Unsigned; - Scale : Integer; + Scale : Impl.Scale_Array; Extra : Unsigned; Minus : Boolean; - Val : Uns; + Val : Impl.Value_Array; begin Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scale, Extra, Minus); - return Integer_to_Real (Str, Val, Base, Scale, Extra, Minus); + return Integer_to_Real (Str, Val, Base, Scale, Minus); end Scan_Real; ---------------- @@ -375,15 +444,15 @@ package body System.Val_Real is function Value_Real (Str : String) return Num is Base : Unsigned; - Scale : Integer; + Scale : Impl.Scale_Array; Extra : Unsigned; Minus : Boolean; - Val : Uns; + Val : Impl.Value_Array; begin Val := Impl.Value_Raw_Real (Str, Base, Scale, Extra, Minus); - return Integer_to_Real (Str, Val, Base, Scale, Extra, Minus); + return Integer_to_Real (Str, Val, Base, Scale, Minus); end Value_Real; end System.Val_Real; diff --git a/gcc/ada/libgnat/s-valrea.ads b/gcc/ada/libgnat/s-valrea.ads index 1d55fc9..89be8d7 100644 --- a/gcc/ada/libgnat/s-valrea.ads +++ b/gcc/ada/libgnat/s-valrea.ads @@ -38,7 +38,13 @@ generic Maxpow : Positive; - Powten_Address : System.Address; + Powfive_Address : System.Address; + + Powfive_100_Address : System.Address; + + Powfive_200_Address : System.Address; + + Powfive_300_Address : System.Address; type Uns is mod <>; diff --git a/gcc/ada/libgnat/s-valued.adb b/gcc/ada/libgnat/s-valued.adb index c4a78a2..92e9140 100644 --- a/gcc/ada/libgnat/s-valued.adb +++ b/gcc/ada/libgnat/s-valued.adb @@ -38,7 +38,7 @@ package body System.Value_D is pragma Assert (Int'Size <= Uns'Size); -- We need an unsigned type large enough to represent the mantissa - package Impl is new Value_R (Uns, 2**(Int'Size - 1), Round => False); + package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => False); -- We do not use the Extra digit for decimal fixed-point types function Integer_to_Decimal @@ -229,16 +229,16 @@ package body System.Value_D is Max : Integer; Scale : Integer) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus); + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus); - return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); + return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale); end Scan_Decimal; ------------------- @@ -246,16 +246,16 @@ package body System.Value_D is ------------------- function Value_Decimal (Str : String; Scale : Integer) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus); + Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus); - return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); + return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale); end Value_Decimal; end System.Value_D; diff --git a/gcc/ada/libgnat/s-valuef.adb b/gcc/ada/libgnat/s-valuef.adb index e252a28..1b9d18e 100644 --- a/gcc/ada/libgnat/s-valuef.adb +++ b/gcc/ada/libgnat/s-valuef.adb @@ -46,7 +46,7 @@ package body System.Value_F is pragma Assert (Int'Size <= Uns'Size); -- We need an unsigned type large enough to represent the mantissa - package Impl is new Value_R (Uns, 2**(Int'Size - 1), Round => True); + package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => True); -- We use the Extra digit for ordinary fixed-point types function Integer_To_Fixed @@ -332,16 +332,17 @@ package body System.Value_F is Num : Int; Den : Int) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus); + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus); - return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den); + return + Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den); end Scan_Fixed; ----------------- @@ -353,16 +354,17 @@ package body System.Value_F is Num : Int; Den : Int) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus); + Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus); - return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den); + return + Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den); end Value_Fixed; end System.Value_F; diff --git a/gcc/ada/libgnat/s-valuei.adb b/gcc/ada/libgnat/s-valuei.adb index b453ffc..51764b2 100644 --- a/gcc/ada/libgnat/s-valuei.adb +++ b/gcc/ada/libgnat/s-valuei.adb @@ -41,59 +41,6 @@ package body System.Value_I is 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 -- ------------------ @@ -104,6 +51,25 @@ package body System.Value_I is Max : Integer; Res : out Int) is + procedure Prove_Is_Int_Of_Uns + (Minus : Boolean; + Uval : Uns; + Val : Int) + with Ghost, + Pre => Spec.Uns_Is_Valid_Int (Minus, Uval) + and then + (if Minus and then Uval = Uns (Int'Last) + 1 then Val = Int'First + elsif Minus then Val = -(Int (Uval)) + else Val = Int (Uval)), + Post => Spec.Is_Int_Of_Uns (Minus, Uval, Val); + -- Unfold the definition of Is_Int_Of_Uns + + procedure Prove_Is_Int_Of_Uns + (Minus : Boolean; + Uval : Uns; + Val : Int) + is null; + Uval : Uns; -- Unsigned result @@ -131,7 +97,8 @@ package body System.Value_I is end if; Scan_Raw_Unsigned (Str, Ptr, Max, Uval); - pragma Assert (Uval = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max)); + pragma Assert + (Uval = Uns_Params.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max)); -- Deal with overflow cases, and also with largest negative number @@ -152,6 +119,11 @@ package body System.Value_I is else Res := Int (Uval); end if; + + Prove_Is_Int_Of_Uns + (Minus => Str (Non_Blank) = '-', + Uval => Uval, + Val => Res); end Scan_Integer; ------------------- @@ -167,7 +139,15 @@ package body System.Value_I is if Str'Last = Positive'Last then declare subtype NT is String (1 .. Str'Length); + procedure Prove_Is_Integer_Ghost with + Ghost, + Pre => Str'Length < Natural'Last + and then not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Spec.Is_Integer_Ghost (Spec.Slide_To_1 (Str)), + Post => Spec.Is_Integer_Ghost (NT (Str)); + procedure Prove_Is_Integer_Ghost is null; begin + Prove_Is_Integer_Ghost; return Value_Integer (NT (Str)); end; @@ -187,8 +167,6 @@ package body System.Value_I is else Non_Blank) with Ghost; begin - pragma Assert - (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); declare P_Acc : constant not null access Integer := P'Access; @@ -197,12 +175,13 @@ package body System.Value_I is end; pragma Assert - (P = Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last)); + (P = Uns_Params.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)); + (Spec.Is_Value_Integer_Ghost (Spec.Slide_If_Necessary (Str), V)); return V; end; end if; diff --git a/gcc/ada/libgnat/s-valuei.ads b/gcc/ada/libgnat/s-valuei.ads index 5e42773..3f78db6 100644 --- a/gcc/ada/libgnat/s-valuei.ads +++ b/gcc/ada/libgnat/s-valuei.ads @@ -39,6 +39,7 @@ pragma Assertion_Policy (Pre => Ignore, Subprogram_Variant => Ignore); with System.Val_Util; use System.Val_Util; +with System.Value_I_Spec; generic @@ -54,71 +55,15 @@ generic -- 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; + with package Uns_Params is new System.Val_Util.Uns_Params + (Uns => Uns, others => <>) + with Ghost; package System.Value_I is pragma Preelaborate; + use all type Uns_Params.Uns_Option; - function Uns_Is_Valid_Int (Minus : Boolean; Uval : Uns) return Boolean is - (if Minus then Uval <= Uns (Int'Last) + 1 - else Uval <= Uns (Int'Last)) - with 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 + package Spec is new System.Value_I_Spec (Int, Uns, Uns_Params); procedure Scan_Integer (Str : String; @@ -139,11 +84,13 @@ package System.Value_I is (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 + Uns_Params.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max)) + and then Uns_Params.Raw_Unsigned_No_Overflow_Ghost + (Str, Fst_Num, Max) + and then Spec.Uns_Is_Valid_Int (Minus => Str (Non_Blank) = '-', - Uval => Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max))), + Uval => Uns_Params.Scan_Raw_Unsigned_Ghost + (Str, Fst_Num, Max))), Post => (declare Non_Blank : constant Positive := First_Non_Space_Ghost @@ -152,12 +99,13 @@ package System.Value_I is (if Str (Non_Blank) in '+' | '-' then Non_Blank + 1 else Non_Blank); Uval : constant Uns := - Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max); + Uns_Params.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)); + Spec.Is_Int_Of_Uns (Minus => Str (Non_Blank) = '-', + Uval => Uval, + Val => Res) + and then Ptr.all = Uns_Params.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 @@ -183,111 +131,17 @@ 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 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), + and then Spec.Is_Integer_Ghost (Spec.Slide_If_Necessary (Str)), + Post => Spec.Is_Value_Integer_Ghost + (Spec.Slide_If_Necessary (Str), Value_Integer'Result), Subprogram_Variant => (Decreases => Str'First); -- 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 b474f84..c55444a 100644 --- a/gcc/ada/libgnat/s-valuer.adb +++ b/gcc/ada/libgnat/s-valuer.adb @@ -44,22 +44,23 @@ package body System.Value_R is procedure Round_Extra (Digit : Char_As_Digit; + Base : Unsigned; Value : in out Uns; Scale : in out Integer; - Extra : in out Char_As_Digit; - Base : Unsigned); + Extra : in out Char_As_Digit); -- Round the triplet (Value, Scale, Extra) according to Digit in Base procedure Scan_Decimal_Digits (Str : String; Index : in out Integer; Max : Integer; - Value : in out Uns; - Scale : in out Integer; - Extra : in out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean); + Base_Specified : Boolean; + Value : in out Value_Array; + Scale : in out Scale_Array; + N : in out Positive; + Extra : in out Char_As_Digit; + Base_Violation : in out Boolean); -- Scan the decimal part of a real (i.e. after decimal separator) -- -- The string parsed is Str (Index .. Max) and after the call Index will @@ -77,12 +78,13 @@ package body System.Value_R is (Str : String; Index : in out Integer; Max : Integer; - Value : out Uns; - Scale : out Integer; - Extra : out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean); + Base_Specified : Boolean; + Value : out Value_Array; + Scale : out Scale_Array; + N : out Positive; + Extra : out Char_As_Digit; + Base_Violation : in out Boolean); -- Scan the integral part of a real (i.e. before decimal separator) -- -- The string parsed is Str (Index .. Max) and after the call Index will @@ -123,10 +125,10 @@ package body System.Value_R is procedure Round_Extra (Digit : Char_As_Digit; + Base : Unsigned; Value : in out Uns; Scale : in out Integer; - Extra : in out Char_As_Digit; - Base : Unsigned) + Extra : in out Char_As_Digit) is pragma Assert (Base in 2 .. 16); @@ -145,7 +147,7 @@ package body System.Value_R is Extra := Char_As_Digit (Value mod B); Value := Value / B; Scale := Scale + 1; - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value, Scale, Extra); else Extra := 0; @@ -166,12 +168,13 @@ package body System.Value_R is (Str : String; Index : in out Integer; Max : Integer; - Value : in out Uns; - Scale : in out Integer; - Extra : in out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean) + Base_Specified : Boolean; + Value : in out Value_Array; + Scale : in out Scale_Array; + N : in out Positive; + Extra : in out Char_As_Digit; + Base_Violation : in out Boolean) is pragma Assert (Base in 2 .. 16); @@ -184,7 +187,7 @@ package body System.Value_R is UmaxB : constant Uns := Precision_Limit / Uns (Base); -- Numbers bigger than UmaxB overflow if multiplied by base - Precision_Limit_Reached : Boolean := False; + Precision_Limit_Reached : Boolean; -- Set to True if addition of a digit will cause Value to be superior -- to Precision_Limit. @@ -198,23 +201,28 @@ package body System.Value_R is Temp : Uns; -- Temporary - Trailing_Zeros : Natural := 0; + Trailing_Zeros : Natural; -- Number of trailing zeros at a given point begin -- If initial Scale is not 0 then it means that Precision_Limit was -- reached during scanning of the integral part. - if Scale > 0 then + if Scale (Data_Index'Last) > 0 then Precision_Limit_Reached := True; else Extra := 0; + Precision_Limit_Reached := False; end if; if Round then Precision_Limit_Just_Reached := False; end if; + -- Initialize trailing zero counter + + Trailing_Zeros := 0; + -- The function precondition is that the first character is a valid -- digit. @@ -242,7 +250,7 @@ package body System.Value_R is if Precision_Limit_Reached then if Round and then Precision_Limit_Just_Reached then - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value (N), Scale (N), Extra); Precision_Limit_Just_Reached := False; end if; @@ -253,19 +261,24 @@ package body System.Value_R is Trailing_Zeros := Trailing_Zeros + 1; else - -- Handle accumulated zeros. + -- Handle accumulated zeros for J in 1 .. Trailing_Zeros loop - if Value <= UmaxB then - Value := Value * Uns (Base); - Scale := Scale - 1; + if Value (N) <= UmaxB then + Value (N) := Value (N) * Uns (Base); + Scale (N) := Scale (N) - 1; + + elsif Parts > 1 and then N < Data_Index'Last then + N := N + 1; + Scale (N) := Scale (N - 1) - 1; else Extra := 0; Precision_Limit_Reached := True; if Round and then J = Trailing_Zeros then - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value (N), Scale (N), Extra); end if; + exit; end if; end loop; @@ -276,7 +289,7 @@ package body System.Value_R is -- Handle current non zero digit - Temp := Value * Uns (Base) + Uns (Digit); + Temp := Value (N) * Uns (Base) + Uns (Digit); -- Precision_Limit_Reached may have been set above @@ -287,15 +300,20 @@ package body System.Value_R is -- account that Temp may wrap around when Precision_Limit is -- equal to the largest integer. - elsif Value <= Umax - or else (Value <= UmaxB + elsif Value (N) <= Umax + or else (Value (N) <= UmaxB and then ((Precision_Limit < Uns'Last and then Temp <= Precision_Limit) or else (Precision_Limit = Uns'Last and then Temp >= Uns (Base)))) then - Value := Temp; - Scale := Scale - 1; + Value (N) := Temp; + Scale (N) := Scale (N) - 1; + + elsif Parts > 1 and then N < Data_Index'Last then + N := N + 1; + Value (N) := Uns (Digit); + Scale (N) := Scale (N - 1) - 1; else Extra := Digit; @@ -347,12 +365,13 @@ package body System.Value_R is (Str : String; Index : in out Integer; Max : Integer; - Value : out Uns; - Scale : out Integer; - Extra : out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean) + Base_Specified : Boolean; + Value : out Value_Array; + Scale : out Scale_Array; + N : out Positive; + Extra : out Char_As_Digit; + Base_Violation : in out Boolean) is pragma Assert (Base in 2 .. 16); @@ -362,7 +381,7 @@ package body System.Value_R is UmaxB : constant Uns := Precision_Limit / Uns (Base); -- Numbers bigger than UmaxB overflow if multiplied by base - Precision_Limit_Reached : Boolean := False; + Precision_Limit_Reached : Boolean; -- Set to True if addition of a digit will cause Value to be superior -- to Precision_Limit. @@ -377,12 +396,15 @@ package body System.Value_R is -- Temporary begin - -- Initialize Value, Scale and Extra + -- Initialize N, Value, Scale and Extra - Value := 0; - Scale := 0; + N := 1; + Value := (others => 0); + Scale := (others => 0); Extra := 0; + Precision_Limit_Reached := False; + if Round then Precision_Limit_Just_Reached := False; end if; @@ -415,28 +437,32 @@ package body System.Value_R is -- should continue only to assess the validity of the string. if Precision_Limit_Reached then - Scale := Scale + 1; + Scale (N) := Scale (N) + 1; if Round and then Precision_Limit_Just_Reached then - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value (N), Scale (N), Extra); Precision_Limit_Just_Reached := False; end if; else - Temp := Value * Uns (Base) + Uns (Digit); + Temp := Value (N) * Uns (Base) + Uns (Digit); -- Check if Temp is larger than Precision_Limit, taking into -- account that Temp may wrap around when Precision_Limit is -- equal to the largest integer. - if Value <= Umax - or else (Value <= UmaxB + if Value (N) <= Umax + or else (Value (N) <= UmaxB and then ((Precision_Limit < Uns'Last and then Temp <= Precision_Limit) or else (Precision_Limit = Uns'Last and then Temp >= Uns (Base)))) then - Value := Temp; + Value (N) := Temp; + + elsif Parts > 1 and then N < Data_Index'Last then + N := N + 1; + Value (N) := Uns (Digit); else Extra := Digit; @@ -444,10 +470,16 @@ package body System.Value_R is if Round then Precision_Limit_Just_Reached := True; end if; - Scale := Scale + 1; + Scale (N) := Scale (N) + 1; end if; end if; + -- Every parsed digit also scales the previous parts + + for J in 1 .. N - 1 loop + Scale (J) := Scale (J) + 1; + end loop; + -- Look for the next character Index := Index + 1; @@ -485,37 +517,44 @@ package body System.Value_R is Ptr : not null access Integer; Max : Integer; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns + Minus : out Boolean) return Value_Array is pragma Assert (Max <= Str'Last); After_Point : Boolean; -- True if a decimal should be parsed - Base_Char : Character := ASCII.NUL; - -- Character used to set the base. If Nul this means that default + Base_Char : Character; + -- Character used to set the base. If it is Nul, this means that default -- base is used. - Base_Violation : Boolean := False; + Base_Violation : Boolean; -- If True some digits where not in the base. The real is still scanned -- till the end even if an error will be raised. + N : Positive; + -- Index number of the current part + + Expon : Integer; + -- Exponent as an integer + Index : Integer; -- Local copy of string pointer Start : Positive; + -- Index of the first non-blank character - Value : Uns; - -- Mantissa as an Integer - - Expon : Integer; + Value : Value_Array; + -- Mantissa as an array of integers begin -- The default base is 10 - Base := 10; + Base := 10; + Base_Char := ASCII.NUL; + Base_Violation := False; -- We do not tolerate strings with Str'Last = Positive'Last @@ -543,8 +582,8 @@ package body System.Value_R is -- part or the base to use. Scan_Integral_Digits - (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), - Base_Violation, Base, Base_Specified => False); + (Str, Index, Max, Base, False, Value, Scale, N, + Char_As_Digit (Extra), Base_Violation); -- A dot is allowed only if followed by a digit (RM 3.5(47)) @@ -554,8 +593,9 @@ package body System.Value_R is then After_Point := True; Index := Index + 1; - Value := 0; - Scale := 0; + N := 1; + Value := (others => 0); + Scale := (others => 0); Extra := 0; else @@ -571,8 +611,8 @@ package body System.Value_R is then Base_Char := Str (Index); - if Value in 2 .. 16 then - Base := Unsigned (Value); + if N = 1 and then Value (1) in 2 .. 16 then + Base := Unsigned (Value (1)); else Base_Violation := True; Base := 16; @@ -586,7 +626,7 @@ package body System.Value_R is then After_Point := True; Index := Index + 1; - Value := 0; + Value := (others => 0); end if; end if; @@ -598,8 +638,8 @@ package body System.Value_R is end if; Scan_Integral_Digits - (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), - Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL); + (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale, + N, Char_As_Digit (Extra), Base_Violation); end if; -- Do we have a dot? @@ -625,8 +665,8 @@ package body System.Value_R is pragma Assert (Index <= Max); Scan_Decimal_Digits - (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), - Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL); + (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale, + N, Char_As_Digit (Extra), Base_Violation); end if; -- If an explicit base was specified ensure that the delimiter is found @@ -649,9 +689,15 @@ package body System.Value_R is -- Handle very large exponents like Scan_Exponent if Expon < Integer'First / 10 or else Expon > Integer'Last / 10 then - Scale := Expon; + Scale (1) := Expon; + for J in 2 .. Data_Index'Last loop + Value (J) := 0; + end loop; + else - Scale := Scale + Expon; + for J in Data_Index'Range loop + Scale (J) := Scale (J) + Expon; + end loop; end if; -- Here is where we check for a bad based number @@ -661,7 +707,6 @@ package body System.Value_R is else return Value; end if; - end Scan_Raw_Real; -------------------- @@ -671,10 +716,13 @@ package body System.Value_R is function Value_Raw_Real (Str : String; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns + Minus : out Boolean) return Value_Array is + P : aliased Integer; + V : Value_Array; + begin -- We have to special case Str'Last = Positive'Last because the normal -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We @@ -686,20 +734,15 @@ package body System.Value_R is begin return Value_Raw_Real (NT (Str), Base, Scale, Extra, Minus); end; + end if; - -- Normal case where Str'Last < Positive'Last + -- Normal case - else - declare - V : Uns; - P : aliased Integer := Str'First; - begin - V := Scan_Raw_Real - (Str, P'Access, Str'Last, Base, Scale, Extra, Minus); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; + P := Str'First; + V := Scan_Raw_Real (Str, P'Access, Str'Last, Base, Scale, Extra, Minus); + Scan_Trailing_Blanks (Str, P); + + return V; end Value_Raw_Real; end System.Value_R; diff --git a/gcc/ada/libgnat/s-valuer.ads b/gcc/ada/libgnat/s-valuer.ads index 3279090..d9d168e 100644 --- a/gcc/ada/libgnat/s-valuer.ads +++ b/gcc/ada/libgnat/s-valuer.ads @@ -37,22 +37,37 @@ with System.Unsigned_Types; use System.Unsigned_Types; generic type Uns is mod <>; + -- Modular type used for the value + + Parts : Positive; + -- Number of Uns parts in the value Precision_Limit : Uns; + -- Precision limit for each part of the value Round : Boolean; + -- If Parts = 1, True if the extra digit must be rounded package System.Value_R is pragma Preelaborate; + subtype Data_Index is Positive range 1 .. Parts; + -- The type indexing the value + + type Scale_Array is array (Data_Index) of Integer; + -- The scale for each part of the value + + type Value_Array is array (Data_Index) of Uns; + -- The value split into parts + function Scan_Raw_Real (Str : String; Ptr : not null access Integer; Max : Integer; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns; + Minus : out Boolean) return Value_Array; -- This function scans the string starting at Str (Ptr.all) for a valid -- real literal according to the syntax described in (RM 3.5(43)). The -- substring scanned extends no further than Str (Max). There are three @@ -64,9 +79,13 @@ package System.Value_R is -- parameters are set; if Val is the result of the call, then the real -- represented by the literal is equal to -- - -- (Val * Base + Extra) * (Base ** (Scale - 1)) + -- (Val (1) * Base + Extra) * (Base ** (Scale (1) - 1)) + -- + -- when Parts = 1 and + -- + -- Sum [Val (N) * (Base ** Scale (N)), N in 1 .. Parts] -- - -- with the negative sign if Minus is true. + -- when Parts > 1, with the negative sign if Minus is true. -- -- If no valid real is found, then Ptr.all points either to an initial -- non-blank character, or to Max + 1 if the field is all spaces and the @@ -91,9 +110,9 @@ package System.Value_R is function Value_Raw_Real (Str : String; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns; + Minus : out Boolean) return Value_Array; -- Used in computing X'Value (Str) where X is a real type. Str is the -- string argument of the attribute. Constraint_Error is raised if the -- string is malformed. diff --git a/gcc/ada/libgnat/s-valueu.adb b/gcc/ada/libgnat/s-valueu.adb index f5a6881..8f19086 100644 --- a/gcc/ada/libgnat/s-valueu.adb +++ b/gcc/ada/libgnat/s-valueu.adb @@ -41,9 +41,12 @@ package body System.Value_U is Assert_And_Cut => Ignore, Subprogram_Variant => Ignore); + use type Spec.Uns_Option; + use type Spec.Split_Value_Ghost; + -- Local lemmas - procedure Lemma_Digit_Is_Before_Last + procedure Lemma_Digit_Not_Last (Str : String; P : Integer; From : Integer; @@ -54,257 +57,47 @@ package body System.Value_U is and then To in From .. Str'Last and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' and then P in From .. To - and then Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F', - Post => P /= Last_Hexa_Ghost (Str (From .. To)) + 1; - -- If the character at position P is a digit, P cannot be the position of - -- of the first non-digit in Str. + and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1 + and then Spec.Is_Based_Format_Ghost (Str (From .. To)), + Post => + (if Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' + then P <= Spec.Last_Hexa_Ghost (Str (From .. To))); - procedure Lemma_End_Of_Scan + procedure Lemma_Underscore_Not_Last (Str : String; + P : Integer; From : Integer; - To : Integer; - Base : Uns; - Acc : Uns) - with Ghost, - Pre => Str'Last /= Positive'Last and then From > To, - Post => Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = - (False, Acc); - -- Unfold the definition of Scan_Based_Number_Ghost on an empty string - - procedure Lemma_Scan_Digit - (Str : String; - P : Integer; - Lst : Integer; - Digit : Uns; - Base : Uns; - Old_Acc : Uns; - Acc : Uns; - Scan_Val : Uns_Option; - Old_Overflow : Boolean; - Overflow : Boolean) - with Ghost, - Pre => Str'Last /= Positive'Last - and then Lst in Str'Range - and then P in Str'First .. Lst - and then Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then Digit = Hexa_To_Unsigned_Ghost (Str (P)) - and then Only_Hexa_Ghost (Str, P, Lst) - and then Base in 2 .. 16 - and then (if Digit < Base and then Old_Acc <= Uns'Last / Base - then Acc = Base * Old_Acc + Digit) - and then (if Digit >= Base - or else Old_Acc > Uns'Last / Base - or else (Old_Acc > (Uns'Last - Base + 1) / Base - and then Acc < Uns'Last / Base) - then Overflow - else Overflow = Old_Overflow) - and then - (if not Old_Overflow then - Scan_Val = Scan_Based_Number_Ghost - (Str, P, Lst, Base, Old_Acc)), - Post => - (if not Overflow then - Scan_Val = Scan_Based_Number_Ghost - (Str, P + 1, Lst, Base, Acc)) - and then - (if Overflow then Old_Overflow or else Scan_Val.Overflow); - -- Unfold the definition of Scan_Based_Number_Ghost when the string starts - -- with a digit. - - procedure Lemma_Scan_Underscore - (Str : String; - P : Integer; - From : Integer; - To : Integer; - Lst : Integer; - Base : Uns; - Acc : Uns; - Scan_Val : Uns_Option; - Overflow : Boolean; - Ext : Boolean) + To : Integer) with Ghost, Pre => Str'Last /= Positive'Last and then From in Str'Range and then To in From .. Str'Last - and then Lst <= To - and then P in From .. Lst + 1 - and then P <= To - and then - (if Ext then - Is_Based_Format_Ghost (Str (From .. To)) - and then Lst = Last_Hexa_Ghost (Str (From .. To)) - else Is_Natural_Format_Ghost (Str (From .. To)) - and then Lst = Last_Number_Ghost (Str (From .. To))) + and then Str (From) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' + and then P in From .. To and then Str (P) = '_' - and then - (if not Overflow then - Scan_Val = Scan_Based_Number_Ghost (Str, P, Lst, Base, Acc)), - Post => P + 1 <= Lst - and then - (if Ext then Str (P + 1) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - else Str (P + 1) in '0' .. '9') - and then - (if not Overflow then - Scan_Val = Scan_Based_Number_Ghost (Str, P + 1, Lst, Base, Acc)); - -- Unfold the definition of Scan_Based_Number_Ghost when the string starts - -- with an underscore. + and then P <= Spec.Last_Hexa_Ghost (Str (From .. To)) + 1 + and then Spec.Is_Based_Format_Ghost (Str (From .. To)), + Post => P + 1 <= Spec.Last_Hexa_Ghost (Str (From .. To)) + and then Str (P + 1) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; ----------------------------- -- Local lemma null bodies -- ----------------------------- - procedure Lemma_Digit_Is_Before_Last + procedure Lemma_Digit_Not_Last (Str : String; P : Integer; From : Integer; To : Integer) is null; - procedure Lemma_End_Of_Scan - (Str : String; - From : Integer; - To : Integer; - Base : Uns; - Acc : Uns) - is null; - - procedure Lemma_Scan_Underscore - (Str : String; - P : Integer; - From : Integer; - To : Integer; - Lst : Integer; - Base : Uns; - Acc : Uns; - Scan_Val : Uns_Option; - Overflow : Boolean; - Ext : Boolean) + procedure Lemma_Underscore_Not_Last + (Str : String; + P : Integer; + From : Integer; + To : Integer) is null; - --------------------- - -- Last_Hexa_Ghost -- - --------------------- - - function Last_Hexa_Ghost (Str : String) return Positive is - begin - for J in Str'Range loop - if Str (J) not in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' then - return J - 1; - end if; - - pragma Loop_Invariant - (for all K in Str'First .. J => - Str (K) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_'); - end loop; - - return Str'Last; - end Last_Hexa_Ghost; - - ---------------------- - -- Lemma_Scan_Digit -- - ---------------------- - - procedure Lemma_Scan_Digit - (Str : String; - P : Integer; - Lst : Integer; - Digit : Uns; - Base : Uns; - Old_Acc : Uns; - Acc : Uns; - Scan_Val : Uns_Option; - Old_Overflow : Boolean; - Overflow : Boolean) - is - pragma Unreferenced (Str, P, Lst, Scan_Val, Overflow, Old_Overflow); - begin - if Digit >= Base then - null; - - elsif Old_Acc <= (Uns'Last - Base + 1) / Base then - pragma Assert (not Scan_Overflows_Ghost (Digit, Base, Old_Acc)); - - elsif Old_Acc > Uns'Last / Base then - null; - - else - pragma Assert - ((Acc < Uns'Last / Base) = - Scan_Overflows_Ghost (Digit, Base, Old_Acc)); - 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 -- ----------------------- @@ -341,8 +134,8 @@ package body System.Value_U is Last_Num_Init : constant Integer := Last_Number_Ghost (Str (Ptr.all .. Max)) with Ghost; - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, Ptr.all, Last_Num_Init) + Init_Val : constant Spec.Uns_Option := + Spec.Scan_Based_Number_Ghost (Str, Ptr.all, Last_Num_Init) with Ghost; Starts_As_Based : constant Boolean := Last_Num_Init < Max - 1 @@ -352,7 +145,7 @@ package body System.Value_U is with Ghost; Last_Num_Based : constant Integer := (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Max)) + then Spec.Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Max)) else Last_Num_Init) with Ghost; Is_Based : constant Boolean := @@ -360,9 +153,9 @@ package body System.Value_U is and then Last_Num_Based < Max and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1) with Ghost; - Based_Val : constant Uns_Option := + Based_Val : constant Spec.Uns_Option := (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost + then Spec.Scan_Based_Number_Ghost (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) else Init_Val) with Ghost; @@ -379,6 +172,7 @@ package body System.Value_U is end if; P := Ptr.all; + Spec.Lemma_Scan_Based_Number_Ghost_Step (Str, P, Last_Num_Init); Uval := Character'Pos (Str (P)) - Character'Pos ('0'); P := P + 1; @@ -392,9 +186,6 @@ package body System.Value_U is Umax10 : constant Uns := Uns'Last / 10; -- Numbers bigger than Umax10 overflow if multiplied by 10 - Old_Uval : Uns with Ghost; - Old_Overflow : Boolean with Ghost; - begin -- Loop through decimal digits loop @@ -403,7 +194,7 @@ package body System.Value_U is (if Overflow then Init_Val.Overflow); pragma Loop_Invariant (if not Overflow - then Init_Val = Scan_Based_Number_Ghost + then Init_Val = Spec.Scan_Based_Number_Ghost (Str, P, Last_Num_Init, Acc => Uval)); exit when P > Max; @@ -414,9 +205,8 @@ package body System.Value_U is if Digit > 9 then if Str (P) = '_' then - Lemma_Scan_Underscore - (Str, P, Ptr_Old, Max, Last_Num_Init, 10, Uval, - Init_Val, Overflow, False); + Spec.Lemma_Scan_Based_Number_Ghost_Underscore + (Str, P, Last_Num_Init, Acc => Uval); Scan_Underscore (Str, P, Ptr, Max, False); else exit; @@ -425,11 +215,19 @@ package body System.Value_U is -- Accumulate result, checking for overflow else - Old_Uval := Uval; - Old_Overflow := Overflow; + Spec.Lemma_Scan_Based_Number_Ghost_Step + (Str, P, Last_Num_Init, Acc => Uval); + Spec.Lemma_Scan_Based_Number_Ghost_Overflow + (Str, P, Last_Num_Init, Acc => Uval); if Uval <= Umax then + pragma Assert + (Spec.Hexa_To_Unsigned_Ghost (Str (P)) = Digit); Uval := 10 * Uval + Digit; + pragma Assert + (if not Overflow + then Init_Val = Spec.Scan_Based_Number_Ghost + (Str, P + 1, Last_Num_Init, Acc => Uval)); elsif Uval > Umax10 then Overflow := True; @@ -440,17 +238,17 @@ package body System.Value_U is if Uval < Umax10 then Overflow := True; end if; + pragma Assert + (if not Overflow + then Init_Val = Spec.Scan_Based_Number_Ghost + (Str, P + 1, Last_Num_Init, Acc => Uval)); end if; - Lemma_Scan_Digit - (Str, P, Last_Num_Init, Digit, 10, Old_Uval, Uval, Init_Val, - Old_Overflow, Overflow); - P := P + 1; end if; end loop; - pragma Assert (P = Last_Num_Init + 1); - pragma Assert (Init_Val.Overflow = Overflow); + Spec.Lemma_Scan_Based_Number_Ghost_Base + (Str, P, Last_Num_Init, Acc => Uval); end; pragma Assert_And_Cut @@ -488,18 +286,14 @@ package body System.Value_U is UmaxB : constant Uns := Uns'Last / Base; -- Numbers bigger than UmaxB overflow if multiplied by base - Old_Uval : Uns with Ghost; - Old_Overflow : Boolean with Ghost; - begin pragma Assert (if Str (P) in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' - then Is_Based_Format_Ghost (Str (P .. Max))); + then Spec.Is_Based_Format_Ghost (Str (P .. Max))); -- Loop to scan out based integer value loop - -- We require a digit at this stage if Str (P) in '0' .. '9' then @@ -519,6 +313,8 @@ package body System.Value_U is -- already stored in Ptr.all. else + Spec.Lemma_Scan_Based_Number_Ghost_Base + (Str, P, Last_Num_Based, Base, Uval); Uval := Base; Base := 10; pragma Assert (Ptr.all = Last_Num_Init + 1); @@ -529,25 +325,25 @@ package body System.Value_U is exit; end if; - Lemma_Digit_Is_Before_Last (Str, P, Last_Num_Init + 2, Max); - pragma Loop_Invariant (P in P'Loop_Entry .. Last_Num_Based); pragma Loop_Invariant (Str (P) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then Digit = Hexa_To_Unsigned_Ghost (Str (P))); + and then Digit = Spec.Hexa_To_Unsigned_Ghost (Str (P))); pragma Loop_Invariant (if Overflow'Loop_Entry then Overflow); pragma Loop_Invariant (if Overflow then - Overflow'Loop_Entry or else Based_Val.Overflow); + (Overflow'Loop_Entry or else Based_Val.Overflow)); pragma Loop_Invariant (if not Overflow - then Based_Val = Scan_Based_Number_Ghost + then Based_Val = Spec.Scan_Based_Number_Ghost (Str, P, Last_Num_Based, Base, Uval)); pragma Loop_Invariant (Ptr.all = Last_Num_Init + 1); - Old_Uval := Uval; - Old_Overflow := Overflow; + Spec.Lemma_Scan_Based_Number_Ghost_Step + (Str, P, Last_Num_Based, Base, Uval); + Spec.Lemma_Scan_Based_Number_Ghost_Overflow + (Str, P, Last_Num_Based, Base, Uval); -- If digit is too large, just signal overflow and continue. -- The idea here is to keep scanning as long as the input is @@ -560,6 +356,10 @@ package body System.Value_U is elsif Uval <= Umax then Uval := Base * Uval + Digit; + pragma Assert + (if not Overflow + then Based_Val = Spec.Scan_Based_Number_Ghost + (Str, P + 1, Last_Num_Based, Base, Uval)); elsif Uval > UmaxB then Overflow := True; @@ -570,6 +370,10 @@ package body System.Value_U is if Uval < UmaxB then Overflow := True; end if; + pragma Assert + (if not Overflow + then Based_Val = Spec.Scan_Based_Number_Ghost + (Str, P + 1, Last_Num_Based, Base, Uval)); end if; -- If at end of string with no base char, not a based number @@ -579,10 +383,6 @@ 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); @@ -592,48 +392,54 @@ package body System.Value_U is if Str (P) = Base_Char then Ptr.all := P + 1; + pragma Assert (P = Last_Num_Based + 1); pragma Assert (Ptr.all = Last_Num_Based + 2); + pragma Assert (Starts_As_Based); + pragma Assert (Last_Num_Based < Max); + pragma Assert (Str (Last_Num_Based + 1) = Base_Char); + pragma Assert (Base_Char = Str (Last_Num_Init + 1)); 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); + Spec.Lemma_Scan_Based_Number_Ghost_Base + (Str, P, Last_Num_Based, Base, Uval); exit; -- Deal with underscore elsif Str (P) = '_' then - Lemma_Scan_Underscore - (Str, P, Last_Num_Init + 2, Max, Last_Num_Based, Base, - Uval, Based_Val, Overflow, True); + Lemma_Underscore_Not_Last (Str, P, Last_Num_Init + 2, Max); + Spec.Lemma_Scan_Based_Number_Ghost_Underscore + (Str, P, Last_Num_Based, Base, Uval); Scan_Underscore (Str, P, Ptr, Max, True); pragma Assert (if not Overflow - then Based_Val = Scan_Based_Number_Ghost + then Based_Val = Spec.Scan_Based_Number_Ghost (Str, P, Last_Num_Based, Base, Uval)); + pragma Assert (Str (P) /= '_'); + pragma Assert (Str (P) /= Base_Char); end if; + + Lemma_Digit_Not_Last (Str, P, Last_Num_Init + 2, Max); + pragma Assert (Str (P) /= '_'); + pragma Assert (Str (P) /= Base_Char); end loop; end; pragma Assert (if Starts_As_Based then P = Last_Num_Based + 1 else P = Last_Num_Init + 2); pragma Assert + (Last_Num_Init < Max - 1 + and then Str (Last_Num_Init + 1) in '#' | ':'); + pragma Assert (Overflow = (Init_Val.Overflow or else Init_Val.Value not in 2 .. 16 or else (Starts_As_Based and then Based_Val.Overflow))); + pragma Assert + (Overflow /= Spec.Scan_Split_No_Overflow_Ghost (Str, Ptr_Old, Max)); end if; pragma Assert_And_Cut - (Overflow = - (Init_Val.Overflow - or else - (Last_Num_Init < Max - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Init_Val.Value not in 2 .. 16) - or else (Starts_As_Based and then Based_Val.Overflow)) + (Overflow /= Spec.Scan_Split_No_Overflow_Ghost (Str, Ptr_Old, Max) and then (if not Overflow then (if Is_Based then Uval = Based_Val.Value @@ -649,10 +455,12 @@ 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))); + (Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr_Old, Max)); + pragma Assert + (if not Overflow + then Spec.Scan_Split_Value_Ghost (Str, Ptr_Old, Max) = + (Uval, Base, Expon)); if Expon /= 0 and then Uval /= 0 then @@ -664,8 +472,8 @@ package body System.Value_U is UmaxB : constant Uns := Uns'Last / Base; -- Numbers bigger than UmaxB overflow if multiplied by base - Res_Val : constant Uns_Option := - Exponent_Unsigned_Ghost (Uval, Expon, Base) + Res_Val : constant Spec.Uns_Option := + Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base) with Ghost; begin for J in 1 .. Expon loop @@ -674,48 +482,45 @@ package body System.Value_U is pragma Loop_Invariant (if Overflow then Overflow'Loop_Entry or else Res_Val.Overflow); + pragma Loop_Invariant (Uval /= 0); pragma Loop_Invariant (if not Overflow - then Res_Val = Exponent_Unsigned_Ghost + then Res_Val = Spec.Exponent_Unsigned_Ghost (Uval, Expon - J + 1, Base)); pragma Assert - ((Uval > UmaxB) = Scan_Overflows_Ghost (0, Base, Uval)); + ((Uval > UmaxB) = Spec.Scan_Overflows_Ghost (0, Base, Uval)); if Uval > UmaxB then + Spec.Lemma_Exponent_Unsigned_Ghost_Overflow + (Uval, Expon - J + 1, Base); Overflow := True; exit; end if; + Spec.Lemma_Exponent_Unsigned_Ghost_Step + (Uval, Expon - J + 1, Base); + Uval := Uval * Base; end loop; + Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, 0, Base); + pragma Assert - (Overflow = (Init_Val.Overflow - or else - (Last_Num_Init < Max - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Init_Val.Value not in 2 .. 16) - or else (Starts_As_Based and then Based_Val.Overflow) - or else Res_Val.Overflow)); - pragma Assert - (Overflow = Raw_Unsigned_Overflows_Ghost (Str, Ptr_Old, Max)); - pragma Assert - (Exponent_Unsigned_Ghost (Uval, 0, Base) = (False, Uval)); - pragma Assert - (if not Overflow then Uval = Res_Val.Value); - pragma Assert - (if not Overflow then - Uval = Scan_Raw_Unsigned_Ghost (Str, Ptr_Old, Max)); + (Overflow /= + Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max)); + pragma Assert (if not Overflow then Res_Val = (False, Uval)); end; end if; + Spec.Lemma_Exponent_Unsigned_Ghost_Base (Uval, Expon, Base); pragma Assert (if Expon = 0 or else Uval = 0 then - Exponent_Unsigned_Ghost (Uval, Expon, Base) = (False, Uval)); + Spec.Exponent_Unsigned_Ghost (Uval, Expon, Base) = (False, Uval)); pragma Assert - (Overflow = Raw_Unsigned_Overflows_Ghost (Str, Ptr_Old, Max)); + (Overflow /= + Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr_Old, Max)); pragma Assert (if not Overflow then - Uval = Scan_Raw_Unsigned_Ghost (Str, Ptr_Old, Max)); + Uval = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr_Old, Max)); -- Return result, dealing with overflow @@ -774,7 +579,15 @@ package body System.Value_U is if Str'Last = Positive'Last then declare subtype NT is String (1 .. Str'Length); + procedure Prove_Is_Unsigned_Ghost with + Ghost, + Pre => Str'Length < Natural'Last + and then not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Spec.Is_Unsigned_Ghost (Spec.Slide_To_1 (Str)), + Post => Spec.Is_Unsigned_Ghost (NT (Str)); + procedure Prove_Is_Unsigned_Ghost is null; begin + Prove_Is_Unsigned_Ghost; return Value_Unsigned (NT (Str)); end; @@ -784,7 +597,6 @@ package body System.Value_U is declare V : Uns; P : aliased Integer := Str'First; - Non_Blank : constant Positive := First_Non_Space_Ghost (Str, Str'First, Str'Last) with Ghost; @@ -792,9 +604,6 @@ package body System.Value_U is (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank) with Ghost; begin - pragma Assert - (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); - declare P_Acc : constant not null access Integer := P'Access; begin @@ -802,14 +611,15 @@ package body System.Value_U is end; pragma Assert - (P = Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last)); + (P = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last)); pragma Assert - (V = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)); + (V = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)); Scan_Trailing_Blanks (Str, P); pragma Assert - (Is_Value_Unsigned_Ghost (Slide_If_Necessary (Str), V)); + (Spec.Is_Value_Unsigned_Ghost + (Spec.Slide_If_Necessary (Str), V)); return V; end; end if; diff --git a/gcc/ada/libgnat/s-valueu.ads b/gcc/ada/libgnat/s-valueu.ads index 1508b6e..466b96a 100644 --- a/gcc/ada/libgnat/s-valueu.ads +++ b/gcc/ada/libgnat/s-valueu.ads @@ -44,6 +44,7 @@ pragma Assertion_Policy (Pre => Ignore, Ghost => Ignore, Subprogram_Variant => Ignore); +with System.Value_U_Spec; with System.Val_Util; use System.Val_Util; generic @@ -53,317 +54,7 @@ generic package System.Value_U is pragma Preelaborate; - type Uns_Option (Overflow : Boolean := False) is record - case Overflow is - when True => - null; - when False => - Value : Uns := 0; - end case; - 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 - (for all J in From .. To => - Str (J) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') - with - Ghost, - Pre => From > To or else (From >= Str'First and then To <= Str'Last); - -- Ghost function that returns True if S has only hexadecimal characters - -- from index From to index To. - - function Last_Hexa_Ghost (Str : String) return Positive - with - Ghost, - Pre => Str /= "" - and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F', - Post => Last_Hexa_Ghost'Result in Str'Range - and then (if Last_Hexa_Ghost'Result < Str'Last then - Str (Last_Hexa_Ghost'Result + 1) not in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') - and then Only_Hexa_Ghost (Str, Str'First, Last_Hexa_Ghost'Result); - -- Ghost function that returns the index of the last character in S that - -- is either an hexadecimal digit or an underscore, which necessarily - -- exists given the precondition on Str. - - function Is_Based_Format_Ghost (Str : String) return Boolean - is - (Str /= "" - and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' - and then - (declare - L : constant Positive := Last_Hexa_Ghost (Str); - begin - Str (L) /= '_' - and then (for all J in Str'First .. L => - (if Str (J) = '_' then Str (J + 1) /= '_')))) - with - Ghost; - -- Ghost function that determines if Str has the correct format for a - -- based number, consisting in a sequence of hexadecimal digits possibly - -- separated by single underscores. It may be followed by other characters. - - function Hexa_To_Unsigned_Ghost (X : Character) return Uns is - (case X is - when '0' .. '9' => Character'Pos (X) - Character'Pos ('0'), - when 'a' .. 'f' => Character'Pos (X) - Character'Pos ('a') + 10, - when 'A' .. 'F' => Character'Pos (X) - Character'Pos ('A') + 10, - when others => raise Program_Error) - with - Ghost, - Pre => X in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - -- Ghost function that computes the value corresponding to an hexadecimal - -- digit. - - function Scan_Overflows_Ghost - (Digit : Uns; - Base : Uns; - Acc : Uns) return Boolean - is - (Digit >= Base - or else Acc > Uns'Last / Base - or else Uns'Last - Digit < Base * Acc) - with Ghost; - -- Ghost function which returns True if Digit + Base * Acc overflows or - -- Digit is greater than Base, as this is used by the algorithm for the - -- test of overflow. - - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) return Uns_Option - with - Ghost, - Subprogram_Variant => (Increases => From), - Pre => Str'Last /= Positive'Last - and then - (From > To or else (From >= Str'First and then To <= Str'Last)) - and then Only_Hexa_Ghost (Str, From, To); - -- Ghost function that recursively computes the based number in Str, - -- assuming Acc has been scanned already and scanning continues at index - -- From. - - function Exponent_Unsigned_Ghost - (Value : Uns; - Exp : Natural; - Base : Uns := 10) return Uns_Option - with - Ghost, - Subprogram_Variant => (Decreases => Exp); - -- Ghost function that recursively computes Value * Base ** Exp - - function Is_Raw_Unsigned_Format_Ghost (Str : String) return Boolean is - (Is_Natural_Format_Ghost (Str) - and then - (declare - Last_Num_Init : constant Integer := Last_Number_Ghost (Str); - Starts_As_Based : constant Boolean := - 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'; - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) - else Last_Num_Init); - Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < Str'Last - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - begin - (if Starts_As_Based then - Is_Based_Format_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) - and then Last_Num_Based < Str'Last) - and then Is_Opt_Exponent_Format_Ghost - (Str (First_Exp .. Str'Last)))) - with - Ghost, - Pre => Str'Last /= Positive'Last, - Post => True; - -- Ghost function that determines if Str has the correct format for an - -- unsigned number without a sign character. - -- It is a natural number in base 10, optionally followed by a based - -- number surrounded by delimiters # or :, optionally followed by an - -- exponent part. - - function Raw_Unsigned_Overflows_Ghost - (Str : String; - From, To : Integer) - return Boolean - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, From, Last_Num_Init); - Starts_As_Based : constant Boolean := - Last_Num_Init < To - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < To - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); - Based_Val : constant Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - Expon : constant Natural := - (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then Scan_Exponent_Ghost (Str (First_Exp .. To)) - else 0); - begin - Init_Val.Overflow - or else - (Last_Num_Init < To - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Init_Val.Value not in 2 .. 16) - or else - (Starts_As_Based - and then Based_Val.Overflow) - or else - (Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - and then - (declare - Base : constant Uns := - (if Is_Based then Init_Val.Value else 10); - Value : constant Uns := - (if Is_Based then Based_Val.Value else Init_Val.Value); - begin - Exponent_Unsigned_Ghost - (Value, Expon, Base).Overflow))) - with - Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9', - Post => True; - -- Ghost function that determines if the computation of the unsigned number - -- represented by Str will overflow. The computation overflows if either: - -- * The computation of the decimal part overflows, - -- * The decimal part is followed by a valid delimiter for a based - -- part, and the number corresponding to the base is not a valid base, - -- * The computation of the based part overflows, or - -- * There is an exponent and the computation of the exponentiation - -- overflows. - - function Scan_Raw_Unsigned_Ghost - (Str : String; - From, To : Integer) - return Uns - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Init_Val : constant Uns_Option := - Scan_Based_Number_Ghost (Str, From, Last_Num_Init); - Starts_As_Based : constant Boolean := - Last_Num_Init < To - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < To - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); - Based_Val : constant Uns_Option := - (if Starts_As_Based and then not Init_Val.Overflow - then Scan_Based_Number_Ghost - (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) - else Init_Val); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - Expon : constant Natural := - (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then Scan_Exponent_Ghost (Str (First_Exp .. To)) - else 0); - Base : constant Uns := - (if Is_Based then Init_Val.Value else 10); - Value : constant Uns := - (if Is_Based then Based_Val.Value else Init_Val.Value); - begin - Exponent_Unsigned_Ghost (Value, Expon, Base).Value) - with - Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9' - and then not Raw_Unsigned_Overflows_Ghost (Str, From, To), - Post => True; - -- Ghost function that scans an unsigned number without a sign character - - function Raw_Unsigned_Last_Ghost - (Str : String; - From, To : Integer) - return Positive - is - (declare - Last_Num_Init : constant Integer := - Last_Number_Ghost (Str (From .. To)); - Starts_As_Based : constant Boolean := - Last_Num_Init < To - 1 - and then Str (Last_Num_Init + 1) in '#' | ':' - and then Str (Last_Num_Init + 2) in - '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; - Last_Num_Based : constant Integer := - (if Starts_As_Based - then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) - else Last_Num_Init); - Is_Based : constant Boolean := - Starts_As_Based - and then Last_Num_Based < To - and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); - First_Exp : constant Integer := - (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); - begin - (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) - then First_Exp - elsif Str (First_Exp + 1) in '-' | '+' then - Last_Number_Ghost (Str (First_Exp + 2 .. To)) + 1 - else Last_Number_Ghost (Str (First_Exp + 1 .. To)) + 1)) - with - Ghost, - Pre => Str'Last /= Positive'Last - and then From in Str'Range - and then To in From .. Str'Last - and then Str (From) in '0' .. '9', - Post => Raw_Unsigned_Last_Ghost'Result in From .. To + 1; - -- Ghost function that returns the position of the cursor once an unsigned - -- number has been seen. + package Spec is new System.Value_U_Spec (Uns); procedure Scan_Raw_Unsigned (Str : String; @@ -373,10 +64,10 @@ package System.Value_U is with Pre => Str'Last /= Positive'Last and then Ptr.all in Str'Range and then Max in Ptr.all .. Str'Last - and then Is_Raw_Unsigned_Format_Ghost (Str (Ptr.all .. Max)), - Post => not Raw_Unsigned_Overflows_Ghost (Str, Ptr.all'Old, Max) - and Res = Scan_Raw_Unsigned_Ghost (Str, Ptr.all'Old, Max) - and Ptr.all = Raw_Unsigned_Last_Ghost (Str, Ptr.all'Old, Max); + and then Spec.Is_Raw_Unsigned_Format_Ghost (Str (Ptr.all .. Max)), + Post => Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Ptr.all'Old, Max) + and Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Ptr.all'Old, Max) + and Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Ptr.all'Old, Max); -- This function scans the string starting at Str (Ptr.all) for a valid -- integer according to the syntax described in (RM 3.5(43)). The substring @@ -464,7 +155,7 @@ package System.Value_U is Fst_Num : constant Positive := (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); begin - Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max))), + Spec.Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Max))), Post => (declare Non_Blank : constant Positive := @@ -472,9 +163,9 @@ package System.Value_U is Fst_Num : constant Positive := (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); begin - not Raw_Unsigned_Overflows_Ghost (Str, Fst_Num, Max) - and then Res = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max) - and then Ptr.all = Raw_Unsigned_Last_Ghost (Str, Fst_Num, Max)); + Spec.Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Max) + and then Res = Spec.Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Max) + and then Ptr.all = Spec.Raw_Unsigned_Last_Ghost (Str, Fst_Num, Max)); -- Same as Scan_Raw_Unsigned, except scans optional leading -- blanks, and an optional leading plus sign. @@ -482,157 +173,18 @@ package System.Value_U is -- Note: if a minus sign is present, Constraint_Error will be raised. -- Note: trailing blanks are not scanned. - 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_Unsigned_Ghost (Str : String) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) - and then not Raw_Unsigned_Overflows_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 an - -- unsigned number, consisting in some blank characters, an optional - -- + sign, a raw unsigned number which does not overflow and then some - -- more blank characters. - - function Is_Value_Unsigned_Ghost (Str : String; Val : Uns) return Boolean is - (declare - Non_Blank : constant Positive := First_Non_Space_Ghost - (Str, Str'First, Str'Last); - Fst_Num : constant Positive := - (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); - begin - Val = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)) - with Ghost, - Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Last /= Positive'Last - and then Is_Unsigned_Ghost (Str), - Post => True; - -- Ghost function that returns True if Val is the value corresponding to - -- the unsigned number represented by Str. - function Value_Unsigned (Str : String) return Uns - with Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) - and then Str'Length /= Positive'Last - and then Is_Unsigned_Ghost (Slide_If_Necessary (Str)), + with Pre => Str'Length /= Positive'Last + and then not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Spec.Is_Unsigned_Ghost (Spec.Slide_If_Necessary (Str)), Post => - Is_Value_Unsigned_Ghost - (Slide_If_Necessary (Str), Value_Unsigned'Result), + Spec.Is_Value_Unsigned_Ghost + (Spec.Slide_If_Necessary (Str), Value_Unsigned'Result), Subprogram_Variant => (Decreases => Str'First); -- Used in computing X'Value (Str) where X is a modular integer type whose -- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str -- is the string argument of the attribute. Constraint_Error is raised if -- 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 - - ----------------------------- - -- Exponent_Unsigned_Ghost -- - ----------------------------- - - function Exponent_Unsigned_Ghost - (Value : Uns; - Exp : Natural; - Base : Uns := 10) return Uns_Option - is - (if Exp = 0 or Value = 0 then (Overflow => False, Value => Value) - elsif Scan_Overflows_Ghost (0, Base, Value) then (Overflow => True) - else Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); - - ----------------------------- - -- Scan_Based_Number_Ghost -- - ----------------------------- - - function Scan_Based_Number_Ghost - (Str : String; - From, To : Integer; - Base : Uns := 10; - Acc : Uns := 0) return Uns_Option - is - (if From > To then (Overflow => False, Value => Acc) - elsif Str (From) = '_' - then Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc) - elsif Scan_Overflows_Ghost - (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) - then (Overflow => True) - else Scan_Based_Number_Ghost - (Str, From + 1, To, Base, - Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); - - ---------------- - -- Slide_To_1 -- - ---------------- - - function Slide_To_1 (Str : String) return String is - (declare - Res : constant String (1 .. Str'Length) := Str; - begin - Res); - end System.Value_U; diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads index 2b89b12..7c2da17 100644 --- a/gcc/ada/libgnat/s-valuti.ads +++ b/gcc/ada/libgnat/s-valuti.ads @@ -374,48 +374,274 @@ 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 + -- Bundle Uns type with other types, constants and subprograms used in -- ghost code, so that this package can be instantiated once and used - -- multiple times as generic formal for a given Int type. + -- multiple times as generic formal for a given Uns type. generic - type Int is range <>; type Uns is mod <>; - type Uns_Option is private; + type P_Uns_Option is private with Ghost; + with function P_Wrap_Option (Value : Uns) return P_Uns_Option + with Ghost; + with function P_Hexa_To_Unsigned_Ghost (X : Character) return Uns + with Ghost; + with function P_Scan_Overflows_Ghost + (Digit : Uns; + Base : Uns; + Acc : Uns) return Boolean + with Ghost; + with function P_Is_Raw_Unsigned_Format_Ghost + (Str : String) return Boolean + with Ghost; + with function P_Scan_Split_No_Overflow_Ghost + (Str : String; + From, To : Integer) + return Boolean + with Ghost; + with function P_Raw_Unsigned_No_Overflow_Ghost + (Str : String; + From, To : Integer) + return Boolean + with Ghost; - Unsigned_Width_Ghost : Natural; + with function P_Exponent_Unsigned_Ghost + (Value : Uns; + Exp : Natural; + Base : Uns := 10) return P_Uns_Option + with Ghost; + with procedure P_Lemma_Exponent_Unsigned_Ghost_Base + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with Ghost; + with procedure P_Lemma_Exponent_Unsigned_Ghost_Overflow + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with Ghost; + with procedure P_Lemma_Exponent_Unsigned_Ghost_Step + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with Ghost; - with function Wrap_Option (Value : Uns) return Uns_Option - with Ghost; - with function Only_Decimal_Ghost + with function P_Scan_Raw_Unsigned_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 + return Uns + with Ghost; + with procedure P_Lemma_Scan_Based_Number_Ghost_Base (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 + with Ghost; + with procedure P_Lemma_Scan_Based_Number_Ghost_Underscore + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with Ghost; + with procedure P_Lemma_Scan_Based_Number_Ghost_Overflow + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with Ghost; + with procedure P_Lemma_Scan_Based_Number_Ghost_Step + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with Ghost; + + with function P_Raw_Unsigned_Last_Ghost + (Str : String; + From, To : Integer) + return Positive + with Ghost; + with function P_Only_Decimal_Ghost + (Str : String; + From, To : Integer) + return Boolean + with Ghost; + with function P_Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + return P_Uns_Option + with Ghost; + with function P_Is_Unsigned_Ghost (Str : String) return Boolean + with Ghost; + with function P_Is_Value_Unsigned_Ghost + (Str : String; + Val : Uns) return Boolean + with Ghost; + + with procedure P_Prove_Scan_Only_Decimal_Ghost + (Str : String; + Val : Uns) + with Ghost; + with procedure P_Prove_Scan_Based_Number_Ghost_Eq (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with Ghost; + + package Uns_Params is + subtype Uns_Option is P_Uns_Option with Ghost; + function Wrap_Option (Value : Uns) return Uns_Option renames + P_Wrap_Option; + function Hexa_To_Unsigned_Ghost + (X : Character) return Uns + renames P_Hexa_To_Unsigned_Ghost; + function Scan_Overflows_Ghost + (Digit : Uns; + Base : Uns; + Acc : Uns) return Boolean + renames P_Scan_Overflows_Ghost; + function Is_Raw_Unsigned_Format_Ghost + (Str : String) return Boolean + renames P_Is_Raw_Unsigned_Format_Ghost; + function Scan_Split_No_Overflow_Ghost + (Str : String; + From, To : Integer) return Boolean + renames P_Scan_Split_No_Overflow_Ghost; + function Raw_Unsigned_No_Overflow_Ghost + (Str : String; + From, To : Integer) return Boolean + renames P_Raw_Unsigned_No_Overflow_Ghost; + + function Exponent_Unsigned_Ghost + (Value : Uns; + Exp : Natural; + Base : Uns := 10) return Uns_Option + renames P_Exponent_Unsigned_Ghost; + procedure Lemma_Exponent_Unsigned_Ghost_Base + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + renames P_Lemma_Exponent_Unsigned_Ghost_Base; + procedure Lemma_Exponent_Unsigned_Ghost_Overflow + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + renames P_Lemma_Exponent_Unsigned_Ghost_Overflow; + procedure Lemma_Exponent_Unsigned_Ghost_Step + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + renames P_Lemma_Exponent_Unsigned_Ghost_Step; + + function Scan_Raw_Unsigned_Ghost + (Str : String; + From, To : Integer) return Uns + renames P_Scan_Raw_Unsigned_Ghost; + procedure Lemma_Scan_Based_Number_Ghost_Base + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + renames P_Lemma_Scan_Based_Number_Ghost_Base; + procedure Lemma_Scan_Based_Number_Ghost_Underscore + (Str : String; From, To : Integer; Base : Uns := 10; Acc : Uns := 0) + renames P_Lemma_Scan_Based_Number_Ghost_Underscore; + procedure Lemma_Scan_Based_Number_Ghost_Overflow + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + renames P_Lemma_Scan_Based_Number_Ghost_Overflow; + procedure Lemma_Scan_Based_Number_Ghost_Step + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + renames P_Lemma_Scan_Based_Number_Ghost_Step; + + function Raw_Unsigned_Last_Ghost + (Str : String; + From, To : Integer) return Positive + renames P_Raw_Unsigned_Last_Ghost; + function Only_Decimal_Ghost + (Str : String; + From, To : Integer) return Boolean + renames P_Only_Decimal_Ghost; + function Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) return Uns_Option + renames P_Scan_Based_Number_Ghost; + function Is_Unsigned_Ghost (Str : String) return Boolean + renames P_Is_Unsigned_Ghost; + function Is_Value_Unsigned_Ghost + (Str : String; + Val : Uns) return Boolean + renames P_Is_Value_Unsigned_Ghost; + + procedure Prove_Scan_Only_Decimal_Ghost + (Str : String; + Val : Uns) + renames P_Prove_Scan_Only_Decimal_Ghost; + procedure Prove_Scan_Based_Number_Ghost_Eq + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + renames P_Prove_Scan_Based_Number_Ghost_Eq; + end Uns_Params; + + -- 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 <>; + + with package P_Uns_Params is new System.Val_Util.Uns_Params + (Uns => Uns, others => <>) + with Ghost; + + with function P_Abs_Uns_Of_Int (Val : Int) return Uns + with Ghost; + with function P_Is_Int_Of_Uns + (Minus : Boolean; + Uval : Uns; + Val : Int) + return Boolean with Ghost; - with procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) + with function P_Is_Integer_Ghost (Str : String) return Boolean with Ghost; - with function Abs_Uns_Of_Int (Val : Int) return Uns + with function P_Is_Value_Integer_Ghost + (Str : String; + Val : Int) return Boolean with Ghost; - with function Value_Integer (Str : String) return Int + with procedure P_Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) with Ghost; package Int_Params is + package Uns_Params renames P_Uns_Params; + function Abs_Uns_Of_Int (Val : Int) return Uns renames + P_Abs_Uns_Of_Int; + function Is_Int_Of_Uns + (Minus : Boolean; + Uval : Uns; + Val : Int) + return Boolean + renames P_Is_Int_Of_Uns; + function Is_Integer_Ghost (Str : String) return Boolean renames + P_Is_Integer_Ghost; + function Is_Value_Integer_Ghost + (Str : String; + Val : Int) return Boolean + renames P_Is_Value_Integer_Ghost; + procedure Prove_Scan_Only_Decimal_Ghost (Str : String; Val : Int) renames + P_Prove_Scan_Only_Decimal_Ghost; end Int_Params; private diff --git a/gcc/ada/libgnat/s-vauspe.adb b/gcc/ada/libgnat/s-vauspe.adb new file mode 100644 index 0000000..1a870b9 --- /dev/null +++ b/gcc/ada/libgnat/s-vauspe.adb @@ -0,0 +1,198 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ U _ S P E C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2022-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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore, + Subprogram_Variant => Ignore); + +package body System.Value_U_Spec with SPARK_Mode is + + ----------------------------- + -- Exponent_Unsigned_Ghost -- + ----------------------------- + + function Exponent_Unsigned_Ghost + (Value : Uns; + Exp : Natural; + Base : Uns := 10) return Uns_Option + is + (if Exp = 0 or Value = 0 then (Overflow => False, Value => Value) + elsif Scan_Overflows_Ghost (0, Base, Value) then (Overflow => True) + else Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); + + --------------------- + -- Last_Hexa_Ghost -- + --------------------- + + function Last_Hexa_Ghost (Str : String) return Positive is + begin + for J in Str'Range loop + if Str (J) not in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' then + return J - 1; + end if; + + pragma Loop_Invariant + (for all K in Str'First .. J => + Str (K) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_'); + end loop; + + return Str'Last; + end Last_Hexa_Ghost; + + ----------------------------- + -- Lemmas with null bodies -- + ----------------------------- + + procedure Lemma_Scan_Based_Number_Ghost_Base + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is null; + + procedure Lemma_Scan_Based_Number_Ghost_Underscore + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is null; + + procedure Lemma_Scan_Based_Number_Ghost_Overflow + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is null; + + procedure Lemma_Scan_Based_Number_Ghost_Step + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is null; + + procedure Lemma_Exponent_Unsigned_Ghost_Base + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + is null; + + procedure Lemma_Exponent_Unsigned_Ghost_Overflow + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + is null; + + procedure Lemma_Exponent_Unsigned_Ghost_Step + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + is null; + + -------------------------------------- + -- Prove_Scan_Based_Number_Ghost_Eq -- + -------------------------------------- + + procedure Prove_Scan_Based_Number_Ghost_Eq + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + is + begin + if From > To then + null; + elsif Str1 (From) = '_' then + Prove_Scan_Based_Number_Ghost_Eq + (Str1, Str2, From + 1, To, Base, Acc); + elsif Scan_Overflows_Ghost + (Hexa_To_Unsigned_Ghost (Str1 (From)), Base, Acc) + then + null; + else + Prove_Scan_Based_Number_Ghost_Eq + (Str1, Str2, From + 1, To, Base, + Base * Acc + Hexa_To_Unsigned_Ghost (Str1 (From))); + end if; + end Prove_Scan_Based_Number_Ghost_Eq; + + ----------------------------------- + -- Prove_Scan_Only_Decimal_Ghost -- + ----------------------------------- + + procedure Prove_Scan_Only_Decimal_Ghost + (Str : String; + Val : Uns) + is + pragma Assert (Str (Str'First + 1) /= ' '); + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + pragma Assert (Non_Blank = Str'First + 1); + Fst_Num : constant Positive := + (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); + pragma Assert (Fst_Num = Str'First + 1); + begin + pragma Assert + (Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last))); + pragma Assert + (Scan_Split_No_Overflow_Ghost (Str, Str'First + 1, Str'Last)); + pragma Assert + ((Val, 10, 0) = Scan_Split_Value_Ghost (Str, Str'First + 1, Str'Last)); + pragma Assert + (Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last)); + pragma Assert (Val = Exponent_Unsigned_Ghost (Val, 0, 10).Value); + pragma Assert (Is_Unsigned_Ghost (Str)); + pragma Assert (Is_Value_Unsigned_Ghost (Str, Val)); + end Prove_Scan_Only_Decimal_Ghost; + + ----------------------------- + -- Scan_Based_Number_Ghost -- + ----------------------------- + + function Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) return Uns_Option + is + (if From > To then (Overflow => False, Value => Acc) + elsif Str (From) = '_' + then Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc) + elsif Scan_Overflows_Ghost + (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) + then (Overflow => True) + else Scan_Based_Number_Ghost + (Str, From + 1, To, Base, + Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); + +end System.Value_U_Spec; diff --git a/gcc/ada/libgnat/s-vauspe.ads b/gcc/ada/libgnat/s-vauspe.ads new file mode 100644 index 0000000..0d5c19e --- /dev/null +++ b/gcc/ada/libgnat/s-vauspe.ads @@ -0,0 +1,639 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L U E _ U _ S P E C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2022-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 contains the specification entities using for the formal +-- verification of the routines for scanning modular Unsigned values. + +-- Preconditions in this unit are meant for analysis only, not for run-time +-- checking, so that the expected exceptions are raised. This is enforced by +-- setting the corresponding assertion policy to Ignore. Postconditions and +-- contract cases should not be executed at runtime as well, in order not to +-- slow down the execution of these functions. + +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore, + Subprogram_Variant => Ignore); + +with System.Val_Util; use System.Val_Util; + +generic + + type Uns is mod <>; + +package System.Value_U_Spec with + Ghost, + SPARK_Mode, + Annotate => (GNATprove, Always_Return) +is + pragma Preelaborate; + + type Uns_Option (Overflow : Boolean := False) is record + case Overflow is + when True => + null; + when False => + Value : Uns := 0; + end case; + end record; + + function Wrap_Option (Value : Uns) return Uns_Option is + (Overflow => False, Value => Value); + + function Only_Decimal_Ghost + (Str : String; + From, To : Integer) + return Boolean + is + (for all J in From .. To => Str (J) in '0' .. '9') + with + Pre => From > To or else (From >= Str'First and then To <= Str'Last); + -- Ghost function that returns True if S has only decimal characters + -- from index From to index To. + + function Only_Hexa_Ghost (Str : String; From, To : Integer) return Boolean + is + (for all J in From .. To => + Str (J) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') + with + Pre => From > To or else (From >= Str'First and then To <= Str'Last); + -- Ghost function that returns True if S has only hexadecimal characters + -- from index From to index To. + + function Last_Hexa_Ghost (Str : String) return Positive + with + Pre => Str /= "" + and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F', + Post => Last_Hexa_Ghost'Result in Str'Range + and then (if Last_Hexa_Ghost'Result < Str'Last then + Str (Last_Hexa_Ghost'Result + 1) not in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_') + and then Only_Hexa_Ghost (Str, Str'First, Last_Hexa_Ghost'Result); + -- Ghost function that returns the index of the last character in S that + -- is either an hexadecimal digit or an underscore, which necessarily + -- exists given the precondition on Str. + + function Is_Based_Format_Ghost (Str : String) return Boolean + is + (Str /= "" + and then Str (Str'First) in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' + and then + (declare + L : constant Positive := Last_Hexa_Ghost (Str); + begin + Str (L) /= '_' + and then (for all J in Str'First .. L => + (if Str (J) = '_' then Str (J + 1) /= '_')))); + -- Ghost function that determines if Str has the correct format for a + -- based number, consisting in a sequence of hexadecimal digits possibly + -- separated by single underscores. It may be followed by other characters. + + function Hexa_To_Unsigned_Ghost (X : Character) return Uns is + (case X is + when '0' .. '9' => Character'Pos (X) - Character'Pos ('0'), + when 'a' .. 'f' => Character'Pos (X) - Character'Pos ('a') + 10, + when 'A' .. 'F' => Character'Pos (X) - Character'Pos ('A') + 10, + when others => raise Program_Error) + with + Pre => X in '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; + -- Ghost function that computes the value corresponding to an hexadecimal + -- digit. + + function Scan_Overflows_Ghost + (Digit : Uns; + Base : Uns; + Acc : Uns) return Boolean + is + (Digit >= Base + or else Acc > Uns'Last / Base + or else Uns'Last - Digit < Base * Acc); + -- Ghost function which returns True if Digit + Base * Acc overflows or + -- Digit is greater than Base, as this is used by the algorithm for the + -- test of overflow. + + function Scan_Based_Number_Ghost + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) return Uns_Option + with + Subprogram_Variant => (Increases => From), + Pre => Str'Last /= Positive'Last + and then + (From > To or else (From >= Str'First and then To <= Str'Last)) + and then Only_Hexa_Ghost (Str, From, To); + -- Ghost function that recursively computes the based number in Str, + -- assuming Acc has been scanned already and scanning continues at index + -- From. + + -- Lemmas unfolding the recursive definition of Scan_Based_Number_Ghost + + procedure Lemma_Scan_Based_Number_Ghost_Base + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Global => null, + Pre => Str'Last /= Positive'Last + and then + (From > To or else (From >= Str'First and then To <= Str'Last)) + and then Only_Hexa_Ghost (Str, From, To), + Post => + (if From > To + then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = + (Overflow => False, Value => Acc)); + -- Base case: Scan_Based_Number_Ghost returns Acc if From is bigger than To + + procedure Lemma_Scan_Based_Number_Ghost_Underscore + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Global => null, + Pre => Str'Last /= Positive'Last + and then + (From > To or else (From >= Str'First and then To <= Str'Last)) + and then Only_Hexa_Ghost (Str, From, To), + Post => + (if From <= To and then Str (From) = '_' + then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = + Scan_Based_Number_Ghost (Str, From + 1, To, Base, Acc)); + -- Underscore case: underscores are ignored while scanning + + procedure Lemma_Scan_Based_Number_Ghost_Overflow + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Global => null, + Pre => Str'Last /= Positive'Last + and then + (From > To or else (From >= Str'First and then To <= Str'Last)) + and then Only_Hexa_Ghost (Str, From, To), + Post => + (if From <= To + and then Str (From) /= '_' + and then Scan_Overflows_Ghost + (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) + then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = + (Overflow => True)); + -- Overflow case: scanning a digit which causes an overflow + + procedure Lemma_Scan_Based_Number_Ghost_Step + (Str : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Global => null, + Pre => Str'Last /= Positive'Last + and then + (From > To or else (From >= Str'First and then To <= Str'Last)) + and then Only_Hexa_Ghost (Str, From, To), + Post => + (if From <= To + and then Str (From) /= '_' + and then not Scan_Overflows_Ghost + (Hexa_To_Unsigned_Ghost (Str (From)), Base, Acc) + then Scan_Based_Number_Ghost (Str, From, To, Base, Acc) = + Scan_Based_Number_Ghost + (Str, From + 1, To, Base, + Base * Acc + Hexa_To_Unsigned_Ghost (Str (From)))); + -- Normal case: scanning a digit without overflows + + function Exponent_Unsigned_Ghost + (Value : Uns; + Exp : Natural; + Base : Uns := 10) return Uns_Option + with + Subprogram_Variant => (Decreases => Exp); + -- Ghost function that recursively computes Value * Base ** Exp + + -- Lemmas unfolding the recursive definition of Exponent_Unsigned_Ghost + + procedure Lemma_Exponent_Unsigned_Ghost_Base + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with + Post => + (if Exp = 0 or Value = 0 + then Exponent_Unsigned_Ghost (Value, Exp, Base) = + (Overflow => False, Value => Value)); + -- Base case: Exponent_Unsigned_Ghost returns 0 if Value or Exp is 0 + + procedure Lemma_Exponent_Unsigned_Ghost_Overflow + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with + Post => + (if Exp /= 0 + and then Value /= 0 + and then Scan_Overflows_Ghost (0, Base, Value) + then Exponent_Unsigned_Ghost (Value, Exp, Base) = (Overflow => True)); + -- Overflow case: the next multiplication overflows + + procedure Lemma_Exponent_Unsigned_Ghost_Step + (Value : Uns; + Exp : Natural; + Base : Uns := 10) + with + Post => + (if Exp /= 0 + and then Value /= 0 + and then not Scan_Overflows_Ghost (0, Base, Value) + then Exponent_Unsigned_Ghost (Value, Exp, Base) = + Exponent_Unsigned_Ghost (Value * Base, Exp - 1, Base)); + -- Normal case: exponentiation without overflows + + function Is_Raw_Unsigned_Format_Ghost (Str : String) return Boolean is + (Is_Natural_Format_Ghost (Str) + and then + (declare + Last_Num_Init : constant Integer := Last_Number_Ghost (Str); + Starts_As_Based : constant Boolean := + 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'; + Last_Num_Based : constant Integer := + (if Starts_As_Based + then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) + else Last_Num_Init); + Is_Based : constant Boolean := + Starts_As_Based + and then Last_Num_Based < Str'Last + and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); + First_Exp : constant Integer := + (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); + begin + (if Starts_As_Based then + Is_Based_Format_Ghost (Str (Last_Num_Init + 2 .. Str'Last)) + and then Last_Num_Based < Str'Last) + and then Is_Opt_Exponent_Format_Ghost + (Str (First_Exp .. Str'Last)))) + with + Pre => Str'Last /= Positive'Last; + -- Ghost function that determines if Str has the correct format for an + -- unsigned number without a sign character. + -- It is a natural number in base 10, optionally followed by a based + -- number surrounded by delimiters # or :, optionally followed by an + -- exponent part. + + type Split_Value_Ghost is record + Value : Uns; + Base : Uns; + Expon : Natural; + end record; + + function Scan_Split_No_Overflow_Ghost + (Str : String; + From, To : Integer) + return Boolean + is + (declare + Last_Num_Init : constant Integer := + Last_Number_Ghost (Str (From .. To)); + Init_Val : constant Uns_Option := + Scan_Based_Number_Ghost (Str, From, Last_Num_Init); + Starts_As_Based : constant Boolean := + Last_Num_Init < To - 1 + and then Str (Last_Num_Init + 1) in '#' | ':' + and then Str (Last_Num_Init + 2) in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; + Last_Num_Based : constant Integer := + (if Starts_As_Based + then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) + else Last_Num_Init); + Based_Val : constant Uns_Option := + (if Starts_As_Based and then not Init_Val.Overflow + then Scan_Based_Number_Ghost + (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) + else Init_Val); + begin + not Init_Val.Overflow + and then + (Last_Num_Init >= To - 1 + or else Str (Last_Num_Init + 1) not in '#' | ':' + or else Init_Val.Value in 2 .. 16) + and then + (not Starts_As_Based + or else not Based_Val.Overflow)) + with + Pre => Str'Last /= Positive'Last + and then From in Str'Range + and then To in From .. Str'Last + and then Str (From) in '0' .. '9'; + -- Ghost function that determines if an overflow might occur while scanning + -- the representation of an unsigned number. The computation overflows if + -- either: + -- * The computation of the decimal part overflows, + -- * The decimal part is followed by a valid delimiter for a based + -- part, and the number corresponding to the base is not a valid base, + -- or + -- * The computation of the based part overflows. + + pragma Warnings (Off, "constant * is not referenced"); + function Scan_Split_Value_Ghost + (Str : String; + From, To : Integer) + return Split_Value_Ghost + is + (declare + Last_Num_Init : constant Integer := + Last_Number_Ghost (Str (From .. To)); + Init_Val : constant Uns_Option := + Scan_Based_Number_Ghost (Str, From, Last_Num_Init); + Starts_As_Based : constant Boolean := + Last_Num_Init < To - 1 + and then Str (Last_Num_Init + 1) in '#' | ':' + and then Str (Last_Num_Init + 2) in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; + Last_Num_Based : constant Integer := + (if Starts_As_Based + then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) + else Last_Num_Init); + Is_Based : constant Boolean := + Starts_As_Based + and then Last_Num_Based < To + and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); + Based_Val : constant Uns_Option := + (if Starts_As_Based and then not Init_Val.Overflow + then Scan_Based_Number_Ghost + (Str, Last_Num_Init + 2, Last_Num_Based, Init_Val.Value) + else Init_Val); + First_Exp : constant Integer := + (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); + Expon : constant Natural := + (if Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) + then Scan_Exponent_Ghost (Str (First_Exp .. To)) + else 0); + Base : constant Uns := + (if Is_Based then Init_Val.Value else 10); + Value : constant Uns := + (if Is_Based then Based_Val.Value else Init_Val.Value); + begin + (Value => Value, Base => Base, Expon => Expon)) + with + Pre => Str'Last /= Positive'Last + and then From in Str'Range + and then To in From .. Str'Last + and then Str (From) in '0' .. '9' + and then Scan_Split_No_Overflow_Ghost (Str, From, To); + -- Ghost function that scans an unsigned number without a sign character + -- and return a record containing the values scanned for its value, its + -- base, and its exponent. + pragma Warnings (On, "constant * is not referenced"); + + function Raw_Unsigned_No_Overflow_Ghost + (Str : String; + From, To : Integer) + return Boolean + is + (Scan_Split_No_Overflow_Ghost (Str, From, To) + and then + (declare + Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost + (Str, From, To); + begin + not Exponent_Unsigned_Ghost + (Val.Value, Val.Expon, Val.Base).Overflow)) + with + Pre => Str'Last /= Positive'Last + and then From in Str'Range + and then To in From .. Str'Last + and then Str (From) in '0' .. '9'; + -- Ghost function that determines if the computation of the unsigned number + -- represented by Str will overflow. The computation overflows if either: + -- * The scan of the string overflows, or + -- * The computation of the exponentiation overflows. + + function Scan_Raw_Unsigned_Ghost + (Str : String; + From, To : Integer) + return Uns + is + (declare + Val : constant Split_Value_Ghost := Scan_Split_Value_Ghost + (Str, From, To); + begin + Exponent_Unsigned_Ghost (Val.Value, Val.Expon, Val.Base).Value) + with + Pre => Str'Last /= Positive'Last + and then From in Str'Range + and then To in From .. Str'Last + and then Str (From) in '0' .. '9' + and then Raw_Unsigned_No_Overflow_Ghost (Str, From, To); + -- Ghost function that scans an unsigned number without a sign character + + function Raw_Unsigned_Last_Ghost + (Str : String; + From, To : Integer) + return Positive + is + (declare + Last_Num_Init : constant Integer := + Last_Number_Ghost (Str (From .. To)); + Starts_As_Based : constant Boolean := + Last_Num_Init < To - 1 + and then Str (Last_Num_Init + 1) in '#' | ':' + and then Str (Last_Num_Init + 2) in + '0' .. '9' | 'a' .. 'f' | 'A' .. 'F'; + Last_Num_Based : constant Integer := + (if Starts_As_Based + then Last_Hexa_Ghost (Str (Last_Num_Init + 2 .. To)) + else Last_Num_Init); + Is_Based : constant Boolean := + Starts_As_Based + and then Last_Num_Based < To + and then Str (Last_Num_Based + 1) = Str (Last_Num_Init + 1); + First_Exp : constant Integer := + (if Is_Based then Last_Num_Based + 2 else Last_Num_Init + 1); + begin + (if not Starts_As_Exponent_Format_Ghost (Str (First_Exp .. To)) + then First_Exp + elsif Str (First_Exp + 1) in '-' | '+' then + Last_Number_Ghost (Str (First_Exp + 2 .. To)) + 1 + else Last_Number_Ghost (Str (First_Exp + 1 .. To)) + 1)) + with + Pre => Str'Last /= Positive'Last + and then From in Str'Range + and then To in From .. Str'Last + and then Str (From) in '0' .. '9'; + -- Ghost function that returns the position of the cursor once an unsigned + -- number has been seen. + + function Slide_To_1 (Str : String) return String + with + Post => + Only_Space_Ghost (Str, Str'First, Str'Last) = + (for all J in Str'First .. Str'Last => + Slide_To_1'Result (J - Str'First + 1) = ' '); + -- Slides Str so that it starts at 1 + + function Slide_If_Necessary (Str : String) return String is + (if Str'Last = Positive'Last then Slide_To_1 (Str) else Str); + -- If Str'Last = Positive'Last then slides Str so that it starts at 1 + + function Is_Unsigned_Ghost (Str : String) return Boolean is + (declare + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + Fst_Num : constant Positive := + (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); + begin + Is_Raw_Unsigned_Format_Ghost (Str (Fst_Num .. Str'Last)) + and then Raw_Unsigned_No_Overflow_Ghost (Str, Fst_Num, Str'Last) + and then Only_Space_Ghost + (Str, Raw_Unsigned_Last_Ghost (Str, Fst_Num, Str'Last), Str'Last)) + with + Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Str'Last /= Positive'Last; + -- Ghost function that determines if Str has the correct format for an + -- unsigned number, consisting in some blank characters, an optional + -- + sign, a raw unsigned number which does not overflow and then some + -- more blank characters. + + function Is_Value_Unsigned_Ghost (Str : String; Val : Uns) return Boolean is + (declare + Non_Blank : constant Positive := First_Non_Space_Ghost + (Str, Str'First, Str'Last); + Fst_Num : constant Positive := + (if Str (Non_Blank) = '+' then Non_Blank + 1 else Non_Blank); + begin + Val = Scan_Raw_Unsigned_Ghost (Str, Fst_Num, Str'Last)) + with + Pre => not Only_Space_Ghost (Str, Str'First, Str'Last) + and then Str'Last /= Positive'Last + and then Is_Unsigned_Ghost (Str); + -- Ghost function that returns True if Val is the value corresponding to + -- the unsigned number represented by Str. + + procedure Prove_Scan_Based_Number_Ghost_Eq + (Str1, Str2 : String; + From, To : Integer; + Base : Uns := 10; + Acc : Uns := 0) + with + Subprogram_Variant => (Increases => From), + Pre => Str1'Last /= Positive'Last + and then Str2'Last /= Positive'Last + and then + (From > To or else (From >= Str1'First and then To <= Str1'Last)) + and then + (From > To or else (From >= Str2'First and then To <= Str2'Last)) + and then Only_Hexa_Ghost (Str1, From, To) + and then (for all J in From .. To => Str1 (J) = Str2 (J)), + Post => + Scan_Based_Number_Ghost (Str1, From, To, Base, Acc) + = Scan_Based_Number_Ghost (Str2, From, To, Base, Acc); + -- Scan_Based_Number_Ghost returns the same value on two slices which are + -- equal. + + procedure Prove_Scan_Only_Decimal_Ghost + (Str : String; + Val : Uns) + with + Pre => Str'Last /= Positive'Last + and then Str'Length >= 2 + and then Str (Str'First) = ' ' + and then Only_Decimal_Ghost (Str, Str'First + 1, Str'Last) + and then Scan_Based_Number_Ghost (Str, Str'First + 1, Str'Last) + = Wrap_Option (Val), + Post => Is_Unsigned_Ghost (Slide_If_Necessary (Str)) + and then + Is_Value_Unsigned_Ghost (Slide_If_Necessary (Str), Val); + -- Ghost lemma used in the proof of 'Image implementation, to prove that + -- the result of Value_Unsigned on a decimal string is the same as the + -- result of Scan_Based_Number_Ghost. + + -- Bundle Uns type with other types, constants and subprograms used in + -- ghost code, so that this package can be instantiated once and used + -- multiple times as generic formal for a given Int type. + + package Uns_Params is new System.Val_Util.Uns_Params + (Uns => Uns, + P_Uns_Option => Uns_Option, + P_Wrap_Option => Wrap_Option, + P_Hexa_To_Unsigned_Ghost => Hexa_To_Unsigned_Ghost, + P_Scan_Overflows_Ghost => Scan_Overflows_Ghost, + P_Is_Raw_Unsigned_Format_Ghost => + Is_Raw_Unsigned_Format_Ghost, + P_Scan_Split_No_Overflow_Ghost => + Scan_Split_No_Overflow_Ghost, + P_Raw_Unsigned_No_Overflow_Ghost => + Raw_Unsigned_No_Overflow_Ghost, + P_Exponent_Unsigned_Ghost => Exponent_Unsigned_Ghost, + P_Lemma_Exponent_Unsigned_Ghost_Base => + Lemma_Exponent_Unsigned_Ghost_Base, + P_Lemma_Exponent_Unsigned_Ghost_Overflow => + Lemma_Exponent_Unsigned_Ghost_Overflow, + P_Lemma_Exponent_Unsigned_Ghost_Step => + Lemma_Exponent_Unsigned_Ghost_Step, + P_Scan_Raw_Unsigned_Ghost => Scan_Raw_Unsigned_Ghost, + P_Lemma_Scan_Based_Number_Ghost_Base => + Lemma_Scan_Based_Number_Ghost_Base, + P_Lemma_Scan_Based_Number_Ghost_Underscore => + Lemma_Scan_Based_Number_Ghost_Underscore, + P_Lemma_Scan_Based_Number_Ghost_Overflow => + Lemma_Scan_Based_Number_Ghost_Overflow, + P_Lemma_Scan_Based_Number_Ghost_Step => + Lemma_Scan_Based_Number_Ghost_Step, + P_Raw_Unsigned_Last_Ghost => Raw_Unsigned_Last_Ghost, + P_Only_Decimal_Ghost => Only_Decimal_Ghost, + P_Scan_Based_Number_Ghost => Scan_Based_Number_Ghost, + P_Is_Unsigned_Ghost => + Is_Unsigned_Ghost, + P_Is_Value_Unsigned_Ghost => + Is_Value_Unsigned_Ghost, + P_Prove_Scan_Only_Decimal_Ghost => + Prove_Scan_Only_Decimal_Ghost, + P_Prove_Scan_Based_Number_Ghost_Eq => + Prove_Scan_Based_Number_Ghost_Eq); + +private + + ---------------- + -- Slide_To_1 -- + ---------------- + + function Slide_To_1 (Str : String) return String is + (declare + Res : constant String (1 .. Str'Length) := Str; + begin + Res); + +end System.Value_U_Spec; diff --git a/gcc/ada/libgnat/s-widthu.adb b/gcc/ada/libgnat/s-widthu.adb index 390942c..df5f224 100644 --- a/gcc/ada/libgnat/s-widthu.adb +++ b/gcc/ada/libgnat/s-widthu.adb @@ -73,6 +73,14 @@ package body System.Width_U is Ghost, Post => X / Y / Z = X / (Y * Z); + procedure Lemma_Euclidian (V, Q, F, R : Big_Integer) + with + Ghost, + Pre => F > 0 and then Q = V / F and then R = V rem F, + Post => V = Q * F + R; + -- Ghost lemma to prove the relation between the quotient/remainder of + -- division by F and the value V. + ---------------------- -- Lemma_Lower_Mult -- ---------------------- @@ -104,6 +112,12 @@ package body System.Width_U is pragma Assert (X / YZ = XYZ + R / YZ); end Lemma_Div_Twice; + --------------------- + -- Lemma_Euclidian -- + --------------------- + + procedure Lemma_Euclidian (V, Q, F, R : Big_Integer) is null; + -- Local variables W : Natural; @@ -152,7 +166,7 @@ package body System.Width_U is 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_Euclidian (Big (T_Init), Q, F, R); Lemma_Lower_Mult (Q, Big (9), F); pragma Assert (Big (T_Init) <= Big (9) * F + F - 1); pragma Assert (Big (T_Init) < Big_10 * F); diff --git a/gcc/ada/libgnat/system-qnx-arm.ads b/gcc/ada/libgnat/system-qnx-arm.ads index 749384f..038fe6c 100644 --- a/gcc/ada/libgnat/system-qnx-arm.ads +++ b/gcc/ada/libgnat/system-qnx-arm.ads @@ -142,7 +142,7 @@ 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_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads index 46b740e..ae67cd0 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads @@ -151,7 +151,7 @@ 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_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64.ads b/gcc/ada/libgnat/system-vxworks7-aarch64.ads index 1aba15b..a943ecd 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64.ads @@ -148,7 +148,7 @@ 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_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads index e81348e..49e6e7a 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads @@ -148,7 +148,7 @@ 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_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-arm.ads b/gcc/ada/libgnat/system-vxworks7-arm.ads index 4ced0f1..6d3218f4 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm.ads @@ -146,7 +146,7 @@ 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_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads index 42ae983..e34c22a 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads @@ -146,7 +146,7 @@ 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_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads index 47dd3ae..68ca423 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads @@ -149,7 +149,7 @@ 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_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads index 7931241..6504a02 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads @@ -146,7 +146,7 @@ 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_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; 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 3c98b4c..ffcc78f 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads @@ -149,7 +149,7 @@ 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_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; |