diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index d941364eadef..96306f8cc9ae 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -110,14 +110,6 @@ GNATRTL_NONTASKING_OBJS= \ a-cbprqu$(objext) \ a-cbsyqu$(objext) \ a-cdlili$(objext) \ - a-cfdlli$(objext) \ - a-cfhama$(objext) \ - a-cfhase$(objext) \ - a-cfidll$(objext) \ - a-cfinve$(objext) \ - a-cfinse$(objext) \ - a-cforma$(objext) \ - a-cforse$(objext) \ a-cgaaso$(objext) \ a-cgarso$(objext) \ a-cgcaso$(objext) \ @@ -144,14 +136,7 @@ GNATRTL_NONTASKING_OBJS= \ a-clrefi$(objext) \ a-coboho$(objext) \ a-cobove$(objext) \ - a-cofove$(objext) \ - a-cofuba$(objext) \ - a-cofuma$(objext) \ - a-cofuse$(objext) \ - a-cofuve$(objext) \ a-cogeso$(objext) \ - a-cohama$(objext) \ - a-cohase$(objext) \ a-cohata$(objext) \ a-coinho$(objext) \ a-coinve$(objext) \ diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 343a9dbe8f94..6562c1213306 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -605,19 +605,7 @@ package body Impunit is -- GNAT Defined Additions to Ada 2012 -- ---------------------------------------- - ("a-cfidll", F), -- Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists - ("a-cfinse", F), -- Ada.Containers.Functional_Infinite_Sequences - ("a-cfinve", F), -- Ada.Containers.Formal_Indefinite_Vectors ("a-coboho", F), -- Ada.Containers.Bounded_Holders - ("a-cofove", F), -- Ada.Containers.Formal_Vectors - ("a-cofuma", F), -- Ada.Containers.Functional_Maps - ("a-cofuse", F), -- Ada.Containers.Functional_Sets - ("a-cofuve", F), -- Ada.Containers.Functional_Vectors - ("a-cfdlli", F), -- Ada.Containers.Formal_Doubly_Linked_Lists - ("a-cforse", F), -- Ada.Containers.Formal_Ordered_Sets - ("a-cforma", F), -- Ada.Containers.Formal_Ordered_Maps - ("a-cfhase", F), -- Ada.Containers.Formal_Hashed_Sets - ("a-cfhama", F), -- Ada.Containers.Formal_Hashed_Maps ("a-cvgpso", F) -- Ada.Containers.Vectors.Generic_Parallel_Sorting from ); -- GNATCOLL.OMP diff --git a/gcc/ada/libgnat/a-cfdlli.adb b/gcc/ada/libgnat/a-cfdlli.adb deleted file mode 100644 index bbb8fd449a7b..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 01e7db29132d..3a53ca57cf59 100644 --- a/gcc/ada/libgnat/a-cfdlli.ads +++ b/gcc/ada/libgnat/a-cfdlli.ads @@ -29,1643 +29,12 @@ -- . -- ------------------------------------------------------------------------------ -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 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; - - 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 bdf2c61d61e4..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 8cb7488f1830..42c7fbd896b1 100644 --- a/gcc/ada/libgnat/a-cfhama.ads +++ b/gcc/ada/libgnat/a-cfhama.ads @@ -29,885 +29,12 @@ -- . -- ------------------------------------------------------------------------------ --- 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; +package Ada.Containers.Formal_Hashed_Maps with SPARK_Mode is - 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; - - 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 34afa554c5f7..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 248a0ac9234b..633ed20841d6 100644 --- a/gcc/ada/libgnat/a-cfhase.ads +++ b/gcc/ada/libgnat/a-cfhase.ads @@ -29,1475 +29,12 @@ -- . -- ------------------------------------------------------------------------------ --- 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; +package Ada.Containers.Formal_Hashed_Sets with SPARK_Mode is - 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; - - 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 17e48d29e65f..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 c4d244a30b08..cbddde31b918 100644 --- a/gcc/ada/libgnat/a-cfidll.ads +++ b/gcc/ada/libgnat/a-cfidll.ads @@ -29,1642 +29,12 @@ -- . -- ------------------------------------------------------------------------------ -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 -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 Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); - pragma Assertion_Policy (Pre => Ignore); - pragma Assertion_Policy (Post => Ignore); - pragma Assertion_Policy (Contract_Cases => Ignore); - pragma Annotate (CodePeer, Skip_Analysis); - - type List is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Element), - Default_Initial_Condition => Is_Empty (List); - - type Cursor is record - Node : Count_Type := 0; - end record; - - No_Element : constant Cursor := Cursor'(Node => 0); - - function Length (Container : List) return Count_Type with - Global => null; - - function Empty_List return List with - Global => null, - Post => Length (Empty_List'Result) = 0; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Vectors - (Index_Type => Positive_Count_Type, - Element_Type => Element_Type); - - function "=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."="; - - function "<" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<"; - - function "<=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<="; - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - -- The elements of Container are contained in either Left or Right - with - Global => null, - Post => - M_Elements_In_Union'Result = - (for all I in 1 .. M.Length (Container) => - (for some J in 1 .. M.Length (Left) => - Element (Container, I) = Element (Left, J)) - or (for some J in 1 .. M.Length (Right) => - Element (Container, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Positive_Count_Type := 1; - L_Lst : Count_Type; - Right : M.Sequence; - R_Fst : Positive_Count_Type := 1; - R_Lst : Count_Type) return Boolean - -- The elements of the slice from L_Fst to L_Lst in Left are contained - -- in the slide from R_Fst to R_Lst in Right. - with - Global => null, - Pre => L_Lst <= M.Length (Left) and R_Lst <= M.Length (Right), - Post => - M_Elements_Included'Result = - (for all I in L_Fst .. L_Lst => - (for some J in R_Fst .. R_Lst => - Element (Left, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - -- Right is Left in reverse order - with - Global => null, - Post => - M_Elements_Reversed'Result = - (M.Length (Left) = M.Length (Right) - and (for all I in 1 .. M.Length (Left) => - Element (Left, I) = - Element (Right, M.Length (Left) - I + 1)) - and (for all I in 1 .. M.Length (Left) => - Element (Right, I) = - Element (Left, M.Length (Left) - I + 1))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Positive_Count_Type; - Y : Positive_Count_Type) return Boolean - -- Elements stored at X and Y are reversed in Left and Right - with - Global => null, - Pre => X <= M.Length (Left) and Y <= M.Length (Left), - Post => - M_Elements_Swapped'Result = - (M.Length (Left) = M.Length (Right) - and Element (Left, X) = Element (Right, Y) - and Element (Left, Y) = Element (Right, X) - and M.Equal_Except (Left, Right, X, Y)); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Global => null, - Post => - P_Positions_Shifted'Result = - - -- Big contains all cursors of Small - - (P.Keys_Included (Small, Big) - - -- Cursors located before Cut are not moved, cursors located - -- after are shifted by Count. - - and (for all I of Small => - (if P.Get (Small, I) < Cut then - P.Get (Big, I) = P.Get (Small, I) - else - P.Get (Big, I) - Count = P.Get (Small, I))) - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function P_Positions_Swapped - (Left : P.Map; - Right : P.Map; - X : Cursor; - Y : Cursor) return Boolean - -- Left and Right contain the same cursors, but the positions of X and Y - -- are reversed. - with - Ghost, - Global => null, - Post => - P_Positions_Swapped'Result = - (P.Same_Keys (Left, Right) - and P.Elements_Equal_Except (Left, Right, X, Y) - and P.Has_Key (Left, X) - and P.Has_Key (Left, Y) - and P.Get (Left, X) = P.Get (Right, Y) - and P.Get (Left, Y) = P.Get (Right, X)); - - function P_Positions_Truncated - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Ghost, - Global => null, - Post => - P_Positions_Truncated'Result = - - -- Big contains all cursors of Small at the same position - - (Small <= Big - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function Mapping_Preserved - (M_Left : M.Sequence; - M_Right : M.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Left and Right contain the same cursors - - P.Same_Keys (P_Left, P_Right) - - -- Mappings from cursors to elements induced by M_Left, P_Left - -- and M_Right, P_Right are the same. - - and (for all C of P_Left => - M.Get (M_Left, P.Get (P_Left, C)) = - M.Get (M_Right, P.Get (P_Right, C)))); - - function Model (Container : List) return M.Sequence with - -- The high-level model of a list is a sequence of elements. Cursors are - -- not represented in this model. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model); - - function Positions (Container : List) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and map them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : List) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access to the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level cursor-aware view of a container to a high-level - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Elt of Model (Container) => - (for some I of Positions (Container) => - M.Get (Model (Container), P.Get (Positions (Container), I)) = - Elt)); - - function Element - (S : M.Sequence; - I : Count_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - - end Formal_Model; - use Formal_Model; - - function "=" (Left, Right : List) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function Is_Empty (Container : List) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out List) with - Global => null, - Post => Length (Container) = 0; - - procedure Assign (Target : in out List; Source : List) with - Global => null, - Post => Model (Target) = Model (Source); - - function Copy (Source : List) return List with - Global => null, - Post => - Model (Copy'Result) = Model (Source) - and Positions (Copy'Result) = Positions (Source); - - function Element - (Container : List; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = - Element (Model (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - - -- Cursors are preserved - - and Positions (Container)'Old = Positions (Container) - - -- The element at the position of Position in Container is New_Item - - and Element - (Model (Container), - P.Get (Positions (Container), Position)) = New_Item - - -- Other elements are preserved - - and M.Equal_Except - (Model (Container)'Old, - Model (Container), - P.Get (Positions (Container), Position)); - - function At_End (E : access constant List) return access constant List - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function At_End - (E : access constant Element_Type) return access constant Element_Type - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function Constant_Reference - (Container : List; - Position : Cursor) return not null access constant Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Constant_Reference'Result.all = - Element (Model (Container), P.Get (Positions (Container), Position)); - - function Reference - (Container : not null access List; - Position : Cursor) return not null access Element_Type - with - Global => null, - Pre => Has_Element (Container.all, Position), - Post => - Length (Container.all) = Length (At_End (Container).all) - - -- Cursors are preserved - - and Positions (Container.all) = Positions (At_End (Container).all) - - -- Container will have Result.all at position Position - - and At_End (Reference'Result).all = - Element (Model (At_End (Container).all), - P.Get (Positions (At_End (Container).all), Position)) - - -- All other elements are preserved - - and M.Equal_Except - (Model (Container.all), - Model (At_End (Container).all), - P.Get (Positions (At_End (Container).all), Position)); - - procedure Move (Target : in out List; Source : in out List) with - Global => null, - Post => Model (Target) = Model (Source'Old) and Length (Source) = 0; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Count_Type'Last - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + 1, - Contract_Cases => - (Before = No_Element => - - -- Positions contains a new mapping from the last cursor of - -- Container to its length. - - P.Get (Positions (Container), Last (Container)) = Length (Container) - - -- Other cursors come from Container'Old - - and P.Keys_Included_Except - (Left => Positions (Container), - Right => Positions (Container)'Old, - New_Key => Last (Container)) - - -- Cursors of Container'Old keep the same position - - and Positions (Container)'Old <= Positions (Container) - - -- Model contains a new element New_Item at the end - - and Element (Model (Container), Length (Container)) = New_Item - - -- Elements of Container'Old are preserved - - and Model (Container)'Old <= Model (Container), - - others => - - -- The elements of Container located before Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is stored at the previous position of Before in - -- Container. - - and Element - (Model (Container), - P.Get (Positions (Container)'Old, Before)) = New_Item - - -- A new cursor has been inserted at position Before in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container)'Old, Before))); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Count_Type'Last - Count - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + Count, - Contract_Cases => - (Before = No_Element => - - -- The elements of Container are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old) - - -- Container contains Count times New_Item at the end - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Length (Container)'Old + 1, - Lst => Length (Container), - Item => New_Item)) - - -- Count cursors have been inserted at the end of Container - - and P_Positions_Truncated - (Positions (Container)'Old, - Positions (Container), - Cut => Length (Container)'Old + 1, - Count => Count), - - others => - - -- The elements of Container located before Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1) - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => Length (Container)'Old, - Offset => Count) - - -- Container contains Count times New_Item after position Before - - and M.Constant_Range - (Container => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => - P.Get (Positions (Container)'Old, Before) - 1 + Count, - Item => New_Item) - - -- Count cursors have been inserted at position Before in - -- Container. - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container)'Old, Before), - Count => Count)); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor) - with - Global => null, - Pre => - Length (Container) < Count_Type'Last - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Positions is valid in Container and it is located either before - -- Before if it is valid in Container or at the end if it is - -- No_Element. - - and P.Has_Key (Positions (Container), Position) - and (if Before = No_Element then - P.Get (Positions (Container), Position) = Length (Container) - else - P.Get (Positions (Container), Position) = - P.Get (Positions (Container)'Old, Before)) - - -- The elements of Container located before Position are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is stored at Position in Container - - and Element - (Model (Container), - P.Get (Positions (Container), Position)) = New_Item - - -- A new cursor has been inserted at position Position in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position)); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Count_Type'Last - Count - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + Count, - Contract_Cases => - (Count = 0 => - Position = Before - and Model (Container) = Model (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - others => - - -- Positions is valid in Container and it is located either before - -- Before if it is valid in Container or at the end if it is - -- No_Element. - - P.Has_Key (Positions (Container), Position) - and (if Before = No_Element then - P.Get (Positions (Container), Position) = - Length (Container)'Old + 1 - else - P.Get (Positions (Container), Position) = - P.Get (Positions (Container)'Old, Before)) - - -- The elements of Container located before Position are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => Count) - - -- Container contains Count times New_Item after position Position - - and M.Constant_Range - (Container => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => - P.Get (Positions (Container), Position) - 1 + Count, - Item => New_Item) - - -- Count cursor have been inserted at Position in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position), - Count => Count)); - - procedure Prepend (Container : in out List; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Count_Type'Last, - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is the first element of Container - - and Element (Model (Container), 1) = New_Item - - -- A new cursor has been inserted at the beginning of Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => 1); - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Count_Type'Last - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old, - Offset => Count) - - -- Container starts with Count times New_Item - - and M.Constant_Range - (Container => Model (Container), - Fst => 1, - Lst => Count, - Item => New_Item) - - -- Count cursors have been inserted at the beginning of Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => 1, - Count => Count); - - procedure Append (Container : in out List; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Count_Type'Last, - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Positions contains a new mapping from the last cursor of Container - -- to its length. - - and P.Get (Positions (Container), Last (Container)) = - Length (Container) - - -- Other cursors come from Container'Old - - and P.Keys_Included_Except - (Left => Positions (Container), - Right => Positions (Container)'Old, - New_Key => Last (Container)) - - -- Cursors of Container'Old keep the same position - - and Positions (Container)'Old <= Positions (Container) - - -- Model contains a new element New_Item at the end - - and Element (Model (Container), Length (Container)) = New_Item - - -- Elements of Container'Old are preserved - - and Model (Container)'Old <= Model (Container); - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Count_Type'Last - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- The elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- Container contains Count times New_Item at the end - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Length (Container)'Old + 1, - Lst => Length (Container), - Item => New_Item)) - - -- Count cursors have been inserted at the end of Container - - and P_Positions_Truncated - (Positions (Container)'Old, - Positions (Container), - Cut => Length (Container)'Old + 1, - Count => Count); - - procedure Delete (Container : in out List; Position : in out Cursor) with - Global => null, - Depends => (Container =>+ Position, Position => null), - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Position is set to No_Element - - and Position = No_Element - - -- The elements of Container located before Position are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => 1) - - -- Position has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old)); - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) in - Length (Container)'Old - Count .. Length (Container)'Old - - -- Position is set to No_Element - - and Position = No_Element - - -- The elements of Container located before Position are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1), - - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) - Count < P.Get (Positions (Container), Position) => - Length (Container) = - P.Get (Positions (Container)'Old, Position'Old) - 1 - - -- At most Count cursors have been removed at the end of Container - - and P_Positions_Truncated - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old), - Count => Count), - - others => - Length (Container) = Length (Container)'Old - Count - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => Count) - - -- Count cursors have been removed from Container at Position - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old), - Count => Count)); - - procedure Delete_First (Container : in out List) with - Global => null, - Pre => not Is_Empty (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- The elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => 1) - - -- The first cursor of Container has been removed - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1); - - procedure Delete_First (Container : in out List; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => - Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- Elements of Container are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => Count) - - -- The first Count cursors have been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1, - Count => Count)); - - procedure Delete_Last (Container : in out List) with - Global => null, - Pre => not Is_Empty (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old - - -- The last cursor of Container has been removed - - and not P.Has_Key (Positions (Container), Last (Container)'Old) - - -- Other cursors are still valid - - and P.Keys_Included_Except - (Left => Positions (Container)'Old, - Right => Positions (Container)'Old, - New_Key => Last (Container)'Old) - - -- The positions of other cursors are preserved - - and Positions (Container) <= Positions (Container)'Old; - - procedure Delete_Last (Container : in out List; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => - Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old - - -- At most Count cursors have been removed at the end of Container - - and P_Positions_Truncated - (Positions (Container), - Positions (Container)'Old, - Cut => Length (Container) + 1, - Count => Count)); - - procedure Reverse_Elements (Container : in out List) with - Global => null, - Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); - - procedure Swap - (Container : in out List; - I : Cursor; - J : Cursor) - with - Global => null, - Pre => Has_Element (Container, I) and then Has_Element (Container, J), - Post => - M_Elements_Swapped - (Model (Container)'Old, - Model (Container), - X => P.Get (Positions (Container)'Old, I), - Y => P.Get (Positions (Container)'Old, J)) - - and Positions (Container) = Positions (Container)'Old; - - procedure Swap_Links - (Container : in out List; - I : Cursor; - J : Cursor) - with - Global => null, - Pre => Has_Element (Container, I) and then Has_Element (Container, J), - Post => - M_Elements_Swapped - (Model (Container'Old), - Model (Container), - X => P.Get (Positions (Container)'Old, I), - Y => P.Get (Positions (Container)'Old, J)) - and P_Positions_Swapped - (Positions (Container)'Old, Positions (Container), I, J); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List) - -- Target and Source should not be aliased - with - Global => null, - Pre => - Length (Source) <= Count_Type'Last - Length (Target) - and then (Has_Element (Target, Before) or else Before = No_Element), - Post => - Length (Source) = 0 - and Length (Target) = Length (Target)'Old + Length (Source)'Old, - Contract_Cases => - (Before = No_Element => - - -- The elements of Target are preserved - - M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => Length (Target)'Old) - - -- The elements of Source are appended to target, the order is not - -- specified. - - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Fst => Length (Target)'Old + 1, - R_Lst => Length (Target)) - - and M_Elements_Included - (Left => Model (Target), - L_Fst => Length (Target)'Old + 1, - L_Lst => Length (Target), - Right => Model (Source)'Old, - R_Lst => Length (Source)'Old) - - -- Cursors have been inserted at the end of Target - - and P_Positions_Truncated - (Positions (Target)'Old, - Positions (Target), - Cut => Length (Target)'Old + 1, - Count => Length (Source)'Old), - - others => - - -- The elements of Target located before Before are preserved - - M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => P.Get (Positions (Target)'Old, Before) - 1) - - -- The elements of Source are inserted before Before, the order is - -- not specified. - - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Fst => P.Get (Positions (Target)'Old, Before), - R_Lst => - P.Get (Positions (Target)'Old, Before) - 1 + - Length (Source)'Old) - - and M_Elements_Included - (Left => Model (Target), - L_Fst => P.Get (Positions (Target)'Old, Before), - L_Lst => - P.Get (Positions (Target)'Old, Before) - 1 + - Length (Source)'Old, - Right => Model (Source)'Old, - R_Lst => Length (Source)'Old) - - -- Other elements are shifted by the length of Source - - and M.Range_Shifted - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => P.Get (Positions (Target)'Old, Before), - Lst => Length (Target)'Old, - Offset => Length (Source)'Old) - - -- Cursors have been inserted at position Before in Target - - and P_Positions_Shifted - (Positions (Target)'Old, - Positions (Target), - Cut => P.Get (Positions (Target)'Old, Before), - Count => Length (Source)'Old)); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor) - -- Target and Source should not be aliased - with - Global => null, - Pre => - (Has_Element (Target, Before) or else Before = No_Element) - and then Has_Element (Source, Position) - and then Length (Target) < Count_Type'Last, - Post => - Length (Target) = Length (Target)'Old + 1 - and Length (Source) = Length (Source)'Old - 1 - - -- The elements of Source located before Position are preserved - - and M.Range_Equal - (Left => Model (Source)'Old, - Right => Model (Source), - Fst => 1, - Lst => P.Get (Positions (Source)'Old, Position'Old) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Source)'Old, - Right => Model (Source), - Fst => P.Get (Positions (Source)'Old, Position'Old) + 1, - Lst => Length (Source)'Old, - Offset => -1) - - -- Position has been removed from Source - - and P_Positions_Shifted - (Positions (Source), - Positions (Source)'Old, - Cut => P.Get (Positions (Source)'Old, Position'Old)) - - -- Positions is valid in Target and it is located either before - -- Before if it is valid in Target or at the end if it is No_Element. - - and P.Has_Key (Positions (Target), Position) - and (if Before = No_Element then - P.Get (Positions (Target), Position) = Length (Target) - else - P.Get (Positions (Target), Position) = - P.Get (Positions (Target)'Old, Before)) - - -- The elements of Target located before Position are preserved - - and M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => P.Get (Positions (Target), Position) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => P.Get (Positions (Target), Position), - Lst => Length (Target)'Old, - Offset => 1) - - -- The element located at Position in Source is moved to Target - - and Element (Model (Target), - P.Get (Positions (Target), Position)) = - Element (Model (Source)'Old, - P.Get (Positions (Source)'Old, Position'Old)) - - -- A new cursor has been inserted at position Position in Target - - and P_Positions_Shifted - (Positions (Target)'Old, - Positions (Target), - Cut => P.Get (Positions (Target), Position)); - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor) - with - Global => null, - Pre => - (Has_Element (Container, Before) or else Before = No_Element) - and then Has_Element (Container, Position), - Post => Length (Container) = Length (Container)'Old, - Contract_Cases => - (Before = Position => - Model (Container) = Model (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - Before = No_Element => - - -- The elements located before Position are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Position) + 1, - Lst => Length (Container)'Old, - Offset => -1) - - -- The last element of Container is the one that was previously at - -- Position. - - and Element (Model (Container), - Length (Container)) = - Element (Model (Container)'Old, - P.Get (Positions (Container)'Old, Position)) - - -- Cursors from Container continue designating the same elements - - and Mapping_Preserved - (M_Left => Model (Container)'Old, - M_Right => Model (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)), - - others => - - -- The elements located before Position and Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => - Count_Type'Min - (P.Get (Positions (Container)'Old, Position) - 1, - P.Get (Positions (Container)'Old, Before) - 1)) - - -- The elements located after Position and Before are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => - Count_Type'Max - (P.Get (Positions (Container)'Old, Position) + 1, - P.Get (Positions (Container)'Old, Before) + 1), - Lst => Length (Container)) - - -- The elements located after Before and before Position are - -- shifted by 1 to the right. - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before) + 1, - Lst => P.Get (Positions (Container)'Old, Position) - 1, - Offset => 1) - - -- The elements located after Position and before Before are - -- shifted by 1 to the left. - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Position) + 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1, - Offset => -1) - - -- The element previously at Position is now before Before - - and Element - (Model (Container), - P.Get (Positions (Container)'Old, Before)) = - Element - (Model (Container)'Old, - P.Get (Positions (Container)'Old, Position)) - - -- Cursors from Container continue designating the same elements - - and Mapping_Preserved - (M_Left => Model (Container)'Old, - M_Right => Model (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container))); - - function First (Container : List) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - - function First_Element (Container : List) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => First_Element'Result = M.Get (Model (Container), 1); - - function Last (Container : List) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - Last'Result = No_Element, - - others => - Has_Element (Container, Last'Result) - and P.Get (Positions (Container), Last'Result) = - Length (Container)); - - function Last_Element (Container : List) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = M.Get (Model (Container), Length (Container)); - - function Next (Container : List; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - - procedure Next (Container : List; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - - function Previous (Container : List; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Previous'Result = No_Element, - - others => - Has_Element (Container, Previous'Result) - and then P.Get (Positions (Container), Previous'Result) = - P.Get (Positions (Container), Position) - 1); - - procedure Previous (Container : List; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) - 1); - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - - -- If Item is not contained in Container after Position, Find returns - -- No_Element. - - (not M.Contains - (Container => Model (Container), - Fst => - (if Position = No_Element then - 1 - else - P.Get (Positions (Container), Position)), - Lst => Length (Container), - Item => Item) - => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - - -- The element designated by the result of Find is Item - - and Element - (Model (Container), - P.Get (Positions (Container), Find'Result)) = Item - - -- The result of Find is located after Position - - and (if Position /= No_Element then - P.Get (Positions (Container), Find'Result) >= - P.Get (Positions (Container), Position)) - - -- It is the first occurrence of Item in this slice - - and not M.Contains - (Container => Model (Container), - Fst => - (if Position = No_Element then - 1 - else - P.Get (Positions (Container), Position)), - Lst => - P.Get (Positions (Container), Find'Result) - 1, - Item => Item)); - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - - -- If Item is not contained in Container before Position, Find returns - -- No_Element. - - (not M.Contains - (Container => Model (Container), - Fst => 1, - Lst => - (if Position = No_Element then - Length (Container) - else - P.Get (Positions (Container), Position)), - Item => Item) - => - Reverse_Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Reverse_Find'Result) - - -- The element designated by the result of Find is Item - - and Element - (Model (Container), - P.Get (Positions (Container), Reverse_Find'Result)) = Item - - -- The result of Find is located before Position - - and (if Position /= No_Element then - P.Get (Positions (Container), Reverse_Find'Result) <= - P.Get (Positions (Container), Position)) - - -- It is the last occurrence of Item in this slice - - and not M.Contains - (Container => Model (Container), - Fst => - P.Get (Positions (Container), - Reverse_Find'Result) + 1, - Lst => - (if Position = No_Element then - Length (Container) - else - P.Get (Positions (Container), Position)), - Item => Item)); - - function Contains - (Container : List; - Item : Element_Type) return Boolean - with - Global => null, - Post => - Contains'Result = M.Contains (Container => Model (Container), - Fst => 1, - Lst => Length (Container), - Item => Item); - - function Has_Element - (Container : List; - Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - - package Generic_Sorting with SPARK_Mode is - - package Formal_Model with Ghost is - function M_Elements_Sorted (Container : M.Sequence) return Boolean - with - Global => null, - Post => - M_Elements_Sorted'Result = - (for all I in 1 .. M.Length (Container) => - (for all J in I .. M.Length (Container) => - not (Element (Container, J) < Element (Container, I)))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); - - end Formal_Model; - use Formal_Model; - - function Is_Sorted (Container : List) return Boolean with - Global => null, - Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); - - procedure Sort (Container : in out List) with - Global => null, - Post => - Length (Container) = Length (Container)'Old - and M_Elements_Sorted (Model (Container)) - and M_Elements_Included - (Left => Model (Container)'Old, - L_Lst => Length (Container), - Right => Model (Container), - R_Lst => Length (Container)) - and M_Elements_Included - (Left => Model (Container), - L_Lst => Length (Container), - Right => Model (Container)'Old, - R_Lst => Length (Container)); - - procedure Merge (Target : in out List; Source : in out List) with - -- Target and Source should not be aliased - Global => null, - Pre => Length (Target) <= Count_Type'Last - Length (Source), - Post => - Length (Target) = Length (Target)'Old + Length (Source)'Old - and Length (Source) = 0 - and (if M_Elements_Sorted (Model (Target)'Old) - and M_Elements_Sorted (Model (Source)'Old) - then - M_Elements_Sorted (Model (Target))) - and M_Elements_Included - (Left => Model (Target)'Old, - L_Lst => Length (Target)'Old, - Right => Model (Target), - R_Lst => Length (Target)) - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Lst => Length (Target)) - and M_Elements_In_Union - (Model (Target), - Model (Source)'Old, - Model (Target)'Old); - end Generic_Sorting; - -private - pragma SPARK_Mode (Off); - - use Ada.Finalization; - - type Element_Access is access all Element_Type; - - type Node_Type is record - Prev : Count_Type'Base := -1; - Next : Count_Type := 0; - Element : Element_Access := null; - end record; - - type Node_Access is access all Node_Type; - - function "=" (L, R : Node_Type) return Boolean is abstract; - - type Node_Array is array (Count_Type range <>) of Node_Type; - function "=" (L, R : Node_Array) return Boolean is abstract; - - type Node_Array_Access is access all Node_Array; - - type List is new Controlled with record - Free : Count_Type'Base := -1; - Length : Count_Type := 0; - First : Count_Type := 0; - Last : Count_Type := 0; - Nodes : Node_Array_Access := null; - end record; - - overriding procedure Finalize (Container : in out List); - overriding procedure Adjust (Container : in out List); end Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfinse.adb b/gcc/ada/libgnat/a-cfinse.adb deleted file mode 100644 index 7b457f6fb9f5..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 d7fdb0426cc6..6f517fa80461 100644 --- a/gcc/ada/libgnat/a-cfinse.ads +++ b/gcc/ada/libgnat/a-cfinse.ads @@ -29,352 +29,12 @@ -- . -- ------------------------------------------------------------------------------ -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 is -package Ada.Containers.Functional_Infinite_Sequences with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); - type Sequence is private - with Default_Initial_Condition => Length (Sequence) = 0, - Iterable => (First => Iter_First, - Has_Element => Iter_Has_Element, - Next => Iter_Next, - Element => Get); - -- Sequences are empty when default initialized. - -- Quantification over sequences can be done using the regular - -- quantification over its range or directly on its elements with "for of". - - ----------------------- - -- Basic operations -- - ----------------------- - - -- Sequences are axiomatized using Length and Get, providing respectively - -- the length of a sequence and an accessor to its Nth element: - - function Length (Container : Sequence) return Big_Natural with - -- Length of a sequence - - Global => null; - - function Get - (Container : Sequence; - Position : Big_Integer) return Element_Type - -- Access the Element at position Position in Container - - with - Global => null, - Pre => Iter_Has_Element (Container, Position); - - function Last (Container : Sequence) return Big_Natural with - -- Last index of a sequence - - Global => null, - Post => - Last'Result = Length (Container); - pragma Annotate (GNATprove, Inline_For_Proof, Last); - - function First return Big_Positive is (1) with - -- First index of a sequence - - Global => null; - - ------------------------ - -- Property Functions -- - ------------------------ - - function "=" (Left : Sequence; Right : Sequence) return Boolean with - -- Extensional equality over sequences - - Global => null, - Post => - "="'Result = - (Length (Left) = Length (Right) - and then (for all N in Left => Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "="); - - function "<" (Left : Sequence; Right : Sequence) return Boolean with - -- Left is a strict subsequence of Right - - Global => null, - Post => - "<"'Result = - (Length (Left) < Length (Right) - and then (for all N in Left => Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "<"); - - function "<=" (Left : Sequence; Right : Sequence) return Boolean with - -- Left is a subsequence of Right - - Global => null, - Post => - "<="'Result = - (Length (Left) <= Length (Right) - and then (for all N in Left => Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "<="); - - function Contains - (Container : Sequence; - Fst : Big_Positive; - Lst : Big_Natural; - Item : Element_Type) return Boolean - -- Returns True if Item occurs in the range from Fst to Lst of Container - - with - Global => null, - Pre => Lst <= Last (Container), - Post => - Contains'Result = - (for some J in Container => - Fst <= J and J <= Lst and Get (Container, J) = Item); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Constant_Range - (Container : Sequence; - Fst : Big_Positive; - Lst : Big_Natural; - Item : Element_Type) return Boolean - -- Returns True if every element of the range from Fst to Lst of Container - -- is equal to Item. - - with - Global => null, - Pre => Lst <= Last (Container), - Post => - Constant_Range'Result = - (for all J in Container => - (if Fst <= J and J <= Lst then Get (Container, J) = Item)); - pragma Annotate (GNATprove, Inline_For_Proof, Constant_Range); - - function Equal_Except - (Left : Sequence; - Right : Sequence; - Position : Big_Positive) return Boolean - -- Returns True is Left and Right are the same except at position Position - - with - Global => null, - Pre => Position <= Last (Left), - Post => - Equal_Except'Result = - (Length (Left) = Length (Right) - and then (for all J in Left => - (if J /= Position then - Get (Left, J) = Get (Right, J)))); - pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); - - function Equal_Except - (Left : Sequence; - Right : Sequence; - X : Big_Positive; - Y : Big_Positive) return Boolean - -- Returns True is Left and Right are the same except at positions X and Y - - with - Global => null, - Pre => X <= Last (Left) and Y <= Last (Left), - Post => - Equal_Except'Result = - (Length (Left) = Length (Right) - and then (for all J in Left => - (if J /= X and J /= Y then - Get (Left, J) = Get (Right, J)))); - pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); - - function Range_Equal - (Left : Sequence; - Right : Sequence; - Fst : Big_Positive; - Lst : Big_Natural) return Boolean - -- Returns True if the ranges from Fst to Lst contain the same elements in - -- Left and Right. - - with - Global => null, - Pre => Lst <= Last (Left) and Lst <= Last (Right), - Post => - Range_Equal'Result = - (for all J in Left => - (if Fst <= J and J <= Lst then Get (Left, J) = Get (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, Range_Equal); - - function Range_Shifted - (Left : Sequence; - Right : Sequence; - Fst : Big_Positive; - Lst : Big_Natural; - Offset : Big_Integer) return Boolean - -- Returns True if the range from Fst to Lst in Left contains the same - -- elements as the range from Fst + Offset to Lst + Offset in Right. - - with - Global => null, - Pre => - Lst <= Last (Left) - and then - (if Fst <= Lst then - Offset + Fst >= 1 and Offset + Lst <= Length (Right)), - Post => - Range_Shifted'Result = - ((for all J in Left => - (if Fst <= J and J <= Lst then - Get (Left, J) = Get (Right, J + Offset))) - and - (for all J in Right => - (if Fst + Offset <= J and J <= Lst + Offset then - Get (Left, J - Offset) = Get (Right, J)))); - pragma Annotate (GNATprove, Inline_For_Proof, Range_Shifted); - - ---------------------------- - -- Construction Functions -- - ---------------------------- - - -- For better efficiency of both proofs and execution, avoid using - -- construction functions in annotations and rather use property functions. - - function Set - (Container : Sequence; - Position : Big_Positive; - New_Item : Element_Type) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- except for the one at position Position which is replaced by New_Item. - - with - Global => null, - Pre => Position <= Last (Container), - Post => - Get (Set'Result, Position) = New_Item - and then Equal_Except (Container, Set'Result, Position); - - function Add (Container : Sequence; New_Item : Element_Type) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- plus New_Item at the end. - - with - Global => null, - Post => - Length (Add'Result) = Length (Container) + 1 - and then Get (Add'Result, Last (Add'Result)) = New_Item - and then Container <= Add'Result; - - function Add - (Container : Sequence; - Position : Big_Positive; - New_Item : Element_Type) return Sequence - with - -- Returns a new sequence which contains the same elements as Container - -- except that New_Item has been inserted at position Position. - - Global => null, - Pre => Position <= Last (Container) + 1, - Post => - Length (Add'Result) = Length (Container) + 1 - and then Get (Add'Result, Position) = New_Item - and then Range_Equal - (Left => Container, - Right => Add'Result, - Fst => 1, - Lst => Position - 1) - and then Range_Shifted - (Left => Container, - Right => Add'Result, - Fst => Position, - Lst => Last (Container), - Offset => 1); - - function Remove - (Container : Sequence; - Position : Big_Positive) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- except that the element at position Position has been removed. - - with - Global => null, - Pre => Position <= Last (Container), - Post => - Length (Remove'Result) = Length (Container) - 1 - and then Range_Equal - (Left => Container, - Right => Remove'Result, - Fst => 1, - Lst => Position - 1) - and then Range_Shifted - (Left => Remove'Result, - Right => Container, - Fst => Position, - Lst => Last (Remove'Result), - Offset => 1); - - function Copy_Element (Item : Element_Type) return Element_Type is (Item); - -- Elements of containers are copied by numerous primitives in this - -- package. This function causes GNATprove to verify that such a copy is - -- valid (in particular, it does not break the ownership policy of SPARK, - -- i.e. it does not contain pointers that could be used to alias mutable - -- data). - - function Empty_Sequence return Sequence with - -- Return an empty Sequence - - Global => null, - Post => Length (Empty_Sequence'Result) = 0; - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - function Iter_First (Container : Sequence) return Big_Integer with - Global => null, - Post => Iter_First'Result = 1; - - function Iter_Has_Element - (Container : Sequence; - Position : Big_Integer) return Boolean - with - Global => null, - Post => Iter_Has_Element'Result = - In_Range (Position, 1, Length (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element); - - function Iter_Next - (Container : Sequence; - Position : Big_Integer) return Big_Integer - with - Global => null, - Pre => Iter_Has_Element (Container, Position), - Post => Iter_Next'Result = Position + 1; - -private - pragma SPARK_Mode (Off); - - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package Containers is new Ada.Containers.Functional_Base - (Index_Type => Positive_Count_Type, - Element_Type => Element_Type); - - type Sequence is record - Content : Containers.Container; - end record; - - function Iter_First (Container : Sequence) return Big_Integer is (1); - - function Iter_Next - (Container : Sequence; - Position : Big_Integer) return Big_Integer - is - (Position + 1); - - function Iter_Has_Element - (Container : Sequence; - Position : Big_Integer) return Boolean - is - (In_Range (Position, 1, Length (Container))); end Ada.Containers.Functional_Infinite_Sequences; diff --git a/gcc/ada/libgnat/a-cfinve.adb b/gcc/ada/libgnat/a-cfinve.adb deleted file mode 100644 index a55786d95d0b..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 f44e45b81718..dcec6ba3cd5b 100644 --- a/gcc/ada/libgnat/a-cfinve.ads +++ b/gcc/ada/libgnat/a-cfinve.ads @@ -29,959 +29,12 @@ -- . -- ------------------------------------------------------------------------------ --- 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. +package Ada.Containers.Formal_Indefinite_Vectors with SPARK_Mode is - 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. - - 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 38d15e7bb091..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 7be2eec4ae78..21a5d78dfc8d 100644 --- a/gcc/ada/libgnat/a-cforma.ads +++ b/gcc/ada/libgnat/a-cforma.ads @@ -29,1124 +29,12 @@ -- . -- ------------------------------------------------------------------------------ --- 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; +package Ada.Containers.Formal_Ordered_Maps with SPARK_Mode is - 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; - - 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 e5cddde49852..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 f6cca0fe0528..fe5de2bff4ee 100644 --- a/gcc/ada/libgnat/a-cforse.ads +++ b/gcc/ada/libgnat/a-cforse.ads @@ -29,1786 +29,12 @@ -- . -- ------------------------------------------------------------------------------ --- 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; +package Ada.Containers.Formal_Ordered_Sets with SPARK_Mode is - 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, Find (Container, Key)'Old) = 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)'Old) - and P.Keys_Included (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; - - 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 c921184eb034..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 64133750f293..fb9301fe7f5c 100644 --- a/gcc/ada/libgnat/a-cofove.ads +++ b/gcc/ada/libgnat/a-cofove.ads @@ -29,954 +29,12 @@ -- . -- ------------------------------------------------------------------------------ --- 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 -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)); - - 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 68cf2ae58572..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 8a99a4338374..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- --- 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 f83b4d829f76..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 f863cdc979f5..9b4863af0bfc 100644 --- a/gcc/ada/libgnat/a-cofuma.ads +++ b/gcc/ada/libgnat/a-cofuma.ads @@ -29,368 +29,12 @@ -- . -- ------------------------------------------------------------------------------ -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; +package Ada.Containers.Functional_Maps with SPARK_Mode is - 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); - - 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 bbb3f7e96f9e..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 ce52f613f075..9c57ba193a49 100644 --- a/gcc/ada/libgnat/a-cofuse.ads +++ b/gcc/ada/libgnat/a-cofuse.ads @@ -29,308 +29,12 @@ -- . -- ------------------------------------------------------------------------------ -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; +package Ada.Containers.Functional_Sets with SPARK_Mode is - 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); - - 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 0d91da5015e8..000000000000 --- 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 -- --- . -- ------------------------------------------------------------------------------- - -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 86222217af5b..da0611e7d154 100644 --- a/gcc/ada/libgnat/a-cofuve.ads +++ b/gcc/ada/libgnat/a-cofuve.ads @@ -29,383 +29,12 @@ -- . -- ------------------------------------------------------------------------------ -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. +package Ada.Containers.Functional_Vectors with SPARK_Mode is - 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)); - - 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/testsuite/gnat.dg/aspect2.adb b/gcc/testsuite/gnat.dg/aspect2.adb deleted file mode 100644 index acf3329a3b4c..000000000000 --- a/gcc/testsuite/gnat.dg/aspect2.adb +++ /dev/null @@ -1,5 +0,0 @@ --- { dg-do compile } - -package body Aspect2 is - procedure Foo is null; -end Aspect2; diff --git a/gcc/testsuite/gnat.dg/aspect2.ads b/gcc/testsuite/gnat.dg/aspect2.ads deleted file mode 100644 index 73d3fe050748..000000000000 --- a/gcc/testsuite/gnat.dg/aspect2.ads +++ /dev/null @@ -1,30 +0,0 @@ -with Ada.Containers.Functional_Vectors; -with Ada.Containers; use Ada.Containers; - -generic - type Element_Type (<>) is private; - type Element_Model (<>) is private; - with function Model (X : Element_Type) return Element_Model is <>; - with function Copy (X : Element_Type) return Element_Type is <>; -package Aspect2 with SPARK_Mode is - pragma Unevaluated_Use_Of_Old (Allow); - - type Vector is private; - - function Length (V : Vector) return Natural; - - procedure Foo; - -private - type Element_Access is access Element_Type; - type Element_Array is array (Positive range <>) of Element_Access with - Dynamic_Predicate => Element_Array'First = 1; - type Element_Array_Access is access Element_Array; - type Vector is record - Top : Natural := 0; - Content : Element_Array_Access; - end record; - - function Length (V : Vector) return Natural is - (V.Top); -end Aspect2; diff --git a/gcc/testsuite/gnat.dg/config_pragma1.adb b/gcc/testsuite/gnat.dg/config_pragma1.adb deleted file mode 100644 index bae42d298ef4..000000000000 --- a/gcc/testsuite/gnat.dg/config_pragma1.adb +++ /dev/null @@ -1,21 +0,0 @@ --- { dg-do run } --- { dg-options "-gnata" } - -with Ada.Strings.Fixed; use Ada.Strings.Fixed; -with Config_Pragma1_Pkg; use Config_Pragma1_Pkg; - -procedure Config_Pragma1 is - Target : String10; - -begin - for I in Positive10 loop - Move - (Source => Positive10'Image(I), - Target => Target); - - FHM.Include - (Container => FHMM, - Key => Target, - New_Item => I); - end loop; -end Config_Pragma1; diff --git a/gcc/testsuite/gnat.dg/config_pragma1_pkg.ads b/gcc/testsuite/gnat.dg/config_pragma1_pkg.ads deleted file mode 100644 index 17150686b9c6..000000000000 --- a/gcc/testsuite/gnat.dg/config_pragma1_pkg.ads +++ /dev/null @@ -1,21 +0,0 @@ -pragma Assertion_Policy (Ignore); - -with Ada.Containers; use Ada.Containers; -with Ada.Containers.Formal_Hashed_Maps; -with Ada.Strings; use Ada.Strings; -with Ada.Strings.Hash; - -package Config_Pragma1_Pkg is - subtype Positive10 is Positive range 1 .. 1000; - subtype String10 is String (Positive10); - - package FHM is new Formal_Hashed_Maps - (Key_Type => String10, - Element_Type => Positive10, - Hash => Hash, - Equivalent_Keys => "="); - - FHMM : FHM.Map - (Capacity => 1_000_000, - Modulus => FHM.Default_Modulus (Count_Type (1_000_000))); -end Config_Pragma1_Pkg; diff --git a/gcc/testsuite/gnat.dg/equal8.adb b/gcc/testsuite/gnat.dg/equal8.adb deleted file mode 100644 index 9424abcb8bc8..000000000000 --- a/gcc/testsuite/gnat.dg/equal8.adb +++ /dev/null @@ -1,6 +0,0 @@ --- { dg-do compile } --- { dg-options "-gnata" } - -package body Equal8 is - procedure Foo is null; -end Equal8; diff --git a/gcc/testsuite/gnat.dg/equal8.ads b/gcc/testsuite/gnat.dg/equal8.ads deleted file mode 100644 index 9b6694d673af..000000000000 --- a/gcc/testsuite/gnat.dg/equal8.ads +++ /dev/null @@ -1,36 +0,0 @@ -with Ada.Containers.Formal_Hashed_Sets; -with Ada.Strings.Hash; - --- with Dynamic_Strings; use Dynamic_Strings; --- with Bounded_Dynamic_Strings; - -with Equal8_Pkg; - -package Equal8 is - - package Dynamic_Strings is - -- pragma SPARK_Mode (On); - - package Bounded_Dynamic_Strings is new Equal8_Pkg - (Component => Character, - List_Index => Positive, - List => String, - Default_Value => ' '); - type Dynamic_String is new Bounded_Dynamic_Strings.Sequence; - - end Dynamic_Strings; - use Dynamic_Strings; - - subtype Subscription_Address is Dynamic_String (Capacity => 255); - - function Hashed_Subscription_Address (Element : Subscription_Address) - return Ada.Containers.Hash_Type is - (Ada.Strings.Hash (Value (Element))); - - package Subscription_Addresses is new Ada.Containers.Formal_Hashed_Sets - (Element_Type => Subscription_Address, - Hash => Hashed_Subscription_Address, - Equivalent_Elements => "="); - - procedure Foo; -end Equal8; diff --git a/gcc/testsuite/gnat.dg/equal8_pkg.ads b/gcc/testsuite/gnat.dg/equal8_pkg.ads deleted file mode 100644 index b454a2c51743..000000000000 --- a/gcc/testsuite/gnat.dg/equal8_pkg.ads +++ /dev/null @@ -1,58 +0,0 @@ -generic - type Component is private; - type List_Index is range <>; - type List is array (List_Index range <>) of Component; - Default_Value : Component; - -- with function "=" (Left, Right : List) return Boolean is <>; - -package Equal8_Pkg is - - pragma Pure; - - Maximum_Length : constant List_Index := List_Index'Last; - - subtype Natural_Index is List_Index'Base range 0 .. Maximum_Length; - type Sequence (Capacity : Natural_Index) is private; - -- from zero to Capacity. - - function Value (This : Sequence) return List; - -- Returns the content of this sequence. The value returned is the - -- "logical" value in that only that slice which is currently assigned - -- is returned, as opposed to the entire physical representation. - - overriding - function "=" (Left, Right : Sequence) return Boolean with - Inline; - - function "=" (Left : Sequence; Right : List) return Boolean with - Inline; - -private - type Sequence (Capacity : Natural_Index) is record - Current_Length : Natural_Index := 0; - Content : List (1 .. Capacity) := (others => Default_Value); - end record; - - ----------- - -- Value -- - ----------- - - function Value (This : Sequence) return List is - (This.Content (1 .. This.Current_Length)); - - --------- - -- "=" -- - --------- - - overriding - function "=" (Left, Right : Sequence) return Boolean is - (Value (Left) = Value (Right)); - - --------- - -- "=" -- - --------- - - function "=" (Left : Sequence; Right : List) return Boolean is - (Value (Left) = Right); -end Equal8_Pkg; - diff --git a/gcc/testsuite/gnat.dg/formal_containers.adb b/gcc/testsuite/gnat.dg/formal_containers.adb deleted file mode 100644 index 185b946e71eb..000000000000 --- a/gcc/testsuite/gnat.dg/formal_containers.adb +++ /dev/null @@ -1,23 +0,0 @@ --- { dg-do compile } - -with Ada.Containers.Formal_Hashed_Sets; - -procedure Formal_Containers is - type T is new Integer; - - function Eq (X : T; Y : T) return Boolean; - - function Hash (X : T) return Ada.Containers.Hash_Type is (0); - - package TSet is new Ada.Containers.Formal_Hashed_Sets - (Element_Type => T, - Hash => Hash, - Equivalent_Elements => Eq); - - S : Tset.Set := TSet.Empty_Set; - - function Eq (X : T; Y : T) return Boolean is - begin - return TSet.Contains (S, X) or TSet.Contains (S, Y); - end Eq; -begin null; end Formal_Containers; diff --git a/gcc/testsuite/gnat.dg/iter1.adb b/gcc/testsuite/gnat.dg/iter1.adb deleted file mode 100644 index a0a69cf90181..000000000000 --- a/gcc/testsuite/gnat.dg/iter1.adb +++ /dev/null @@ -1,20 +0,0 @@ --- { dg-do compile } - -with Ada.Text_IO; - -package body Iter1 is - - type Table is array (Integer range <>) of Float; - My_Table : Table := (1.0, 2.0, 3.0); - - procedure Dummy (L : My_Lists.List) is - begin - for Item : Boolean of L loop -- { dg-error "subtype indication does not match element type" } - Ada.Text_IO.Put_Line (Integer'Image (Item)); - end loop; - - for Item : Boolean of My_Table loop -- { dg-error "subtype indication does not match component type" } - null; - end loop; - end; -end Iter1; diff --git a/gcc/testsuite/gnat.dg/iter1.ads b/gcc/testsuite/gnat.dg/iter1.ads deleted file mode 100644 index 8329f756fef4..000000000000 --- a/gcc/testsuite/gnat.dg/iter1.ads +++ /dev/null @@ -1,8 +0,0 @@ -with Ada.Containers.Formal_Doubly_Linked_Lists; - -package Iter1 is - package My_Lists is new Ada.Containers.Formal_Doubly_Linked_Lists - (Element_Type => Integer); - - procedure Dummy (L : My_Lists.List); -end Iter1;