The SPARK containers are now maintained under the spark2014 repository.
This change replaces the implementation of SPARK containers by a
pragma Compile_Time_Error, pointing the users WITHing the libraries
to their new location.
gcc/ada/
* Makefile.rtl: Remove SPARK containers filenames.
* impunit.adb: Remove SPARK containers packages names.
* libgnat/a-cfdlli.adb, libgnat/a-cfdlli.ads: Remove content and
add pragma Compile_Time_Error with suitable message.
* libgnat/a-cfhama.adb, libgnat/a-cfhama.ads: Likewise.
* libgnat/a-cfhase.adb, libgnat/a-cfhase.ads: Likewise.
* libgnat/a-cfidll.adb, libgnat/a-cfidll.ads: Likewise.
* libgnat/a-cfinse.adb, libgnat/a-cfinse.ads: Likewise.
* libgnat/a-cfinve.adb, libgnat/a-cfinve.ads: Likewise.
* libgnat/a-cforma.adb, libgnat/a-cforma.ads: Likewise.
* libgnat/a-cforse.adb, libgnat/a-cforse.ads: Likewise.
* libgnat/a-cofove.adb, libgnat/a-cofove.ads: Likewise.
* libgnat/a-cofuma.adb, libgnat/a-cofuma.ads: Likewise.
* libgnat/a-cofuse.adb, libgnat/a-cofuse.ads: Likewise.
* libgnat/a-cofuve.adb, libgnat/a-cofuve.ads: Likewise.
* libgnat/a-cofuba.adb, libgnat/a-cofuba.ads: Remove package.
gcc/testsuite/
* gnat.dg/aspect2.adb: Removed.
* gnat.dg/aspect2.ads: Removed.
* gnat.dg/config_pragma1.adb: Removed.
* gnat.dg/config_pragma1_pkg.ads: Removed.
* gnat.dg/equal8.adb: Removed.
* gnat.dg/equal8.ads: Removed.
* gnat.dg/equal8_pkg.ads: Removed.
* gnat.dg/formal_containers.adb: Removed.
* gnat.dg/iter1.adb: Removed.
* gnat.dg/iter1.ads: Removed.
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) \
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) \
-- 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
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting;
-
-with System; use type System.Address;
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
-package body Ada.Containers.Formal_Doubly_Linked_Lists with
- SPARK_Mode => Off
-is
- -- Convert Count_Type to Big_Interger
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
- use Conversions;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Allocate
- (Container : in out List;
- New_Item : Element_Type;
- New_Node : out Count_Type);
-
- procedure Free (Container : in out List; X : Count_Type);
-
- procedure Insert_Internal
- (Container : in out List;
- Before : Count_Type;
- New_Node : Count_Type);
-
- function Vet (L : List; Position : Cursor) return Boolean with Inline;
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : List; Right : List) return Boolean is
- LI : Count_Type;
- RI : Count_Type;
-
- begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
- if Left.Length /= Right.Length then
- return False;
- end if;
-
- LI := Left.First;
- RI := Right.First;
- while LI /= 0 loop
- if Left.Nodes (LI).Element /= Right.Nodes (RI).Element then
- return False;
- end if;
-
- LI := Left.Nodes (LI).Next;
- RI := Right.Nodes (RI).Next;
- end loop;
-
- return True;
- end "=";
-
- --------------
- -- Allocate --
- --------------
-
- procedure Allocate
- (Container : in out List;
- New_Item : Element_Type;
- New_Node : out Count_Type)
- is
- N : Node_Array renames Container.Nodes;
-
- begin
- if Container.Free >= 0 then
- New_Node := Container.Free;
- N (New_Node).Element := New_Item;
- Container.Free := N (New_Node).Next;
-
- else
- New_Node := abs Container.Free;
- N (New_Node).Element := New_Item;
- Container.Free := Container.Free - 1;
- end if;
- end Allocate;
-
- ------------
- -- Append --
- ------------
-
- procedure Append (Container : in out List; New_Item : Element_Type) is
- begin
- Insert (Container, No_Element, New_Item, 1);
- end Append;
-
- procedure Append
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, No_Element, New_Item, Count);
- end Append;
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out List; Source : List) is
- N : Node_Array renames Source.Nodes;
- J : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Source.Length then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- J := Source.First;
- while J /= 0 loop
- Append (Target, N (J).Element, 1);
- J := N (J).Next;
- end loop;
- end Assign;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out List) is
- N : Node_Array renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Container.Length = 0 then
- pragma Assert (Container.First = 0);
- pragma Assert (Container.Last = 0);
- return;
- end if;
-
- pragma Assert (Container.First >= 1);
- pragma Assert (Container.Last >= 1);
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- while Container.Length > 1 loop
- X := Container.First;
-
- Container.First := N (X).Next;
- N (Container.First).Prev := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
-
- X := Container.First;
-
- Container.First := 0;
- Container.Last := 0;
- Container.Length := 0;
-
- Free (Container, X);
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased List;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container => Container, Position => Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : List;
- Item : Element_Type) return Boolean
- is
- begin
- return Find (Container, Item) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy
- (Source : List;
- Capacity : Count_Type := 0) return List
- is
- C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity);
- N : Count_Type;
- P : List (C);
-
- begin
- if 0 < Capacity and then Capacity < Source.Capacity then
- raise Capacity_Error;
- end if;
-
- N := 1;
- while N <= Source.Capacity loop
- P.Nodes (N).Prev := Source.Nodes (N).Prev;
- P.Nodes (N).Next := Source.Nodes (N).Next;
- P.Nodes (N).Element := Source.Nodes (N).Element;
- N := N + 1;
- end loop;
-
- P.Free := Source.Free;
- P.Length := Source.Length;
- P.First := Source.First;
- P.Last := Source.Last;
-
- if P.Free >= 0 then
- N := Source.Capacity + 1;
- while N <= C loop
- Free (P, N);
- N := N + 1;
- end loop;
- end if;
-
- return P;
- end Copy;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out List; Position : in out Cursor) is
- begin
- Delete
- (Container => Container,
- Position => Position,
- Count => 1);
- end Delete;
-
- procedure Delete
- (Container : in out List;
- Position : in out Cursor;
- Count : Count_Type)
- is
- N : Node_Array renames Container.Nodes;
- X : Count_Type;
-
- begin
- if not Has_Element (Container => Container,
- Position => Position)
- then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in Delete");
- pragma Assert (Container.First >= 1);
- pragma Assert (Container.Last >= 1);
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- if Position.Node = Container.First then
- Delete_First (Container, Count);
- Position := No_Element;
- return;
- end if;
-
- if Count = 0 then
- Position := No_Element;
- return;
- end if;
-
- for Index in 1 .. Count loop
- pragma Assert (Container.Length >= 2);
-
- X := Position.Node;
- Container.Length := Container.Length - 1;
-
- if X = Container.Last then
- Position := No_Element;
-
- Container.Last := N (X).Prev;
- N (Container.Last).Next := 0;
-
- Free (Container, X);
- return;
- end if;
-
- Position.Node := N (X).Next;
- pragma Assert (N (Position.Node).Prev >= 0);
-
- N (N (X).Next).Prev := N (X).Prev;
- N (N (X).Prev).Next := N (X).Next;
-
- Free (Container, X);
- end loop;
-
- Position := No_Element;
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out List) is
- begin
- Delete_First
- (Container => Container,
- Count => 1);
- end Delete_First;
-
- procedure Delete_First (Container : in out List; Count : Count_Type) is
- N : Node_Array renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Count >= Container.Length then
- Clear (Container);
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- for J in 1 .. Count loop
- X := Container.First;
- pragma Assert (N (N (X).Next).Prev = Container.First);
-
- Container.First := N (X).Next;
- N (Container.First).Prev := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out List) is
- begin
- Delete_Last
- (Container => Container,
- Count => 1);
- end Delete_Last;
-
- procedure Delete_Last (Container : in out List; Count : Count_Type) is
- N : Node_Array renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Count >= Container.Length then
- Clear (Container);
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- for J in 1 .. Count loop
- X := Container.Last;
- pragma Assert (N (N (X).Prev).Next = Container.Last);
-
- Container.Last := N (X).Prev;
- N (Container.Last).Next := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
- end Delete_Last;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : List;
- Position : Cursor) return Element_Type
- is
- begin
- if not Has_Element (Container => Container, Position => Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element;
- end Element;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- is
- From : Count_Type := Position.Node;
-
- begin
- if From = 0 and Container.Length = 0 then
- return No_Element;
- end if;
-
- if From = 0 then
- From := Container.First;
- end if;
-
- if Position.Node /= 0 and then not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- while From /= 0 loop
- if Container.Nodes (From).Element = Item then
- return (Node => From);
- end if;
-
- From := Container.Nodes (From).Next;
- end loop;
-
- return No_Element;
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : List) return Cursor is
- begin
- if Container.First = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.First);
- end First;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : List) return Element_Type is
- F : constant Count_Type := Container.First;
-
- begin
- if F = 0 then
- raise Constraint_Error with "list is empty";
- else
- return Container.Nodes (F).Element;
- end if;
- end First_Element;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : List) is null;
-
- -------------------------
- -- M_Elements_In_Union --
- -------------------------
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- Elem : Element_Type;
-
- begin
- for Index in 1 .. M.Length (Container) loop
- Elem := Element (Container, Index);
-
- if not M.Contains (Left, 1, M.Length (Left), Elem)
- and then not M.Contains (Right, 1, M.Length (Right), Elem)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_In_Union;
-
- -------------------------
- -- M_Elements_Included --
- -------------------------
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Positive_Count_Type := 1;
- L_Lst : Count_Type;
- Right : M.Sequence;
- R_Fst : Positive_Count_Type := 1;
- R_Lst : Count_Type) return Boolean
- is
- begin
- for I in L_Fst .. L_Lst loop
- declare
- Found : Boolean := False;
- J : Count_Type := R_Fst - 1;
-
- begin
- while not Found and J < R_Lst loop
- J := J + 1;
- if Element (Left, I) = Element (Right, J) then
- Found := True;
- end if;
- end loop;
-
- if not Found then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end M_Elements_Included;
-
- -------------------------
- -- M_Elements_Reversed --
- -------------------------
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- L : constant Count_Type := M.Length (Left);
-
- begin
- if L /= M.Length (Right) then
- return False;
- end if;
-
- for I in 1 .. L loop
- if Element (Left, I) /= Element (Right, L - I + 1) then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Reversed;
-
- ------------------------
- -- M_Elements_Swapped --
- ------------------------
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Positive_Count_Type;
- Y : Positive_Count_Type) return Boolean
- is
- begin
- if M.Length (Left) /= M.Length (Right)
- or else Element (Left, X) /= Element (Right, Y)
- or else Element (Left, Y) /= Element (Right, X)
- then
- return False;
- end if;
-
- for I in 1 .. M.Length (Left) loop
- if I /= X and then I /= Y
- and then Element (Left, I) /= Element (Right, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Swapped;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : List) return M.Sequence is
- Position : Count_Type := Container.First;
- R : M.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := M.Add (R, Container.Nodes (Position).Element);
- Position := Container.Nodes (Position).Next;
- end loop;
-
- return R;
- end Model;
-
- -----------------------
- -- Mapping_Preserved --
- -----------------------
-
- function Mapping_Preserved
- (M_Left : M.Sequence;
- M_Right : M.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- is
- begin
- for C of P_Left loop
- if not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > M.Length (M_Left)
- or else P.Get (P_Right, C) > M.Length (M_Right)
- or else M.Get (M_Left, P.Get (P_Left, C)) /=
- M.Get (M_Right, P.Get (P_Right, C))
- then
- return False;
- end if;
- end loop;
-
- for C of P_Right loop
- if not P.Has_Key (P_Left, C) then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved;
-
- -------------------------
- -- P_Positions_Shifted --
- -------------------------
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu) + Count
- then
- return False;
- end if;
-
- else
- if P.Has_Key (Small, Cu) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Shifted;
-
- -------------------------
- -- P_Positions_Swapped --
- -------------------------
-
- function P_Positions_Swapped
- (Left : P.Map;
- Right : P.Map;
- X : Cursor;
- Y : Cursor) return Boolean
- is
- begin
- if not P.Has_Key (Left, X)
- or not P.Has_Key (Left, Y)
- or not P.Has_Key (Right, X)
- or not P.Has_Key (Right, Y)
- then
- return False;
- end if;
-
- if P.Get (Left, X) /= P.Get (Right, Y)
- or P.Get (Left, Y) /= P.Get (Right, X)
- then
- return False;
- end if;
-
- for C of Left loop
- if not P.Has_Key (Right, C) then
- return False;
- end if;
- end loop;
-
- for C of Right loop
- if not P.Has_Key (Left, C)
- or else (C /= X
- and C /= Y
- and P.Get (Left, C) /= P.Get (Right, C))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end P_Positions_Swapped;
-
- ---------------------------
- -- P_Positions_Truncated --
- ---------------------------
-
- function P_Positions_Truncated
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- return False;
-
- elsif P.Has_Key (Small, Cu) then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Truncated;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : List) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := Container.First;
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = To_Big_Integer (I));
- Position := Container.Nodes (Position).Next;
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Container : in out List; X : Count_Type) is
- pragma Assert (X > 0);
- pragma Assert (X <= Container.Capacity);
-
- N : Node_Array renames Container.Nodes;
-
- begin
- N (X).Prev := -1; -- Node is deallocated (not on active list)
-
- if Container.Free >= 0 then
- N (X).Next := Container.Free;
- Container.Free := X;
-
- elsif X + 1 = abs Container.Free then
- N (X).Next := 0; -- Not strictly necessary, but marginally safer
- Container.Free := Container.Free + 1;
-
- else
- Container.Free := abs Container.Free;
-
- if Container.Free > Container.Capacity then
- Container.Free := 0;
-
- else
- for J in Container.Free .. Container.Capacity - 1 loop
- N (J).Next := J + 1;
- end loop;
-
- N (Container.Capacity).Next := 0;
- end if;
-
- N (X).Next := Container.Free;
- Container.Free := X;
- end if;
- end Free;
-
- ---------------------
- -- Generic_Sorting --
- ---------------------
-
- package body Generic_Sorting with SPARK_Mode => Off is
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -----------------------
- -- M_Elements_Sorted --
- -----------------------
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean is
- begin
- if M.Length (Container) = 0 then
- return True;
- end if;
-
- declare
- E1 : Element_Type := Element (Container, 1);
-
- begin
- for I in 2 .. M.Length (Container) loop
- declare
- E2 : constant Element_Type := Element (Container, I);
-
- begin
- if E2 < E1 then
- return False;
- end if;
-
- E1 := E2;
- end;
- end loop;
- end;
-
- return True;
- end M_Elements_Sorted;
-
- end Formal_Model;
-
- ---------------
- -- Is_Sorted --
- ---------------
-
- function Is_Sorted (Container : List) return Boolean is
- Nodes : Node_Array renames Container.Nodes;
- Node : Count_Type := Container.First;
-
- begin
- for J in 2 .. Container.Length loop
- if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
- return False;
- else
- Node := Nodes (Node).Next;
- end if;
- end loop;
-
- return True;
- end Is_Sorted;
-
- -----------
- -- Merge --
- -----------
-
- procedure Merge (Target : in out List; Source : in out List) is
- LN : Node_Array renames Target.Nodes;
- RN : Node_Array renames Source.Nodes;
- LI : Cursor;
- RI : Cursor;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- LI := First (Target);
- RI := First (Source);
- while RI.Node /= 0 loop
- pragma Assert
- (RN (RI.Node).Next = 0
- or else not (RN (RN (RI.Node).Next).Element <
- RN (RI.Node).Element));
-
- if LI.Node = 0 then
- Splice (Target, No_Element, Source);
- return;
- end if;
-
- pragma Assert
- (LN (LI.Node).Next = 0
- or else not (LN (LN (LI.Node).Next).Element <
- LN (LI.Node).Element));
-
- if RN (RI.Node).Element < LN (LI.Node).Element then
- declare
- RJ : Cursor := RI;
- pragma Warnings (Off, RJ);
- begin
- RI.Node := RN (RI.Node).Next;
- Splice (Target, LI, Source, RJ);
- end;
-
- else
- LI.Node := LN (LI.Node).Next;
- end if;
- end loop;
- end Merge;
-
- ----------
- -- Sort --
- ----------
-
- procedure Sort (Container : in out List) is
- N : Node_Array renames Container.Nodes;
- begin
- if Container.Length <= 1 then
- return;
- end if;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- declare
- package Descriptors is new List_Descriptors
- (Node_Ref => Count_Type, Nil => 0);
- use Descriptors;
-
- function Next (Idx : Count_Type) return Count_Type is
- (N (Idx).Next);
- procedure Set_Next (Idx : Count_Type; Next : Count_Type)
- with Inline;
- procedure Set_Prev (Idx : Count_Type; Prev : Count_Type)
- with Inline;
- function "<" (L, R : Count_Type) return Boolean is
- (N (L).Element < N (R).Element);
- procedure Update_Container (List : List_Descriptor) with Inline;
-
- procedure Set_Next (Idx : Count_Type; Next : Count_Type) is
- begin
- N (Idx).Next := Next;
- end Set_Next;
-
- procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is
- begin
- N (Idx).Prev := Prev;
- end Set_Prev;
-
- procedure Update_Container (List : List_Descriptor) is
- begin
- Container.First := List.First;
- Container.Last := List.Last;
- Container.Length := List.Length;
- end Update_Container;
-
- procedure Sort_List is new Doubly_Linked_List_Sort;
- begin
- Sort_List (List_Descriptor'(First => Container.First,
- Last => Container.Last,
- Length => Container.Length));
- end;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Sort;
-
- end Generic_Sorting;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : List; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0 then
- return False;
- end if;
-
- return Container.Nodes (Position.Node).Prev /= -1;
- end Has_Element;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor;
- Count : Count_Type)
- is
- J : Count_Type;
-
- begin
- if Before.Node /= 0 then
- pragma Assert (Vet (Container, Before), "bad cursor in Insert");
- end if;
-
- if Count = 0 then
- Position := Before;
- return;
- end if;
-
- if Container.Length > Container.Capacity - Count then
- raise Constraint_Error with "new length exceeds capacity";
- end if;
-
- Allocate (Container, New_Item, New_Node => J);
- Insert_Internal (Container, Before.Node, New_Node => J);
- Position := (Node => J);
-
- for Index in 2 .. Count loop
- Allocate (Container, New_Item, New_Node => J);
- Insert_Internal (Container, Before.Node, New_Node => J);
- end loop;
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor)
- is
- begin
- Insert
- (Container => Container,
- Before => Before,
- New_Item => New_Item,
- Position => Position,
- Count => 1);
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- Position : Cursor;
-
- begin
- Insert (Container, Before, New_Item, Position, Count);
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type)
- is
- Position : Cursor;
-
- begin
- Insert (Container, Before, New_Item, Position, 1);
- end Insert;
-
- ---------------------
- -- Insert_Internal --
- ---------------------
-
- procedure Insert_Internal
- (Container : in out List;
- Before : Count_Type;
- New_Node : Count_Type)
- is
- N : Node_Array renames Container.Nodes;
-
- begin
- if Container.Length = 0 then
- pragma Assert (Before = 0);
- pragma Assert (Container.First = 0);
- pragma Assert (Container.Last = 0);
-
- Container.First := New_Node;
- Container.Last := New_Node;
-
- N (Container.First).Prev := 0;
- N (Container.Last).Next := 0;
-
- elsif Before = 0 then
- pragma Assert (N (Container.Last).Next = 0);
-
- N (Container.Last).Next := New_Node;
- N (New_Node).Prev := Container.Last;
-
- Container.Last := New_Node;
- N (Container.Last).Next := 0;
-
- elsif Before = Container.First then
- pragma Assert (N (Container.First).Prev = 0);
-
- N (Container.First).Prev := New_Node;
- N (New_Node).Next := Container.First;
-
- Container.First := New_Node;
- N (Container.First).Prev := 0;
-
- else
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- N (New_Node).Next := Before;
- N (New_Node).Prev := N (Before).Prev;
-
- N (N (Before).Prev).Next := New_Node;
- N (Before).Prev := New_Node;
- end if;
-
- Container.Length := Container.Length + 1;
- end Insert_Internal;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : List) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : List) return Cursor is
- begin
- if Container.Last = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.Last);
- end Last;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : List) return Element_Type is
- L : constant Count_Type := Container.Last;
-
- begin
- if L = 0 then
- raise Constraint_Error with "list is empty";
- else
- return Container.Nodes (L).Element;
- end if;
- end Last_Element;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : List) return Count_Type is
- begin
- return Container.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out List; Source : in out List) is
- N : Node_Array renames Source.Nodes;
- X : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Source.Length then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- while Source.Length > 1 loop
- pragma Assert (Source.First in 1 .. Source.Capacity);
- pragma Assert (Source.Last /= Source.First);
- pragma Assert (N (Source.First).Prev = 0);
- pragma Assert (N (Source.Last).Next = 0);
-
- -- Copy first element from Source to Target
-
- X := Source.First;
- Append (Target, N (X).Element); -- optimize away???
-
- -- Unlink first node of Source
-
- Source.First := N (X).Next;
- N (Source.First).Prev := 0;
-
- Source.Length := Source.Length - 1;
-
- -- The representation invariants for Source have been restored. It is
- -- now safe to free the unlinked node, without fear of corrupting the
- -- active links of Source.
-
- -- Note that the algorithm we use here models similar algorithms used
- -- in the unbounded form of the doubly-linked list container. In that
- -- case, Free is an instantation of Unchecked_Deallocation, which can
- -- fail (because PE will be raised if controlled Finalize fails), so
- -- we must defer the call until the last step. Here in the bounded
- -- form, Free merely links the node we have just "deallocated" onto a
- -- list of inactive nodes, so technically Free cannot fail. However,
- -- for consistency, we handle Free the same way here as we do for the
- -- unbounded form, with the pessimistic assumption that it can fail.
-
- Free (Source, X);
- end loop;
-
- if Source.Length = 1 then
- pragma Assert (Source.First in 1 .. Source.Capacity);
- pragma Assert (Source.Last = Source.First);
- pragma Assert (N (Source.First).Prev = 0);
- pragma Assert (N (Source.Last).Next = 0);
-
- -- Copy element from Source to Target
-
- X := Source.First;
- Append (Target, N (X).Element);
-
- -- Unlink node of Source
-
- Source.First := 0;
- Source.Last := 0;
- Source.Length := 0;
-
- -- Return the unlinked node to the free store
-
- Free (Source, X);
- end if;
- end Move;
-
- ----------
- -- Next --
- ----------
-
- procedure Next (Container : List; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- function Next (Container : List; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Program_Error with "Position cursor has no element";
- end if;
-
- return (Node => Container.Nodes (Position.Node).Next);
- end Next;
-
- -------------
- -- Prepend --
- -------------
-
- procedure Prepend (Container : in out List; New_Item : Element_Type) is
- begin
- Insert (Container, First (Container), New_Item, 1);
- end Prepend;
-
- procedure Prepend
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, First (Container), New_Item, Count);
- end Prepend;
-
- --------------
- -- Previous --
- --------------
-
- procedure Previous (Container : List; Position : in out Cursor) is
- begin
- Position := Previous (Container, Position);
- end Previous;
-
- function Previous (Container : List; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Program_Error with "Position cursor has no element";
- end if;
-
- return (Node => Container.Nodes (Position.Node).Prev);
- end Previous;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference
- (Container : not null access List;
- Position : Cursor) return not null access Element_Type
- is
- begin
- if not Has_Element (Container.all, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element'Access;
- end Reference;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out List;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in Replace_Element");
-
- Container.Nodes (Position.Node).Element := New_Item;
- end Replace_Element;
-
- ----------------------
- -- Reverse_Elements --
- ----------------------
-
- procedure Reverse_Elements (Container : in out List) is
- N : Node_Array renames Container.Nodes;
- I : Count_Type := Container.First;
- J : Count_Type := Container.Last;
-
- procedure Swap (L : Count_Type; R : Count_Type);
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap (L : Count_Type; R : Count_Type) is
- LN : constant Count_Type := N (L).Next;
- LP : constant Count_Type := N (L).Prev;
-
- RN : constant Count_Type := N (R).Next;
- RP : constant Count_Type := N (R).Prev;
-
- begin
- if LP /= 0 then
- N (LP).Next := R;
- end if;
-
- if RN /= 0 then
- N (RN).Prev := L;
- end if;
-
- N (L).Next := RN;
- N (R).Prev := LP;
-
- if LN = R then
- pragma Assert (RP = L);
-
- N (L).Prev := R;
- N (R).Next := L;
-
- else
- N (L).Prev := RP;
- N (RP).Next := L;
-
- N (R).Next := LN;
- N (LN).Prev := R;
- end if;
- end Swap;
-
- -- Start of processing for Reverse_Elements
-
- begin
- if Container.Length <= 1 then
- return;
- end if;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- Container.First := J;
- Container.Last := I;
- loop
- Swap (L => I, R => J);
-
- J := N (J).Next;
- exit when I = J;
-
- I := N (I).Prev;
- exit when I = J;
-
- Swap (L => J, R => I);
-
- I := N (I).Next;
- exit when I = J;
-
- J := N (J).Prev;
- exit when I = J;
- end loop;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Reverse_Elements;
-
- ------------------
- -- Reverse_Find --
- ------------------
-
- function Reverse_Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- is
- CFirst : Count_Type := Position.Node;
-
- begin
- if CFirst = 0 then
- CFirst := Container.Last;
- end if;
-
- if Container.Length = 0 then
- return No_Element;
-
- else
- while CFirst /= 0 loop
- if Container.Nodes (CFirst).Element = Item then
- return (Node => CFirst);
- else
- CFirst := Container.Nodes (CFirst).Prev;
- end if;
- end loop;
-
- return No_Element;
- end if;
- end Reverse_Find;
-
- ------------
- -- Splice --
- ------------
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List)
- is
- SN : Node_Array renames Source.Nodes;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Before.Node /= 0 then
- pragma Assert (Vet (Target, Before), "bad cursor in Splice");
- end if;
-
- pragma Assert (SN (Source.First).Prev = 0);
- pragma Assert (SN (Source.Last).Next = 0);
-
- if Target.Length > Count_Type'Base'Last - Source.Length then
- raise Constraint_Error with "new length exceeds maximum";
- end if;
-
- if Target.Length + Source.Length > Target.Capacity then
- raise Constraint_Error;
- end if;
-
- loop
- Insert (Target, Before, SN (Source.Last).Element);
- Delete_Last (Source);
- exit when Is_Empty (Source);
- end loop;
- end Splice;
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List;
- Position : in out Cursor)
- is
- Target_Position : Cursor;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Position.Node = 0 then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Source, Position), "bad Position cursor in Splice");
-
- if Target.Length >= Target.Capacity then
- raise Constraint_Error;
- end if;
-
- Insert
- (Container => Target,
- Before => Before,
- New_Item => Source.Nodes (Position.Node).Element,
- Position => Target_Position);
-
- Delete (Source, Position);
- Position := Target_Position;
- end Splice;
-
- procedure Splice
- (Container : in out List;
- Before : Cursor;
- Position : Cursor)
- is
- N : Node_Array renames Container.Nodes;
-
- begin
- if Before.Node /= 0 then
- pragma Assert
- (Vet (Container, Before), "bad Before cursor in Splice");
- end if;
-
- if Position.Node = 0 then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad Position cursor in Splice");
-
- if Position.Node = Before.Node
- or else N (Position.Node).Next = Before.Node
- then
- return;
- end if;
-
- pragma Assert (Container.Length >= 2);
-
- if Before.Node = 0 then
- pragma Assert (Position.Node /= Container.Last);
-
- if Position.Node = Container.First then
- Container.First := N (Position.Node).Next;
- N (Container.First).Prev := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (Container.Last).Next := Position.Node;
- N (Position.Node).Prev := Container.Last;
-
- Container.Last := Position.Node;
- N (Container.Last).Next := 0;
-
- return;
- end if;
-
- if Before.Node = Container.First then
- pragma Assert (Position.Node /= Container.First);
-
- if Position.Node = Container.Last then
- Container.Last := N (Position.Node).Prev;
- N (Container.Last).Next := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (Container.First).Prev := Position.Node;
- N (Position.Node).Next := Container.First;
-
- Container.First := Position.Node;
- N (Container.First).Prev := 0;
-
- return;
- end if;
-
- if Position.Node = Container.First then
- Container.First := N (Position.Node).Next;
- N (Container.First).Prev := 0;
-
- elsif Position.Node = Container.Last then
- Container.Last := N (Position.Node).Prev;
- N (Container.Last).Next := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (N (Before.Node).Prev).Next := Position.Node;
- N (Position.Node).Prev := N (Before.Node).Prev;
-
- N (Before.Node).Prev := Position.Node;
- N (Position.Node).Next := Before.Node;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Splice;
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- is
- begin
- if I.Node = 0 then
- raise Constraint_Error with "I cursor has no element";
- end if;
-
- if J.Node = 0 then
- raise Constraint_Error with "J cursor has no element";
- end if;
-
- if I.Node = J.Node then
- return;
- end if;
-
- pragma Assert (Vet (Container, I), "bad I cursor in Swap");
- pragma Assert (Vet (Container, J), "bad J cursor in Swap");
-
- declare
- NN : Node_Array renames Container.Nodes;
- NI : Node_Type renames NN (I.Node);
- NJ : Node_Type renames NN (J.Node);
-
- EI_Copy : constant Element_Type := NI.Element;
-
- begin
- NI.Element := NJ.Element;
- NJ.Element := EI_Copy;
- end;
- end Swap;
-
- ----------------
- -- Swap_Links --
- ----------------
-
- procedure Swap_Links
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- is
- I_Next : Cursor;
- J_Next : Cursor;
-
- begin
- if I.Node = 0 then
- raise Constraint_Error with "I cursor has no element";
- end if;
-
- if J.Node = 0 then
- raise Constraint_Error with "J cursor has no element";
- end if;
-
- if I.Node = J.Node then
- return;
- end if;
-
- pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links");
- pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links");
-
- I_Next := Next (Container, I);
-
- if I_Next = J then
- Splice (Container, Before => I, Position => J);
-
- else
- J_Next := Next (Container, J);
-
- if J_Next = I then
- Splice (Container, Before => J, Position => I);
-
- else
- pragma Assert (Container.Length >= 3);
- Splice (Container, Before => I_Next, Position => J);
- Splice (Container, Before => J_Next, Position => I);
- end if;
- end if;
- end Swap_Links;
-
- ---------
- -- Vet --
- ---------
-
- function Vet (L : List; Position : Cursor) return Boolean is
- N : Node_Array renames L.Nodes;
- begin
- if not Container_Checks'Enabled then
- return True;
- end if;
-
- if L.Length = 0 then
- return False;
- end if;
-
- if L.First = 0 then
- return False;
- end if;
-
- if L.Last = 0 then
- return False;
- end if;
-
- if Position.Node > L.Capacity then
- return False;
- end if;
-
- if N (Position.Node).Prev < 0
- or else N (Position.Node).Prev > L.Capacity
- then
- return False;
- end if;
-
- if N (Position.Node).Next > L.Capacity then
- return False;
- end if;
-
- if N (L.First).Prev /= 0 then
- return False;
- end if;
-
- if N (L.Last).Next /= 0 then
- return False;
- end if;
-
- if N (Position.Node).Prev = 0 and then Position.Node /= L.First then
- return False;
- end if;
-
- if N (Position.Node).Next = 0 and then Position.Node /= L.Last then
- return False;
- end if;
-
- if L.Length = 1 then
- return L.First = L.Last;
- end if;
-
- if L.First = L.Last then
- return False;
- end if;
-
- if N (L.First).Next = 0 then
- return False;
- end if;
-
- if N (L.Last).Prev = 0 then
- return False;
- end if;
-
- if N (N (L.First).Next).Prev /= L.First then
- return False;
- end if;
-
- if N (N (L.Last).Prev).Next /= L.Last then
- return False;
- end if;
-
- if L.Length = 2 then
- if N (L.First).Next /= L.Last then
- return False;
- end if;
-
- if N (L.Last).Prev /= L.First then
- return False;
- end if;
-
- return True;
- end if;
-
- if N (L.First).Next = L.Last then
- return False;
- end if;
-
- if N (L.Last).Prev = L.First then
- return False;
- end if;
-
- if Position.Node = L.First then
- return True;
- end if;
-
- if Position.Node = L.Last then
- return True;
- end if;
-
- if N (Position.Node).Next = 0 then
- return False;
- end if;
-
- if N (Position.Node).Prev = 0 then
- return False;
- end if;
-
- if N (N (Position.Node).Next).Prev /= Position.Node then
- return False;
- end if;
-
- if N (N (Position.Node).Prev).Next /= Position.Node then
- return False;
- end if;
-
- if L.Length = 3 then
- if N (L.First).Next /= Position.Node then
- return False;
- end if;
-
- if N (L.Last).Prev /= Position.Node then
- return False;
- end if;
- end if;
-
- return True;
- end Vet;
-
-end Ada.Containers.Formal_Doubly_Linked_Lists;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-with Ada.Containers.Functional_Vectors;
-with Ada.Containers.Functional_Maps;
-
generic
- type Element_Type is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Doubly_Linked_Lists with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- type List (Capacity : Count_Type) is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Element),
- Default_Initial_Condition => Is_Empty (List);
- pragma Preelaborable_Initialization (List);
-
- type Cursor is record
- Node : Count_Type := 0;
- end record;
-
- No_Element : constant Cursor := Cursor'(Node => 0);
-
- Empty_List : constant List;
-
- function Length (Container : List) return Count_Type with
- Global => null,
- Post => Length'Result <= Container.Capacity;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Vectors
- (Index_Type => Positive_Count_Type,
- Element_Type => Element_Type);
-
- function "="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."=";
-
- function "<"
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<";
-
- function "<="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<=";
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- The elements of Container are contained in either Left or Right
- with
- Global => null,
- Post =>
- M_Elements_In_Union'Result =
- (for all I in 1 .. M.Length (Container) =>
- (for some J in 1 .. M.Length (Left) =>
- Element (Container, I) = Element (Left, J))
- or (for some J in 1 .. M.Length (Right) =>
- Element (Container, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union);
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Positive_Count_Type := 1;
- L_Lst : Count_Type;
- Right : M.Sequence;
- R_Fst : Positive_Count_Type := 1;
- R_Lst : Count_Type) return Boolean
- -- The elements of the slice from L_Fst to L_Lst in Left are contained
- -- in the slide from R_Fst to R_Lst in Right.
- with
- Global => null,
- Pre => L_Lst <= M.Length (Left) and R_Lst <= M.Length (Right),
- Post =>
- M_Elements_Included'Result =
- (for all I in L_Fst .. L_Lst =>
- (for some J in R_Fst .. R_Lst =>
- Element (Left, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included);
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- Right is Left in reverse order
- with
- Global => null,
- Post =>
- M_Elements_Reversed'Result =
- (M.Length (Left) = M.Length (Right)
- and (for all I in 1 .. M.Length (Left) =>
- Element (Left, I) =
- Element (Right, M.Length (Left) - I + 1))
- and (for all I in 1 .. M.Length (Left) =>
- Element (Right, I) =
- Element (Left, M.Length (Left) - I + 1)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed);
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Positive_Count_Type;
- Y : Positive_Count_Type) return Boolean
- -- Elements stored at X and Y are reversed in Left and Right
- with
- Global => null,
- Pre => X <= M.Length (Left) and Y <= M.Length (Left),
- Post =>
- M_Elements_Swapped'Result =
- (M.Length (Left) = M.Length (Right)
- and Element (Left, X) = Element (Right, Y)
- and Element (Left, Y) = Element (Right, X)
- and M.Equal_Except (Left, Right, X, Y));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped);
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Global => null,
- Post =>
- P_Positions_Shifted'Result =
-
- -- Big contains all cursors of Small
-
- (P.Keys_Included (Small, Big)
-
- -- Cursors located before Cut are not moved, cursors located
- -- after are shifted by Count.
-
- and (for all I of Small =>
- (if P.Get (Small, I) < Cut then
- P.Get (Big, I) = P.Get (Small, I)
- else
- P.Get (Big, I) - Count = P.Get (Small, I)))
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function P_Positions_Swapped
- (Left : P.Map;
- Right : P.Map;
- X : Cursor;
- Y : Cursor) return Boolean
- -- Left and Right contain the same cursors, but the positions of X and Y
- -- are reversed.
- with
- Ghost,
- Global => null,
- Post =>
- P_Positions_Swapped'Result =
- (P.Same_Keys (Left, Right)
- and P.Elements_Equal_Except (Left, Right, X, Y)
- and P.Has_Key (Left, X)
- and P.Has_Key (Left, Y)
- and P.Get (Left, X) = P.Get (Right, Y)
- and P.Get (Left, Y) = P.Get (Right, X));
-
- function P_Positions_Truncated
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- P_Positions_Truncated'Result =
-
- -- Big contains all cursors of Small at the same position
-
- (Small <= Big
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function Mapping_Preserved
- (M_Left : M.Sequence;
- M_Right : M.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved'Result then
-
- -- Left and Right contain the same cursors
-
- P.Same_Keys (P_Left, P_Right)
-
- -- Mappings from cursors to elements induced by M_Left, P_Left
- -- and M_Right, P_Right are the same.
-
- and (for all C of P_Left =>
- M.Get (M_Left, P.Get (P_Left, C)) =
- M.Get (M_Right, P.Get (P_Right, C))));
-
- function Model (Container : List) return M.Sequence with
- -- The high-level model of a list is a sequence of elements. Cursors are
- -- not represented in this model.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Length (Container);
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model);
-
- function Positions (Container : List) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and map them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length.
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : List) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access to the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level cursor-aware view of a container to a high-level
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Elt of Model (Container) =>
- (for some I of Positions (Container) =>
- M.Get (Model (Container), P.Get (Positions (Container), I)) =
- Elt));
-
- function Element
- (S : M.Sequence;
- I : Count_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
-
- end Formal_Model;
- use Formal_Model;
-
- function "=" (Left, Right : List) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function Is_Empty (Container : List) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out List) with
- Global => null,
- Post => Length (Container) = 0;
-
- procedure Assign (Target : in out List; Source : List) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post => Model (Target) = Model (Source);
-
- function Copy (Source : List; Capacity : Count_Type := 0) return List with
- Global => null,
- Pre => Capacity = 0 or else Capacity >= Source.Capacity,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Positions (Copy'Result) = Positions (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Source.Capacity
- else
- Copy'Result.Capacity = Capacity);
-
- function Element
- (Container : List;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result =
- Element (Model (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out List;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Cursors are preserved
-
- and Positions (Container)'Old = Positions (Container)
-
- -- The element at the position of Position in Container is New_Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Position)) = New_Item
-
- -- Other elements are preserved
-
- and M.Equal_Except
- (Model (Container)'Old,
- Model (Container),
- P.Get (Positions (Container), Position));
-
- function At_End (E : access constant List) return access constant List
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : aliased List;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- Element (Model (Container), P.Get (Positions (Container), Position));
-
- function Reference
- (Container : not null access List;
- Position : Cursor) return not null access Element_Type
- with
- Global => null,
- Pre => Has_Element (Container.all, Position),
- Post =>
- Length (Container.all) = Length (At_End (Container).all)
-
- -- Cursors are preserved
-
- and Positions (Container.all) = Positions (At_End (Container).all)
-
- -- Container will have Result.all at position Position
-
- and At_End (Reference'Result).all =
- Element (Model (At_End (Container).all),
- P.Get (Positions (At_End (Container).all), Position))
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Model (Container.all),
- Model (At_End (Container).all),
- P.Get (Positions (At_End (Container).all), Position));
-
- procedure Move (Target : in out List; Source : in out List) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post => Model (Target) = Model (Source'Old) and Length (Source) = 0;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + 1,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- Positions contains a new mapping from the last cursor of
- -- Container to its length.
-
- P.Get (Positions (Container), Last (Container)) = Length (Container)
-
- -- Other cursors come from Container'Old
-
- and P.Keys_Included_Except
- (Left => Positions (Container),
- Right => Positions (Container)'Old,
- New_Key => Last (Container))
-
- -- Cursors of Container'Old keep the same position
-
- and Positions (Container)'Old <= Positions (Container)
-
- -- Model contains a new element New_Item at the end
-
- and Element (Model (Container), Length (Container)) = New_Item
-
- -- Elements of Container'Old are preserved
-
- and Model (Container)'Old <= Model (Container),
-
- others =>
-
- -- The elements of Container located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is stored at the previous position of Before in
- -- Container.
-
- and Element
- (Model (Container),
- P.Get (Positions (Container)'Old, Before)) = New_Item
-
- -- A new cursor has been inserted at position Before in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container)'Old, Before)));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Container.Capacity - Count
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + Count,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- The elements of Container are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old)
-
- -- Container contains Count times New_Item at the end
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Length (Container)'Old + 1,
- Lst => Length (Container),
- Item => New_Item))
-
- -- Count cursors have been inserted at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Length (Container)'Old + 1,
- Count => Count),
-
- others =>
-
- -- The elements of Container located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1)
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container contains Count times New_Item after position Before
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst =>
- P.Get (Positions (Container)'Old, Before) - 1 + Count,
- Item => New_Item)
-
- -- Count cursors have been inserted at position Before in
- -- Container.
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container)'Old, Before),
- Count => Count));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Positions is valid in Container and it is located either before
- -- Before if it is valid in Container or at the end if it is
- -- No_Element.
-
- and P.Has_Key (Positions (Container), Position)
- and (if Before = No_Element then
- P.Get (Positions (Container), Position) = Length (Container)
- else
- P.Get (Positions (Container), Position) =
- P.Get (Positions (Container)'Old, Before))
-
- -- The elements of Container located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is stored at Position in Container
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Position)) = New_Item
-
- -- A new cursor has been inserted at position Position in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Container.Capacity - Count
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + Count,
- Contract_Cases =>
- (Count = 0 =>
- Position = Before
- and Model (Container) = Model (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- others =>
-
- -- Positions is valid in Container and it is located either before
- -- Before if it is valid in Container or at the end if it is
- -- No_Element.
-
- P.Has_Key (Positions (Container), Position)
- and (if Before = No_Element then
- P.Get (Positions (Container), Position) =
- Length (Container)'Old + 1
- else
- P.Get (Positions (Container), Position) =
- P.Get (Positions (Container)'Old, Before))
-
- -- The elements of Container located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container contains Count times New_Item after position Position
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst =>
- P.Get (Positions (Container), Position) - 1 + Count,
- Item => New_Item)
-
- -- Count cursor have been inserted at Position in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position),
- Count => Count));
-
- procedure Prepend (Container : in out List; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Container.Capacity,
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is the first element of Container
-
- and Element (Model (Container), 1) = New_Item
-
- -- A new cursor has been inserted at the beginning of Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => 1);
-
- procedure Prepend
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Container.Capacity - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container starts with Count times New_Item
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => 1,
- Lst => Count,
- Item => New_Item)
-
- -- Count cursors have been inserted at the beginning of Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => 1,
- Count => Count);
-
- procedure Append (Container : in out List; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Container.Capacity,
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Positions contains a new mapping from the last cursor of Container
- -- to its length.
-
- and P.Get (Positions (Container), Last (Container)) =
- Length (Container)
-
- -- Other cursors come from Container'Old
-
- and P.Keys_Included_Except
- (Left => Positions (Container),
- Right => Positions (Container)'Old,
- New_Key => Last (Container))
-
- -- Cursors of Container'Old keep the same position
-
- and Positions (Container)'Old <= Positions (Container)
-
- -- Model contains a new element New_Item at the end
-
- and Element (Model (Container), Length (Container)) = New_Item
-
- -- Elements of Container'Old are preserved
-
- and Model (Container)'Old <= Model (Container);
-
- procedure Append
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Container.Capacity - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- The elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- Container contains Count times New_Item at the end
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Length (Container)'Old + 1,
- Lst => Length (Container),
- Item => New_Item))
-
- -- Count cursors have been inserted at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Length (Container)'Old + 1,
- Count => Count);
-
- procedure Delete (Container : in out List; Position : in out Cursor) with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Position is set to No_Element
-
- and Position = No_Element
-
- -- The elements of Container located before Position are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => 1)
-
- -- Position has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old));
-
- procedure Delete
- (Container : in out List;
- Position : in out Cursor;
- Count : Count_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) in
- Length (Container)'Old - Count .. Length (Container)'Old
-
- -- Position is set to No_Element
-
- and Position = No_Element
-
- -- The elements of Container located before Position are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1),
-
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) - Count < P.Get (Positions (Container), Position) =>
- Length (Container) =
- P.Get (Positions (Container)'Old, Position'Old) - 1
-
- -- At most Count cursors have been removed at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old),
- Count => Count),
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => Count)
-
- -- Count cursors have been removed from Container at Position
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old),
- Count => Count));
-
- procedure Delete_First (Container : in out List) with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => 1)
-
- -- The first cursor of Container has been removed
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1);
-
- procedure Delete_First (Container : in out List; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count =>
- Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Elements of Container are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => Count)
-
- -- The first Count cursors have been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1,
- Count => Count));
-
- procedure Delete_Last (Container : in out List) with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old
-
- -- The last cursor of Container has been removed
-
- and not P.Has_Key (Positions (Container), Last (Container)'Old)
-
- -- Other cursors are still valid
-
- and P.Keys_Included_Except
- (Left => Positions (Container)'Old,
- Right => Positions (Container)'Old,
- New_Key => Last (Container)'Old)
-
- -- The positions of other cursors are preserved
-
- and Positions (Container) <= Positions (Container)'Old;
-
- procedure Delete_Last (Container : in out List; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count =>
- Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old
-
- -- At most Count cursors have been removed at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Length (Container) + 1,
- Count => Count));
-
- procedure Reverse_Elements (Container : in out List) with
- Global => null,
- Post => M_Elements_Reversed (Model (Container)'Old, Model (Container));
-
- procedure Swap
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- with
- Global => null,
- Pre => Has_Element (Container, I) and then Has_Element (Container, J),
- Post =>
- M_Elements_Swapped
- (Model (Container)'Old,
- Model (Container),
- X => P.Get (Positions (Container)'Old, I),
- Y => P.Get (Positions (Container)'Old, J))
-
- and Positions (Container) = Positions (Container)'Old;
-
- procedure Swap_Links
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- with
- Global => null,
- Pre => Has_Element (Container, I) and then Has_Element (Container, J),
- Post =>
- M_Elements_Swapped
- (Model (Container'Old),
- Model (Container),
- X => P.Get (Positions (Container)'Old, I),
- Y => P.Get (Positions (Container)'Old, J))
- and P_Positions_Swapped
- (Positions (Container)'Old, Positions (Container), I, J);
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List)
- -- Target and Source should not be aliased
- with
- Global => null,
- Pre =>
- Length (Source) <= Target.Capacity - Length (Target)
- and then (Has_Element (Target, Before)
- or else Before = No_Element),
- Post =>
- Length (Source) = 0
- and Length (Target) = Length (Target)'Old + Length (Source)'Old,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- The elements of Target are preserved
-
- M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => Length (Target)'Old)
-
- -- The elements of Source are appended to target, the order is not
- -- specified.
-
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Fst => Length (Target)'Old + 1,
- R_Lst => Length (Target))
-
- and M_Elements_Included
- (Left => Model (Target),
- L_Fst => Length (Target)'Old + 1,
- L_Lst => Length (Target),
- Right => Model (Source)'Old,
- R_Lst => Length (Source)'Old)
-
- -- Cursors have been inserted at the end of Target
-
- and P_Positions_Truncated
- (Positions (Target)'Old,
- Positions (Target),
- Cut => Length (Target)'Old + 1,
- Count => Length (Source)'Old),
-
- others =>
-
- -- The elements of Target located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => P.Get (Positions (Target)'Old, Before) - 1)
-
- -- The elements of Source are inserted before Before, the order is
- -- not specified.
-
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Fst => P.Get (Positions (Target)'Old, Before),
- R_Lst =>
- P.Get (Positions (Target)'Old, Before) - 1 +
- Length (Source)'Old)
-
- and M_Elements_Included
- (Left => Model (Target),
- L_Fst => P.Get (Positions (Target)'Old, Before),
- L_Lst =>
- P.Get (Positions (Target)'Old, Before) - 1 +
- Length (Source)'Old,
- Right => Model (Source)'Old,
- R_Lst => Length (Source)'Old)
-
- -- Other elements are shifted by the length of Source
-
- and M.Range_Shifted
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => P.Get (Positions (Target)'Old, Before),
- Lst => Length (Target)'Old,
- Offset => Length (Source)'Old)
-
- -- Cursors have been inserted at position Before in Target
-
- and P_Positions_Shifted
- (Positions (Target)'Old,
- Positions (Target),
- Cut => P.Get (Positions (Target)'Old, Before),
- Count => Length (Source)'Old));
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List;
- Position : in out Cursor)
- -- Target and Source should not be aliased
- with
- Global => null,
- Pre =>
- (Has_Element (Target, Before) or else Before = No_Element)
- and then Has_Element (Source, Position)
- and then Length (Target) < Target.Capacity,
- Post =>
- Length (Target) = Length (Target)'Old + 1
- and Length (Source) = Length (Source)'Old - 1
-
- -- The elements of Source located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Source)'Old,
- Right => Model (Source),
- Fst => 1,
- Lst => P.Get (Positions (Source)'Old, Position'Old) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Source)'Old,
- Right => Model (Source),
- Fst => P.Get (Positions (Source)'Old, Position'Old) + 1,
- Lst => Length (Source)'Old,
- Offset => -1)
-
- -- Position has been removed from Source
-
- and P_Positions_Shifted
- (Positions (Source),
- Positions (Source)'Old,
- Cut => P.Get (Positions (Source)'Old, Position'Old))
-
- -- Positions is valid in Target and it is located either before
- -- Before if it is valid in Target or at the end if it is No_Element.
-
- and P.Has_Key (Positions (Target), Position)
- and (if Before = No_Element then
- P.Get (Positions (Target), Position) = Length (Target)
- else
- P.Get (Positions (Target), Position) =
- P.Get (Positions (Target)'Old, Before))
-
- -- The elements of Target located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => P.Get (Positions (Target), Position) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => P.Get (Positions (Target), Position),
- Lst => Length (Target)'Old,
- Offset => 1)
-
- -- The element located at Position in Source is moved to Target
-
- and Element (Model (Target),
- P.Get (Positions (Target), Position)) =
- Element (Model (Source)'Old,
- P.Get (Positions (Source)'Old, Position'Old))
-
- -- A new cursor has been inserted at position Position in Target
-
- and P_Positions_Shifted
- (Positions (Target)'Old,
- Positions (Target),
- Cut => P.Get (Positions (Target), Position));
-
- procedure Splice
- (Container : in out List;
- Before : Cursor;
- Position : Cursor)
- with
- Global => null,
- Pre =>
- (Has_Element (Container, Before) or else Before = No_Element)
- and then Has_Element (Container, Position),
- Post => Length (Container) = Length (Container)'Old,
- Contract_Cases =>
- (Before = Position =>
- Model (Container) = Model (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- Before = No_Element =>
-
- -- The elements located before Position are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Position) + 1,
- Lst => Length (Container)'Old,
- Offset => -1)
-
- -- The last element of Container is the one that was previously at
- -- Position.
-
- and Element (Model (Container),
- Length (Container)) =
- Element (Model (Container)'Old,
- P.Get (Positions (Container)'Old, Position))
-
- -- Cursors from Container continue designating the same elements
-
- and Mapping_Preserved
- (M_Left => Model (Container)'Old,
- M_Right => Model (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container)),
-
- others =>
-
- -- The elements located before Position and Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst =>
- Count_Type'Min
- (P.Get (Positions (Container)'Old, Position) - 1,
- P.Get (Positions (Container)'Old, Before) - 1))
-
- -- The elements located after Position and Before are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst =>
- Count_Type'Max
- (P.Get (Positions (Container)'Old, Position) + 1,
- P.Get (Positions (Container)'Old, Before) + 1),
- Lst => Length (Container))
-
- -- The elements located after Before and before Position are
- -- shifted by 1 to the right.
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before) + 1,
- Lst => P.Get (Positions (Container)'Old, Position) - 1,
- Offset => 1)
-
- -- The elements located after Position and before Before are
- -- shifted by 1 to the left.
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Position) + 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1,
- Offset => -1)
-
- -- The element previously at Position is now before Before
-
- and Element
- (Model (Container),
- P.Get (Positions (Container)'Old, Before)) =
- Element
- (Model (Container)'Old,
- P.Get (Positions (Container)'Old, Position))
-
- -- Cursors from Container continue designating the same elements
-
- and Mapping_Preserved
- (M_Left => Model (Container)'Old,
- M_Right => Model (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container)));
-
- function First (Container : List) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
-
- function First_Element (Container : List) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post => First_Element'Result = M.Get (Model (Container), 1);
-
- function Last (Container : List) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- Last'Result = No_Element,
-
- others =>
- Has_Element (Container, Last'Result)
- and P.Get (Positions (Container), Last'Result) =
- Length (Container));
-
- function Last_Element (Container : List) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result = M.Get (Model (Container), Length (Container));
-
- function Next (Container : List; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
-
- procedure Next (Container : List; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
-
- function Previous (Container : List; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Previous'Result = No_Element,
-
- others =>
- Has_Element (Container, Previous'Result)
- and then P.Get (Positions (Container), Previous'Result) =
- P.Get (Positions (Container), Position) - 1);
-
- procedure Previous (Container : List; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) - 1);
-
- function Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
-
- -- If Item is not contained in Container after Position, Find returns
- -- No_Element.
-
- (not M.Contains
- (Container => Model (Container),
- Fst =>
- (if Position = No_Element then
- 1
- else
- P.Get (Positions (Container), Position)),
- Lst => Length (Container),
- Item => Item)
- =>
- Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
-
- -- The element designated by the result of Find is Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Find'Result)) = Item
-
- -- The result of Find is located after Position
-
- and (if Position /= No_Element then
- P.Get (Positions (Container), Find'Result) >=
- P.Get (Positions (Container), Position))
-
- -- It is the first occurrence of Item in this slice
-
- and not M.Contains
- (Container => Model (Container),
- Fst =>
- (if Position = No_Element then
- 1
- else
- P.Get (Positions (Container), Position)),
- Lst =>
- P.Get (Positions (Container), Find'Result) - 1,
- Item => Item));
-
- function Reverse_Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
-
- -- If Item is not contained in Container before Position, Find returns
- -- No_Element.
-
- (not M.Contains
- (Container => Model (Container),
- Fst => 1,
- Lst =>
- (if Position = No_Element then
- Length (Container)
- else
- P.Get (Positions (Container), Position)),
- Item => Item)
- =>
- Reverse_Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Reverse_Find'Result)
-
- -- The element designated by the result of Find is Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Reverse_Find'Result)) = Item
-
- -- The result of Find is located before Position
-
- and (if Position /= No_Element then
- P.Get (Positions (Container), Reverse_Find'Result) <=
- P.Get (Positions (Container), Position))
-
- -- It is the last occurrence of Item in this slice
-
- and not M.Contains
- (Container => Model (Container),
- Fst =>
- P.Get (Positions (Container),
- Reverse_Find'Result) + 1,
- Lst =>
- (if Position = No_Element then
- Length (Container)
- else
- P.Get (Positions (Container), Position)),
- Item => Item));
-
- function Contains
- (Container : List;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Post =>
- Contains'Result = M.Contains (Container => Model (Container),
- Fst => 1,
- Lst => Length (Container),
- Item => Item);
-
- function Has_Element
- (Container : List;
- Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- generic
- with function "<" (Left, Right : Element_Type) return Boolean is <>;
-
- package Generic_Sorting with SPARK_Mode is
-
- package Formal_Model with Ghost is
- function M_Elements_Sorted (Container : M.Sequence) return Boolean
- with
- Global => null,
- Post =>
- M_Elements_Sorted'Result =
- (for all I in 1 .. M.Length (Container) =>
- (for all J in I .. M.Length (Container) =>
- not (Element (Container, J) < Element (Container, I))));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted);
-
- end Formal_Model;
- use Formal_Model;
-
- function Is_Sorted (Container : List) return Boolean with
- Global => null,
- Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container));
-
- procedure Sort (Container : in out List) with
- Global => null,
- Post =>
- Length (Container) = Length (Container)'Old
- and M_Elements_Sorted (Model (Container))
- and M_Elements_Included
- (Left => Model (Container)'Old,
- L_Lst => Length (Container),
- Right => Model (Container),
- R_Lst => Length (Container))
- and M_Elements_Included
- (Left => Model (Container),
- L_Lst => Length (Container),
- Right => Model (Container)'Old,
- R_Lst => Length (Container));
-
- procedure Merge (Target : in out List; Source : in out List) with
- -- Target and Source should not be aliased
- Global => null,
- Pre => Length (Source) <= Target.Capacity - Length (Target),
- Post =>
- Length (Target) = Length (Target)'Old + Length (Source)'Old
- and Length (Source) = 0
- and (if M_Elements_Sorted (Model (Target)'Old)
- and M_Elements_Sorted (Model (Source)'Old)
- then
- M_Elements_Sorted (Model (Target)))
- and M_Elements_Included
- (Left => Model (Target)'Old,
- L_Lst => Length (Target)'Old,
- Right => Model (Target),
- R_Lst => Length (Target))
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Lst => Length (Target))
- and M_Elements_In_Union
- (Model (Target),
- Model (Source)'Old,
- Model (Target)'Old);
- end Generic_Sorting;
-
-private
- pragma SPARK_Mode (Off);
-
- type Node_Type is record
- Prev : Count_Type'Base := -1;
- Next : Count_Type;
- Element : aliased Element_Type;
- end record;
-
- function "=" (L, R : Node_Type) return Boolean is abstract;
-
- type Node_Array is array (Count_Type range <>) of Node_Type;
- function "=" (L, R : Node_Array) return Boolean is abstract;
-
- type List (Capacity : Count_Type) is record
- Free : Count_Type'Base := -1;
- Length : Count_Type := 0;
- First : Count_Type := 0;
- Last : Count_Type := 0;
- Nodes : Node_Array (1 .. Capacity);
- end record;
+package Ada.Containers.Formal_Doubly_Linked_Lists with SPARK_Mode is
- Empty_List : constant List := (0, others => <>);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Doubly_Linked_Lists;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Hash_Tables.Generic_Formal_Operations;
-pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations);
-
-with Ada.Containers.Hash_Tables.Generic_Formal_Keys;
-pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Keys);
-
-with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Hashed_Maps with
- SPARK_Mode => Off
-is
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- -- All local subprograms require comments ???
-
- function Equivalent_Keys
- (Key : Key_Type;
- Node : Node_Type) return Boolean;
- pragma Inline (Equivalent_Keys);
-
- procedure Free
- (HT : in out Map;
- X : Count_Type);
-
- generic
- with procedure Set_Element (Node : in out Node_Type);
- procedure Generic_Allocate
- (HT : in out HT_Types.Hash_Table_Type;
- Node : out Count_Type);
-
- function Hash_Node (Node : Node_Type) return Hash_Type;
- pragma Inline (Hash_Node);
-
- function Next (Node : Node_Type) return Count_Type;
- pragma Inline (Next);
-
- procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
- pragma Inline (Set_Next);
-
- function Vet (Container : Map; Position : Cursor) return Boolean
- with Inline;
-
- -- Convert Count_Type to Big_Interger
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
-
- function Big (J : Count_Type) return Big_Integer renames
- Conversions.To_Big_Integer;
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package HT_Ops is
- new Hash_Tables.Generic_Formal_Operations
- (HT_Types => HT_Types,
- Hash_Node => Hash_Node,
- Next => Next,
- Set_Next => Set_Next);
-
- package Key_Ops is
- new Hash_Tables.Generic_Formal_Keys
- (HT_Types => HT_Types,
- Next => Next,
- Set_Next => Set_Next,
- Key_Type => Key_Type,
- Hash => Hash,
- Equivalent_Keys => Equivalent_Keys);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left, Right : Map) return Boolean is
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- if Length (Left) = 0 then
- return True;
- end if;
-
- declare
- Node : Count_Type;
- ENode : Count_Type;
-
- begin
- Node := First (Left).Node;
- while Node /= 0 loop
- ENode :=
- Find
- (Container => Right,
- Key => Left.Content.Nodes (Node).Key).Node;
-
- if ENode = 0 or else
- Right.Content.Nodes (ENode).Element /=
- Left.Content.Nodes (Node).Element
- then
- return False;
- end if;
-
- Node := HT_Ops.Next (Left.Content, Node);
- end loop;
-
- return True;
- end;
- end "=";
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out Map; Source : Map) is
- procedure Insert_Element (Source_Node : Count_Type);
- pragma Inline (Insert_Element);
-
- procedure Insert_Elements is
- new HT_Ops.Generic_Iteration (Insert_Element);
-
- --------------------
- -- Insert_Element --
- --------------------
-
- procedure Insert_Element (Source_Node : Count_Type) is
- N : Node_Type renames Source.Content.Nodes (Source_Node);
- begin
- Insert (Target, N.Key, N.Element);
- end Insert_Element;
-
- -- Start of processing for Assign
-
- begin
- if Target.Capacity < Length (Source) then
- raise Constraint_Error with -- correct exception ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- Insert_Elements (Source.Content);
- end Assign;
-
- --------------
- -- Capacity --
- --------------
-
- function Capacity (Container : Map) return Count_Type is
- begin
- return Container.Content.Nodes'Length;
- end Capacity;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Map) is
- begin
- HT_Ops.Clear (Container.Content);
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Map;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position),
- "bad cursor in function Constant_Reference");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Constant_Reference;
-
- function Constant_Reference
- (Container : aliased Map;
- Key : Key_Type) return not null access constant Element_Type
- is
- Node : constant Count_Type := Find (Container, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "no element available because key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains (Container : Map; Key : Key_Type) return Boolean is
- begin
- return Find (Container, Key) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy
- (Source : Map;
- Capacity : Count_Type := 0) return Map
- is
- C : constant Count_Type :=
- Count_Type'Max (Capacity, Source.Capacity);
- Cu : Cursor;
- H : Hash_Type;
- N : Count_Type;
- Target : Map (C, Source.Modulus);
-
- begin
- if 0 < Capacity and then Capacity < Source.Capacity then
- raise Capacity_Error;
- end if;
-
- Target.Content.Length := Source.Content.Length;
- Target.Content.Free := Source.Content.Free;
-
- H := 1;
- while H <= Source.Modulus loop
- Target.Content.Buckets (H) := Source.Content.Buckets (H);
- H := H + 1;
- end loop;
-
- N := 1;
- while N <= Source.Capacity loop
- Target.Content.Nodes (N) := Source.Content.Nodes (N);
- N := N + 1;
- end loop;
-
- while N <= C loop
- Cu := (Node => N);
- Free (Target, Cu.Node);
- N := N + 1;
- end loop;
-
- return Target;
- end Copy;
-
- ---------------------
- -- Default_Modulus --
- ---------------------
-
- function Default_Modulus (Capacity : Count_Type) return Hash_Type is
- begin
- return To_Prime (Capacity);
- end Default_Modulus;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Map; Key : Key_Type) is
- X : Count_Type;
-
- begin
- Key_Ops.Delete_Key_Sans_Free (Container.Content, Key, X);
-
- if X = 0 then
- raise Constraint_Error with "attempt to delete key not in map";
- end if;
-
- Free (Container, X);
- end Delete;
-
- procedure Delete (Container : in out Map; Position : in out Cursor) is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of Delete has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in Delete");
-
- HT_Ops.Delete_Node_Sans_Free (Container.Content, Position.Node);
-
- Free (Container, Position.Node);
- Position := No_Element;
- end Delete;
-
- -------------
- -- Element --
- -------------
-
- function Element (Container : Map; Key : Key_Type) return Element_Type is
- Node : constant Count_Type := Find (Container, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "no element available because key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element;
- end Element;
-
- function Element (Container : Map; Position : Cursor) return Element_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor equals No_Element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in function Element");
-
- return Container.Content.Nodes (Position.Node).Element;
- end Element;
-
- ---------------------
- -- Equivalent_Keys --
- ---------------------
-
- function Equivalent_Keys
- (Key : Key_Type;
- Node : Node_Type) return Boolean
- is
- begin
- return Equivalent_Keys (Key, Node.Key);
- end Equivalent_Keys;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Map; Key : Key_Type) is
- X : Count_Type;
- begin
- Key_Ops.Delete_Key_Sans_Free (Container.Content, Key, X);
- Free (Container, X);
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : Map) return Cursor is
- Node : constant Count_Type := HT_Ops.First (Container.Content);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end First;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : K.Sequence;
- Key : Key_Type) return Count_Type
- is
- begin
- for I in 1 .. K.Length (Container) loop
- if Equivalent_Keys (Key, K.Get (Container, I)) then
- return I;
- end if;
- end loop;
- return 0;
- end Find;
-
- ---------------------
- -- K_Keys_Included --
- ---------------------
-
- function K_Keys_Included
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean
- is
- begin
- for I in 1 .. K.Length (Left) loop
- if not K.Contains (Right, 1, K.Length (Right), K.Get (Left, I))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end K_Keys_Included;
-
- ----------
- -- Keys --
- ----------
-
- function Keys (Container : Map) return K.Sequence is
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : K.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := K.Add (R, Container.Content.Nodes (Position).Key);
- Position := HT_Ops.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Keys;
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : Map) is null;
-
- -----------------------
- -- Mapping_Preserved --
- -----------------------
-
- function Mapping_Preserved
- (K_Left : K.Sequence;
- K_Right : K.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- is
- begin
- for C of P_Left loop
- if not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > K.Length (K_Left)
- or else P.Get (P_Right, C) > K.Length (K_Right)
- or else K.Get (K_Left, P.Get (P_Left, C)) /=
- K.Get (K_Right, P.Get (P_Right, C))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Map) return M.Map is
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : M.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R :=
- M.Add
- (Container => R,
- New_Key => Container.Content.Nodes (Position).Key,
- New_Item => Container.Content.Nodes (Position).Element);
-
- Position := HT_Ops.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Model;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : Map) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = Big (I));
- Position := HT_Ops.Next (Container.Content, Position);
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (HT : in out Map; X : Count_Type) is
- begin
- if X /= 0 then
- pragma Assert (X <= HT.Capacity);
- HT.Content.Nodes (X).Has_Element := False;
- HT_Ops.Free (HT.Content, X);
- end if;
- end Free;
-
- ----------------------
- -- Generic_Allocate --
- ----------------------
-
- procedure Generic_Allocate
- (HT : in out HT_Types.Hash_Table_Type;
- Node : out Count_Type)
- is
- procedure Allocate is
- new HT_Ops.Generic_Allocate (Set_Element);
-
- begin
- Allocate (HT, Node);
- HT.Nodes (Node).Has_Element := True;
- end Generic_Allocate;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : Map; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0
- or else not Container.Content.Nodes (Position.Node).Has_Element
- then
- return False;
- else
- return True;
- end if;
- end Has_Element;
-
- ---------------
- -- Hash_Node --
- ---------------
-
- function Hash_Node (Node : Node_Type) return Hash_Type is
- begin
- return Hash (Node.Key);
- end Hash_Node;
-
- -------------
- -- Include --
- -------------
-
- procedure Include
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, Key, New_Item, Position, Inserted);
-
- if not Inserted then
- declare
- P : constant Count_Type := Position.Node;
- N : Node_Type renames Container.Content.Nodes (P);
- begin
- N.Key := Key;
- N.Element := New_Item;
- end;
- end if;
- end Include;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- is
- procedure Assign_Key (Node : in out Node_Type);
- pragma Inline (Assign_Key);
-
- procedure New_Node
- (HT : in out HT_Types.Hash_Table_Type;
- Node : out Count_Type);
- pragma Inline (New_Node);
-
- procedure Local_Insert is
- new Key_Ops.Generic_Conditional_Insert (New_Node);
-
- procedure Allocate is
- new Generic_Allocate (Assign_Key);
-
- -----------------
- -- Assign_Key --
- -----------------
-
- procedure Assign_Key (Node : in out Node_Type) is
- begin
- Node.Key := Key;
- Node.Element := New_Item;
- end Assign_Key;
-
- --------------
- -- New_Node --
- --------------
-
- procedure New_Node
- (HT : in out HT_Types.Hash_Table_Type;
- Node : out Count_Type)
- is
- begin
- Allocate (HT, Node);
- end New_Node;
-
- -- Start of processing for Insert
-
- begin
- Local_Insert (Container.Content, Key, Position.Node, Inserted);
- end Insert;
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Unused_Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, Key, New_Item, Unused_Position, Inserted);
-
- if not Inserted then
- raise Constraint_Error with "attempt to insert key already in map";
- end if;
- end Insert;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Map) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- ---------
- -- Key --
- ---------
-
- function Key (Container : Map; Position : Cursor) return Key_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of function Key has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in function Key");
-
- return Container.Content.Nodes (Position.Node).Key;
- end Key;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Map) return Count_Type is
- begin
- return Container.Content.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move
- (Target : in out Map;
- Source : in out Map)
- is
- NN : HT_Types.Nodes_Type renames Source.Content.Nodes;
- X : Count_Type;
- Y : Count_Type;
-
- begin
- if Target.Capacity < Length (Source) then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- if Source.Content.Length = 0 then
- return;
- end if;
-
- X := HT_Ops.First (Source.Content);
- while X /= 0 loop
- Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
-
- Y := HT_Ops.Next (Source.Content, X);
-
- HT_Ops.Delete_Node_Sans_Free (Source.Content, X);
- Free (Source, X);
-
- X := Y;
- end loop;
- end Move;
-
- ----------
- -- Next --
- ----------
-
- function Next (Node : Node_Type) return Count_Type is
- begin
- return Node.Next;
- end Next;
-
- function Next (Container : Map; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in function Next");
-
- declare
- Node : constant Count_Type :=
- HT_Ops.Next (Container.Content, Position.Node);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
- end Next;
-
- procedure Next (Container : Map; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference
- (Container : not null access Map;
- Position : Cursor) return not null access Element_Type
- is
- begin
- if not Has_Element (Container.all, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container.all, Position), "bad cursor in function Reference");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Reference;
-
- function Reference
- (Container : not null access Map;
- Key : Key_Type) return not null access Element_Type
- is
- Node : constant Count_Type := Find (Container.all, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "no element available because key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element'Access;
- end Reference;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Node : constant Count_Type := Key_Ops.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- raise Constraint_Error with "attempt to replace key not in map";
- end if;
-
- declare
- N : Node_Type renames Container.Content.Nodes (Node);
- begin
- N.Key := Key;
- N.Element := New_Item;
- end;
- end Replace;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out Map;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of Replace_Element has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in Replace_Element");
-
- Container.Content.Nodes (Position.Node).Element := New_Item;
- end Replace_Element;
-
- ----------------------
- -- Reserve_Capacity --
- ----------------------
-
- procedure Reserve_Capacity
- (Container : in out Map;
- Capacity : Count_Type)
- is
- begin
- if Capacity > Container.Capacity then
- raise Capacity_Error with "requested capacity is too large";
- end if;
- end Reserve_Capacity;
-
- --------------
- -- Set_Next --
- --------------
-
- procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
- begin
- Node.Next := Next;
- end Set_Next;
-
- ---------
- -- Vet --
- ---------
-
- function Vet (Container : Map; Position : Cursor) return Boolean is
- begin
- if not Container_Checks'Enabled then
- return True;
- end if;
-
- if Position.Node = 0 then
- return True;
- end if;
-
- declare
- X : Count_Type;
-
- begin
- if Container.Content.Length = 0 then
- return False;
- end if;
-
- if Container.Capacity = 0 then
- return False;
- end if;
-
- if Container.Content.Buckets'Length = 0 then
- return False;
- end if;
-
- if Position.Node > Container.Capacity then
- return False;
- end if;
-
- if Container.Content.Nodes (Position.Node).Next = Position.Node then
- return False;
- end if;
-
- X :=
- Container.Content.Buckets
- (Key_Ops.Index
- (Container.Content,
- Container.Content.Nodes (Position.Node).Key));
-
- for J in 1 .. Container.Content.Length loop
- if X = Position.Node then
- return True;
- end if;
-
- if X = 0 then
- return False;
- end if;
-
- if X = Container.Content.Nodes (X).Next then
-
- -- Prevent unnecessary looping
-
- return False;
- end if;
-
- X := Container.Content.Nodes (X).Next;
- end loop;
-
- return False;
- end;
- end Vet;
-
-end Ada.Containers.Formal_Hashed_Maps;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- This spec is derived from package Ada.Containers.Bounded_Hashed_Maps in the
--- Ada 2012 RM. The modifications are meant to facilitate formal proofs by
--- making it easier to express properties, and by making the specification of
--- this unit compatible with SPARK 2014. Note that the API of this unit may be
--- subject to incompatible changes as SPARK 2014 evolves.
-
--- The modifications are:
-
--- A parameter for the container is added to every function reading the
--- contents of a container: Key, Element, Next, Query_Element, Has_Element,
--- Iterate, Equivalent_Keys. This change is motivated by the need to have
--- cursors which are valid on different containers (typically a container C
--- and its previous version C'Old) for expressing properties, which is not
--- possible if cursors encapsulate an access to the underlying container.
-
--- Iteration over maps is done using the Iterable aspect, which is SPARK
--- compatible. "For of" iteration ranges over keys instead of elements.
-
-with Ada.Containers.Functional_Vectors;
-with Ada.Containers.Functional_Maps;
-private with Ada.Containers.Hash_Tables;
-
generic
- type Key_Type is private;
- type Element_Type is private;
-
- with function Hash (Key : Key_Type) return Hash_Type;
- with function Equivalent_Keys
- (Left : Key_Type;
- Right : Key_Type) return Boolean is "=";
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Hashed_Maps with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- type Map (Capacity : Count_Type; Modulus : Hash_Type) is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Key),
- Default_Initial_Condition => Is_Empty (Map);
- pragma Preelaborable_Initialization (Map);
-
- Empty_Map : constant Map;
-
- type Cursor is record
- Node : Count_Type;
- end record;
-
- No_Element : constant Cursor := (Node => 0);
-
- function Length (Container : Map) return Count_Type with
- Global => null,
- Post => Length'Result <= Container.Capacity;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Maps
- (Element_Type => Element_Type,
- Key_Type => Key_Type,
- Equivalent_Keys => Equivalent_Keys);
-
- function "="
- (Left : M.Map;
- Right : M.Map) return Boolean renames M."=";
-
- function "<="
- (Left : M.Map;
- Right : M.Map) return Boolean renames M."<=";
-
- package K is new Ada.Containers.Functional_Vectors
- (Element_Type => Key_Type,
- Index_Type => Positive_Count_Type);
-
- function "="
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."=";
-
- function "<"
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."<";
-
- function "<="
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."<=";
-
- function Find (Container : K.Sequence; Key : Key_Type) return Count_Type
- -- Search for Key in Container
-
- with
- Global => null,
- Post =>
- (if Find'Result > 0 then
- Find'Result <= K.Length (Container)
- and Equivalent_Keys (Key, K.Get (Container, Find'Result)));
-
- function K_Keys_Included
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean
- -- Return True if Right contains all the keys of Left
-
- with
- Global => null,
- Post =>
- K_Keys_Included'Result =
- (for all I in 1 .. K.Length (Left) =>
- Find (Right, K.Get (Left, I)) > 0
- and then K.Get (Right, Find (Right, K.Get (Left, I))) =
- K.Get (Left, I));
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function Mapping_Preserved
- (K_Left : K.Sequence;
- K_Right : K.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- with
- Global => null,
- Post =>
- (if Mapping_Preserved'Result then
-
- -- Right contains all the cursors of Left
-
- P.Keys_Included (P_Left, P_Right)
-
- -- Right contains all the keys of Left
-
- and K_Keys_Included (K_Left, K_Right)
-
- -- Mappings from cursors to elements induced by K_Left, P_Left
- -- and K_Right, P_Right are the same.
-
- and (for all C of P_Left =>
- K.Get (K_Left, P.Get (P_Left, C)) =
- K.Get (K_Right, P.Get (P_Right, C))));
-
- function Model (Container : Map) return M.Map with
- -- The high-level model of a map is a map from keys to elements. Neither
- -- cursors nor order of elements are represented in this model. Keys are
- -- modeled up to equivalence.
-
- Ghost,
- Global => null;
-
- function Keys (Container : Map) return K.Sequence with
- -- The Keys sequence represents the underlying list structure of maps
- -- that is used for iteration. It stores the actual values of keys in
- -- the map. It does not model cursors nor elements.
-
- Ghost,
- Global => null,
- Post =>
- K.Length (Keys'Result) = Length (Container)
-
- -- It only contains keys contained in Model
-
- and (for all Key of Keys'Result =>
- M.Has_Key (Model (Container), Key))
-
- -- It contains all the keys contained in Model
-
- and (for all Key of Model (Container) =>
- (Find (Keys'Result, Key) > 0
- and then Equivalent_Keys
- (K.Get (Keys'Result, Find (Keys'Result, Key)),
- Key)))
-
- -- It has no duplicate
-
- and (for all I in 1 .. Length (Container) =>
- Find (Keys'Result, K.Get (Keys'Result, I)) = I)
-
- and (for all I in 1 .. Length (Container) =>
- (for all J in 1 .. Length (Container) =>
- (if Equivalent_Keys
- (K.Get (Keys'Result, I), K.Get (Keys'Result, J))
- then
- I = J)));
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys);
-
- function Positions (Container : Map) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and maps them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : Map) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level, cursor-aware view of a container, to a high-level,
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Key of Keys (Container) =>
- (for some I of Positions (Container) =>
- K.Get (Keys (Container), P.Get (Positions (Container), I)) =
- Key));
-
- function Contains
- (C : M.Map;
- K : Key_Type) return Boolean renames M.Has_Key;
- -- To improve readability of contracts, we rename the function used to
- -- search for a key in the model to Contains.
-
- function Element
- (C : M.Map;
- K : Key_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
-
- end Formal_Model;
- use Formal_Model;
-
- function "=" (Left, Right : Map) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function Capacity (Container : Map) return Count_Type with
- Global => null,
- Post => Capacity'Result = Container.Capacity;
-
- procedure Reserve_Capacity
- (Container : in out Map;
- Capacity : Count_Type)
- with
- Global => null,
- Pre => Capacity <= Container.Capacity,
- Post =>
- Model (Container) = Model (Container)'Old
- and Length (Container)'Old = Length (Container)
-
- -- Actual keys are preserved
-
- and K_Keys_Included (Keys (Container), Keys (Container)'Old)
- and K_Keys_Included (Keys (Container)'Old, Keys (Container));
-
- function Is_Empty (Container : Map) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out Map) with
- Global => null,
- Post => Length (Container) = 0 and M.Is_Empty (Model (Container));
-
- procedure Assign (Target : in out Map; Source : Map) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)
- and Length (Source) = Length (Target)
-
- -- Actual keys are preserved
-
- and K_Keys_Included (Keys (Target), Keys (Source))
- and K_Keys_Included (Keys (Source), Keys (Target));
-
- function Copy
- (Source : Map;
- Capacity : Count_Type := 0) return Map
- with
- Global => null,
- Pre => Capacity = 0 or else Capacity >= Source.Capacity,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Keys (Copy'Result) = Keys (Source)
- and Positions (Copy'Result) = Positions (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Source.Capacity
- else
- Copy'Result.Capacity = Capacity);
- -- Copy returns a container stricty equal to Source. It must have the same
- -- cursors associated with each element. Therefore:
- -- - capacity=0 means use Source.Capacity as capacity of target
- -- - the modulus cannot be changed.
-
- function Key (Container : Map; Position : Cursor) return Key_Type with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Key'Result =
- K.Get (Keys (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Key);
-
- function Element
- (Container : Map;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result = Element (Model (Container), Key (Container, Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Map;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old
-
- -- New_Item is now associated with the key at position Position in
- -- Container.
-
- and Element (Container, Position) = New_Item
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key (Container, Position));
-
- function At_End
- (E : not null access constant Map) return not null access constant Map
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : aliased Map;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- Element (Model (Container), Key (Container, Position));
-
- function Reference
- (Container : not null access Map;
- Position : Cursor) return not null access Element_Type
- with
- Global => null,
- Pre => Has_Element (Container.all, Position),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (At_End (Container).all) = Keys (Container.all)
- and Positions (At_End (Container).all) = Positions (Container.all)
-
- -- The value designated by the result of Reference is now associated
- -- with the key at position Position in Container.
-
- and Element (At_End (Container).all, Position) =
- At_End (Reference'Result).all
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys
- (Model (At_End (Container).all),
- Model (Container.all))
- and M.Elements_Equal_Except
- (Model (At_End (Container).all),
- Model (Container.all),
- Key (At_End (Container).all, Position));
-
- function Constant_Reference
- (Container : aliased Map;
- Key : Key_Type) return not null access constant Element_Type
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Constant_Reference'Result.all = Element (Model (Container), Key);
-
- function Reference
- (Container : not null access Map;
- Key : Key_Type) return not null access Element_Type
- with
- Global => null,
- Pre => Contains (Container.all, Key),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (At_End (Container).all) = Keys (Container.all)
- and Positions (At_End (Container).all) = Positions (Container.all)
-
- -- The value designated by the result of Reference is now associated
- -- with Key in Container.
-
- and Element (Model (At_End (Container).all), Key) =
- At_End (Reference'Result).all
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys
- (Model (At_End (Container).all),
- Model (Container.all))
- and M.Elements_Equal_Except
- (Model (At_End (Container).all),
- Model (Container.all),
- Key);
-
- procedure Move (Target : in out Map; Source : in out Map) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)'Old
- and Length (Source)'Old = Length (Target)
- and Length (Source) = 0
-
- -- Actual keys are preserved
-
- and K_Keys_Included (Keys (Target), Keys (Source)'Old)
- and K_Keys_Included (Keys (Source)'Old, Keys (Target));
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity or Contains (Container, Key),
- Post =>
- Contains (Container, Key)
- and Has_Element (Container, Position)
- and Equivalent_Keys
- (Formal_Hashed_Maps.Key (Container, Position), Key),
- Contract_Cases =>
-
- -- If Key is already in Container, it is not modified and Inserted is
- -- set to False.
-
- (Contains (Container, Key) =>
- not Inserted
- and Model (Container) = Model (Container)'Old
- and Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Key is inserted in Container and Inserted is set to True
-
- others =>
- Inserted
- and Length (Container) = Length (Container)'Old + 1
-
- -- Key now maps to New_Item
-
- and Formal_Hashed_Maps.Key (Container, Position) = Key
- and Element (Model (Container), Key) = New_Item
-
- -- Other keys are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container)'Old,
- K_Right => Keys (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Position));
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- and then (not Contains (Container, Key)),
- Post =>
- Length (Container) = Length (Container)'Old + 1
- and Contains (Container, Key)
-
- -- Key now maps to New_Item
-
- and Formal_Hashed_Maps.Key (Container, Find (Container, Key)) = Key
- and Element (Model (Container), Key) = New_Item
-
- -- Other keys are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container)'Old,
- K_Right => Keys (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Find (Container, Key));
-
- procedure Include
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity or Contains (Container, Key),
- Post =>
- Contains (Container, Key) and Element (Container, Key) = New_Item,
- Contract_Cases =>
-
- -- If Key is already in Container, Key is mapped to New_Item
-
- (Contains (Container, Key) =>
-
- -- Cursors are preserved
-
- Positions (Container) = Positions (Container)'Old
-
- -- The key equivalent to Key in Container is replaced by Key
-
- and K.Get
- (Keys (Container),
- P.Get (Positions (Container), Find (Container, Key))) = Key
- and K.Equal_Except
- (Keys (Container)'Old,
- Keys (Container),
- P.Get (Positions (Container), Find (Container, Key)))
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key),
-
- -- Otherwise, Key is inserted in Container
-
- others =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Other keys are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- Key is inserted in Container
-
- and K.Get
- (Keys (Container),
- P.Get (Positions (Container), Find (Container, Key))) = Key
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container)'Old,
- K_Right => Keys (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Find (Container, Key)));
-
- procedure Replace
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
-
- -- Cursors are preserved
-
- Positions (Container) = Positions (Container)'Old
-
- -- The key equivalent to Key in Container is replaced by Key
-
- and K.Get
- (Keys (Container),
- P.Get (Positions (Container), Find (Container, Key))) = Key
- and K.Equal_Except
- (Keys (Container)'Old,
- Keys (Container),
- P.Get (Positions (Container), Find (Container, Key)))
-
- -- New_Item is now associated with the Key in Container
-
- and Element (Model (Container), Key) = New_Item
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key);
-
- procedure Exclude (Container : in out Map; Key : Key_Type) with
- Global => null,
- Post => not Contains (Container, Key),
- Contract_Cases =>
-
- -- If Key is not in Container, nothing is changed
-
- (not Contains (Container, Key) =>
- Model (Container) = Model (Container)'Old
- and Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Key is removed from Container
-
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Other keys are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container),
- K_Right => Keys (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Key)'Old));
-
- procedure Delete (Container : in out Map; Key : Key_Type) with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Key is no longer in Container
-
- and not Contains (Container, Key)
-
- -- Other keys are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container),
- K_Right => Keys (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Key)'Old);
-
- procedure Delete (Container : in out Map; Position : in out Cursor) with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Position = No_Element
- and Length (Container) = Length (Container)'Old - 1
-
- -- The key at position Position is no longer in Container
-
- and not Contains (Container, Key (Container, Position)'Old)
- and not P.Has_Key (Positions (Container), Position'Old)
-
- -- Other keys are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key (Container, Position)'Old)
-
- -- Mapping from cursors to keys is preserved
-
- and Mapping_Preserved
- (K_Left => Keys (Container),
- K_Right => Keys (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Position'Old);
-
- function First (Container : Map) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
-
- function Next (Container : Map; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
-
- procedure Next (Container : Map; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
-
- function Find (Container : Map; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
-
- -- If Key is not contained in Container, Find returns No_Element
-
- (not Contains (Model (Container), Key) =>
- Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
- and P.Get (Positions (Container), Find'Result) =
- Find (Keys (Container), Key)
-
- -- The key designated by the result of Find is Key
-
- and Equivalent_Keys
- (Formal_Hashed_Maps.Key (Container, Find'Result), Key));
-
- function Contains (Container : Map; Key : Key_Type) return Boolean with
- Global => null,
- Post => Contains'Result = Contains (Model (Container), Key);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Element (Container : Map; Key : Key_Type) return Element_Type with
- Global => null,
- Pre => Contains (Container, Key),
- Post => Element'Result = Element (Model (Container), Key);
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- function Has_Element (Container : Map; Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- function Default_Modulus (Capacity : Count_Type) return Hash_Type with
- Global => null;
-
-private
- pragma SPARK_Mode (Off);
-
- pragma Inline (Length);
- pragma Inline (Is_Empty);
- pragma Inline (Clear);
- pragma Inline (Key);
- pragma Inline (Element);
- pragma Inline (Contains);
- pragma Inline (Capacity);
- pragma Inline (Has_Element);
- pragma Inline (Equivalent_Keys);
- pragma Inline (Next);
-
- type Node_Type is record
- Key : Key_Type;
- Element : aliased Element_Type;
- Next : Count_Type;
- Has_Element : Boolean := False;
- end record;
-
- package HT_Types is new
- Ada.Containers.Hash_Tables.Generic_Formal_Hash_Table_Types (Node_Type);
-
- type Map (Capacity : Count_Type; Modulus : Hash_Type) is record
- Content : HT_Types.Hash_Table_Type (Capacity, Modulus);
- end record;
+package Ada.Containers.Formal_Hashed_Maps with SPARK_Mode is
- Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Hashed_Maps;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Hash_Tables.Generic_Formal_Operations;
-pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations);
-
-with Ada.Containers.Hash_Tables.Generic_Formal_Keys;
-pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Keys);
-
-with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Hashed_Sets with
- SPARK_Mode => Off
-is
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- -- All need comments ???
-
- procedure Difference (Left : Set; Right : Set; Target : in out Set);
-
- function Equivalent_Keys
- (Key : Element_Type;
- Node : Node_Type) return Boolean;
- pragma Inline (Equivalent_Keys);
-
- procedure Free
- (HT : in out Set;
- X : Count_Type);
-
- generic
- with procedure Set_Element (Node : in out Node_Type);
- procedure Generic_Allocate
- (HT : in out Hash_Table_Type;
- Node : out Count_Type);
-
- function Hash_Node (Node : Node_Type) return Hash_Type;
- pragma Inline (Hash_Node);
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Node : out Count_Type;
- Inserted : out Boolean);
-
- procedure Intersection
- (Left : Set;
- Right : Set;
- Target : in out Set);
-
- function Is_In
- (HT : Set;
- Key : Node_Type) return Boolean;
- pragma Inline (Is_In);
-
- procedure Set_Element (Node : in out Node_Type; Item : Element_Type);
- pragma Inline (Set_Element);
-
- function Next (Node : Node_Type) return Count_Type;
- pragma Inline (Next);
-
- procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
- pragma Inline (Set_Next);
-
- function Vet (Container : Set; Position : Cursor) return Boolean
- with Inline;
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package HT_Ops is new Hash_Tables.Generic_Formal_Operations
- (HT_Types => HT_Types,
- Hash_Node => Hash_Node,
- Next => Next,
- Set_Next => Set_Next);
-
- package Element_Keys is new Hash_Tables.Generic_Formal_Keys
- (HT_Types => HT_Types,
- Next => Next,
- Set_Next => Set_Next,
- Key_Type => Element_Type,
- Hash => Hash,
- Equivalent_Keys => Equivalent_Keys);
-
- procedure Replace_Element is
- new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left, Right : Set) return Boolean is
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- if Length (Left) = 0 then
- return True;
- end if;
-
- declare
- Node : Count_Type;
- ENode : Count_Type;
-
- begin
- Node := First (Left).Node;
- while Node /= 0 loop
- ENode :=
- Find
- (Container => Right,
- Item => Left.Content.Nodes (Node).Element).Node;
-
- if ENode = 0
- or else Right.Content.Nodes (ENode).Element /=
- Left.Content.Nodes (Node).Element
- then
- return False;
- end if;
-
- Node := HT_Ops.Next (Left.Content, Node);
- end loop;
-
- return True;
- end;
- end "=";
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out Set; Source : Set) is
- procedure Insert_Element (Source_Node : Count_Type);
-
- procedure Insert_Elements is
- new HT_Ops.Generic_Iteration (Insert_Element);
-
- --------------------
- -- Insert_Element --
- --------------------
-
- procedure Insert_Element (Source_Node : Count_Type) is
- N : Node_Type renames Source.Content.Nodes (Source_Node);
- Unused_X : Count_Type;
- B : Boolean;
-
- begin
- Insert (Target, N.Element, Unused_X, B);
- pragma Assert (B);
- end Insert_Element;
-
- -- Start of processing for Assign
-
- begin
- if Target.Capacity < Length (Source) then
- raise Storage_Error with "not enough capacity"; -- SE or CE? ???
- end if;
-
- HT_Ops.Clear (Target.Content);
- Insert_Elements (Source.Content);
- end Assign;
-
- --------------
- -- Capacity --
- --------------
-
- function Capacity (Container : Set) return Count_Type is
- begin
- return Container.Content.Nodes'Length;
- end Capacity;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Set) is
- begin
- HT_Ops.Clear (Container.Content);
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Set;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor equals No_Element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in function Element");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains (Container : Set; Item : Element_Type) return Boolean is
- begin
- return Find (Container, Item) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy
- (Source : Set;
- Capacity : Count_Type := 0) return Set
- is
- C : constant Count_Type :=
- Count_Type'Max (Capacity, Source.Capacity);
- Cu : Cursor;
- H : Hash_Type;
- N : Count_Type;
- Target : Set (C, Source.Modulus);
-
- begin
- if 0 < Capacity and then Capacity < Source.Capacity then
- raise Capacity_Error;
- end if;
-
- Target.Content.Length := Source.Content.Length;
- Target.Content.Free := Source.Content.Free;
-
- H := 1;
- while H <= Source.Modulus loop
- Target.Content.Buckets (H) := Source.Content.Buckets (H);
- H := H + 1;
- end loop;
-
- N := 1;
- while N <= Source.Capacity loop
- Target.Content.Nodes (N) := Source.Content.Nodes (N);
- N := N + 1;
- end loop;
-
- while N <= C loop
- Cu := (Node => N);
- Free (Target, Cu.Node);
- N := N + 1;
- end loop;
-
- return Target;
- end Copy;
-
- ---------------------
- -- Default_Modulus --
- ---------------------
-
- function Default_Modulus (Capacity : Count_Type) return Hash_Type is
- begin
- return To_Prime (Capacity);
- end Default_Modulus;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Set; Item : Element_Type) is
- X : Count_Type;
-
- begin
- Element_Keys.Delete_Key_Sans_Free (Container.Content, Item, X);
-
- if X = 0 then
- raise Constraint_Error with "attempt to delete element not in set";
- end if;
-
- Free (Container, X);
- end Delete;
-
- procedure Delete (Container : in out Set; Position : in out Cursor) is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in Delete");
-
- HT_Ops.Delete_Node_Sans_Free (Container.Content, Position.Node);
- Free (Container, Position.Node);
-
- Position := No_Element;
- end Delete;
-
- ----------------
- -- Difference --
- ----------------
-
- procedure Difference (Target : in out Set; Source : Set) is
- Src_Last : Count_Type;
- Src_Length : Count_Type;
- Src_Node : Count_Type;
- Tgt_Node : Count_Type;
-
- TN : Nodes_Type renames Target.Content.Nodes;
- SN : Nodes_Type renames Source.Content.Nodes;
-
- begin
- Src_Length := Source.Content.Length;
-
- if Src_Length = 0 then
- return;
- end if;
-
- if Src_Length >= Target.Content.Length then
- Tgt_Node := HT_Ops.First (Target.Content);
- while Tgt_Node /= 0 loop
- if Element_Keys.Find (Source.Content, TN (Tgt_Node).Element) /= 0
- then
- declare
- X : constant Count_Type := Tgt_Node;
- begin
- Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target.Content, X);
- Free (Target, X);
- end;
-
- else
- Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
- end if;
- end loop;
-
- return;
- else
- Src_Node := HT_Ops.First (Source.Content);
- Src_Last := 0;
- end if;
-
- while Src_Node /= Src_Last loop
- Tgt_Node := Element_Keys.Find (Target.Content, SN (Src_Node).Element);
-
- if Tgt_Node /= 0 then
- HT_Ops.Delete_Node_Sans_Free (Target.Content, Tgt_Node);
- Free (Target, Tgt_Node);
- end if;
-
- Src_Node := HT_Ops.Next (Source.Content, Src_Node);
- end loop;
- end Difference;
-
- procedure Difference (Left : Set; Right : Set; Target : in out Set) is
- procedure Process (L_Node : Count_Type);
-
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
-
- -------------
- -- Process --
- -------------
-
- procedure Process (L_Node : Count_Type) is
- B : Boolean;
- E : Element_Type renames Left.Content.Nodes (L_Node).Element;
- Unused_X : Count_Type;
-
- begin
- if Find (Right, E).Node = 0 then
- Insert (Target, E, Unused_X, B);
- pragma Assert (B);
- end if;
- end Process;
-
- -- Start of processing for Difference
-
- begin
- Iterate (Left.Content);
- end Difference;
-
- function Difference (Left : Set; Right : Set) return Set is
- begin
- if Length (Left) = 0 then
- return Empty_Set;
- end if;
-
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- declare
- C : constant Count_Type := Length (Left);
- H : constant Hash_Type := Default_Modulus (C);
- begin
- return S : Set (C, H) do
- Difference (Left, Right, Target => S);
- end return;
- end;
- end Difference;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : Set;
- Position : Cursor) return Element_Type
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor equals No_Element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in function Element");
-
- return Container.Content.Nodes (Position.Node).Element;
- end Element;
-
- ---------------------
- -- Equivalent_Sets --
- ---------------------
-
- function Equivalent_Sets (Left, Right : Set) return Boolean is
-
- function Find_Equivalent_Key
- (R_HT : Hash_Table_Type;
- L_Node : Node_Type) return Boolean;
- pragma Inline (Find_Equivalent_Key);
-
- function Is_Equivalent is
- new HT_Ops.Generic_Equal (Find_Equivalent_Key);
-
- -------------------------
- -- Find_Equivalent_Key --
- -------------------------
-
- function Find_Equivalent_Key
- (R_HT : Hash_Table_Type;
- L_Node : Node_Type) return Boolean
- is
- R_Index : constant Hash_Type :=
- Element_Keys.Index (R_HT, L_Node.Element);
- R_Node : Count_Type := R_HT.Buckets (R_Index);
- RN : Nodes_Type renames R_HT.Nodes;
-
- begin
- loop
- if R_Node = 0 then
- return False;
- end if;
-
- if Equivalent_Elements
- (L_Node.Element, RN (R_Node).Element)
- then
- return True;
- end if;
-
- R_Node := HT_Ops.Next (R_HT, R_Node);
- end loop;
- end Find_Equivalent_Key;
-
- -- Start of processing for Equivalent_Sets
-
- begin
- return Is_Equivalent (Left.Content, Right.Content);
- end Equivalent_Sets;
-
- ---------------------
- -- Equivalent_Keys --
- ---------------------
-
- function Equivalent_Keys
- (Key : Element_Type;
- Node : Node_Type) return Boolean
- is
- begin
- return Equivalent_Elements (Key, Node.Element);
- end Equivalent_Keys;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Set; Item : Element_Type) is
- X : Count_Type;
- begin
- Element_Keys.Delete_Key_Sans_Free (Container.Content, Item, X);
- Free (Container, X);
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : Set;
- Item : Element_Type) return Cursor
- is
- Node : constant Count_Type :=
- Element_Keys.Find (Container.Content, Item);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : Set) return Cursor is
- Node : constant Count_Type := HT_Ops.First (Container.Content);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end First;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -------------------------
- -- E_Elements_Included --
- -------------------------
-
- function E_Elements_Included
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Left) loop
- if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- function E_Elements_Included
- (Left : E.Sequence;
- Model : M.Set;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Left) loop
- declare
- Item : constant Element_Type := E.Get (Left, I);
- begin
- if M.Contains (Model, Item) then
- if not E.Contains (Right, 1, E.Length (Right), Item) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- function E_Elements_Included
- (Container : E.Sequence;
- Model : M.Set;
- Left : E.Sequence;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Container) loop
- declare
- Item : constant Element_Type := E.Get (Container, I);
- begin
- if M.Contains (Model, Item) then
- if not E.Contains (Left, 1, E.Length (Left), Item) then
- return False;
- end if;
- else
- if not E.Contains (Right, 1, E.Length (Right), Item) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : E.Sequence;
- Item : Element_Type) return Count_Type
- is
- begin
- for I in 1 .. E.Length (Container) loop
- if Equivalent_Elements (Item, E.Get (Container, I)) then
- return I;
- end if;
- end loop;
- return 0;
- end Find;
-
- --------------
- -- Elements --
- --------------
-
- function Elements (Container : Set) return E.Sequence is
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : E.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := E.Add (R, Container.Content.Nodes (Position).Element);
- Position := HT_Ops.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Elements;
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : Set) is null;
-
- -----------------------
- -- Mapping_Preserved --
- -----------------------
-
- function Mapping_Preserved
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- is
- begin
- for C of P_Left loop
- if not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > E.Length (E_Left)
- or else P.Get (P_Right, C) > E.Length (E_Right)
- or else E.Get (E_Left, P.Get (P_Left, C)) /=
- E.Get (E_Right, P.Get (P_Right, C))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved;
-
- ------------------------------
- -- Mapping_Preserved_Except --
- ------------------------------
-
- function Mapping_Preserved_Except
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map;
- Position : Cursor) return Boolean
- is
- begin
- for C of P_Left loop
- if C /= Position
- and (not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > E.Length (E_Left)
- or else P.Get (P_Right, C) > E.Length (E_Right)
- or else E.Get (E_Left, P.Get (P_Left, C)) /=
- E.Get (E_Right, P.Get (P_Right, C)))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved_Except;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Set) return M.Set is
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : M.Set;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R :=
- M.Add
- (Container => R,
- Item => Container.Content.Nodes (Position).Element);
-
- Position := HT_Ops.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Model;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : Set) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := HT_Ops.First (Container.Content);
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = Big (I));
- Position := HT_Ops.Next (Container.Content, Position);
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (HT : in out Set; X : Count_Type) is
- begin
- if X /= 0 then
- pragma Assert (X <= HT.Capacity);
- HT.Content.Nodes (X).Has_Element := False;
- HT_Ops.Free (HT.Content, X);
- end if;
- end Free;
-
- ----------------------
- -- Generic_Allocate --
- ----------------------
-
- procedure Generic_Allocate
- (HT : in out Hash_Table_Type;
- Node : out Count_Type)
- is
- procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element);
- begin
- Allocate (HT, Node);
- HT.Nodes (Node).Has_Element := True;
- end Generic_Allocate;
-
- package body Generic_Keys with SPARK_Mode => Off is
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function Equivalent_Key_Node
- (Key : Key_Type;
- Node : Node_Type) return Boolean;
- pragma Inline (Equivalent_Key_Node);
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package Key_Keys is new Hash_Tables.Generic_Formal_Keys
- (HT_Types => HT_Types,
- Next => Next,
- Set_Next => Set_Next,
- Key_Type => Key_Type,
- Hash => Hash,
- Equivalent_Keys => Equivalent_Key_Node);
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Set;
- Key : Key_Type) return Boolean
- is
- begin
- return Find (Container, Key) /= No_Element;
- end Contains;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Set; Key : Key_Type) is
- X : Count_Type;
-
- begin
- Key_Keys.Delete_Key_Sans_Free (Container.Content, Key, X);
-
- if X = 0 then
- raise Constraint_Error with "attempt to delete key not in set";
- end if;
-
- Free (Container, X);
- end Delete;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : Set;
- Key : Key_Type) return Element_Type
- is
- Node : constant Count_Type := Find (Container, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with "key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element;
- end Element;
-
- -------------------------
- -- Equivalent_Key_Node --
- -------------------------
-
- function Equivalent_Key_Node
- (Key : Key_Type;
- Node : Node_Type) return Boolean
- is
- begin
- return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
- end Equivalent_Key_Node;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Set; Key : Key_Type) is
- X : Count_Type;
- begin
- Key_Keys.Delete_Key_Sans_Free (Container.Content, Key, X);
- Free (Container, X);
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : Set;
- Key : Key_Type) return Cursor
- is
- Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
- begin
- return (if Node = 0 then No_Element else (Node => Node));
- end Find;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -----------------------
- -- M_Included_Except --
- -----------------------
-
- function M_Included_Except
- (Left : M.Set;
- Right : M.Set;
- Key : Key_Type) return Boolean
- is
- begin
- for E of Left loop
- if not Contains (Right, E)
- and not Equivalent_Keys (Generic_Keys.Key (E), Key)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Included_Except;
-
- end Formal_Model;
-
- ---------
- -- Key --
- ---------
-
- function Key (Container : Set; Position : Cursor) return Key_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in function Key");
-
- declare
- N : Node_Type renames Container.Content.Nodes (Position.Node);
- begin
- return Key (N.Element);
- end;
- end Key;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace
- (Container : in out Set;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- raise Constraint_Error with "attempt to replace key not in set";
- end if;
-
- Replace_Element (Container.Content, Node, New_Item);
- end Replace;
-
- end Generic_Keys;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : Set; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0
- or else not Container.Content.Nodes (Position.Node).Has_Element
- then
- return False;
- end if;
-
- return True;
- end Has_Element;
-
- ---------------
- -- Hash_Node --
- ---------------
-
- function Hash_Node (Node : Node_Type) return Hash_Type is
- begin
- return Hash (Node.Element);
- end Hash_Node;
-
- -------------
- -- Include --
- -------------
-
- procedure Include (Container : in out Set; New_Item : Element_Type) is
- Inserted : Boolean;
- Position : Cursor;
-
- begin
- Insert (Container, New_Item, Position, Inserted);
-
- if not Inserted then
- Container.Content.Nodes (Position.Node).Element := New_Item;
- end if;
- end Include;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- is
- begin
- Insert (Container, New_Item, Position.Node, Inserted);
- end Insert;
-
- procedure Insert (Container : in out Set; New_Item : Element_Type) is
- Inserted : Boolean;
- Unused_Position : Cursor;
-
- begin
- Insert (Container, New_Item, Unused_Position, Inserted);
-
- if not Inserted then
- raise Constraint_Error with
- "attempt to insert element already in set";
- end if;
- end Insert;
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Node : out Count_Type;
- Inserted : out Boolean)
- is
- procedure Allocate_Set_Element (Node : in out Node_Type);
- pragma Inline (Allocate_Set_Element);
-
- procedure New_Node
- (HT : in out Hash_Table_Type;
- Node : out Count_Type);
- pragma Inline (New_Node);
-
- procedure Local_Insert is
- new Element_Keys.Generic_Conditional_Insert (New_Node);
-
- procedure Allocate is
- new Generic_Allocate (Allocate_Set_Element);
-
- ---------------------------
- -- Allocate_Set_Element --
- ---------------------------
-
- procedure Allocate_Set_Element (Node : in out Node_Type) is
- begin
- Node.Element := New_Item;
- end Allocate_Set_Element;
-
- --------------
- -- New_Node --
- --------------
-
- procedure New_Node
- (HT : in out Hash_Table_Type;
- Node : out Count_Type)
- is
- begin
- Allocate (HT, Node);
- end New_Node;
-
- -- Start of processing for Insert
-
- begin
- Local_Insert (Container.Content, New_Item, Node, Inserted);
- end Insert;
-
- ------------------
- -- Intersection --
- ------------------
-
- procedure Intersection (Target : in out Set; Source : Set) is
- Tgt_Node : Count_Type;
- TN : Nodes_Type renames Target.Content.Nodes;
-
- begin
- if Source.Content.Length = 0 then
- Clear (Target);
- return;
- end if;
-
- Tgt_Node := HT_Ops.First (Target.Content);
- while Tgt_Node /= 0 loop
- if Find (Source, TN (Tgt_Node).Element).Node /= 0 then
- Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
-
- else
- declare
- X : constant Count_Type := Tgt_Node;
- begin
- Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target.Content, X);
- Free (Target, X);
- end;
- end if;
- end loop;
- end Intersection;
-
- procedure Intersection (Left : Set; Right : Set; Target : in out Set) is
- procedure Process (L_Node : Count_Type);
-
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
-
- -------------
- -- Process --
- -------------
-
- procedure Process (L_Node : Count_Type) is
- E : Element_Type renames Left.Content.Nodes (L_Node).Element;
- Unused_X : Count_Type;
- B : Boolean;
-
- begin
- if Find (Right, E).Node /= 0 then
- Insert (Target, E, Unused_X, B);
- pragma Assert (B);
- end if;
- end Process;
-
- -- Start of processing for Intersection
-
- begin
- Iterate (Left.Content);
- end Intersection;
-
- function Intersection (Left : Set; Right : Set) return Set is
- C : constant Count_Type :=
- Count_Type'Min (Length (Left), Length (Right)); -- ???
- H : constant Hash_Type := Default_Modulus (C);
-
- begin
- return S : Set (C, H) do
- if Length (Left) /= 0 and Length (Right) /= 0 then
- Intersection (Left, Right, Target => S);
- end if;
- end return;
- end Intersection;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Set) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- -----------
- -- Is_In --
- -----------
-
- function Is_In (HT : Set; Key : Node_Type) return Boolean is
- begin
- return Element_Keys.Find (HT.Content, Key.Element) /= 0;
- end Is_In;
-
- ---------------
- -- Is_Subset --
- ---------------
-
- function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
- Subset_Node : Count_Type;
- Subset_Nodes : Nodes_Type renames Subset.Content.Nodes;
-
- begin
- if Length (Subset) > Length (Of_Set) then
- return False;
- end if;
-
- Subset_Node := First (Subset).Node;
- while Subset_Node /= 0 loop
- declare
- S : constant Count_Type := Subset_Node;
- N : Node_Type renames Subset_Nodes (S);
- E : Element_Type renames N.Element;
-
- begin
- if Find (Of_Set, E).Node = 0 then
- return False;
- end if;
- end;
-
- Subset_Node := HT_Ops.Next (Subset.Content, Subset_Node);
- end loop;
-
- return True;
- end Is_Subset;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Set) return Count_Type is
- begin
- return Container.Content.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- -- Comments???
-
- procedure Move (Target : in out Set; Source : in out Set) is
- NN : HT_Types.Nodes_Type renames Source.Content.Nodes;
- X, Y : Count_Type;
-
- begin
- if Target.Capacity < Length (Source) then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- if Source.Content.Length = 0 then
- return;
- end if;
-
- X := HT_Ops.First (Source.Content);
- while X /= 0 loop
- Insert (Target, NN (X).Element); -- optimize???
-
- Y := HT_Ops.Next (Source.Content, X);
-
- HT_Ops.Delete_Node_Sans_Free (Source.Content, X);
- Free (Source, X);
-
- X := Y;
- end loop;
- end Move;
-
- ----------
- -- Next --
- ----------
-
- function Next (Node : Node_Type) return Count_Type is
- begin
- return Node.Next;
- end Next;
-
- function Next (Container : Set; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in Next");
-
- return (Node => HT_Ops.Next (Container.Content, Position.Node));
- end Next;
-
- procedure Next (Container : Set; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- -------------
- -- Overlap --
- -------------
-
- function Overlap (Left, Right : Set) return Boolean is
- Left_Node : Count_Type;
- Left_Nodes : Nodes_Type renames Left.Content.Nodes;
-
- begin
- if Length (Right) = 0 or Length (Left) = 0 then
- return False;
- end if;
-
- Left_Node := First (Left).Node;
- while Left_Node /= 0 loop
- declare
- L : constant Count_Type := Left_Node;
- N : Node_Type renames Left_Nodes (L);
- E : Element_Type renames N.Element;
- begin
- if Find (Right, E).Node /= 0 then
- return True;
- end if;
- end;
-
- Left_Node := HT_Ops.Next (Left.Content, Left_Node);
- end loop;
-
- return False;
- end Overlap;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace (Container : in out Set; New_Item : Element_Type) is
- Node : constant Count_Type :=
- Element_Keys.Find (Container.Content, New_Item);
-
- begin
- if Node = 0 then
- raise Constraint_Error with "attempt to replace element not in set";
- end if;
-
- Container.Content.Nodes (Node).Element := New_Item;
- end Replace;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out Set;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor equals No_Element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in Replace_Element");
-
- Replace_Element (Container.Content, Position.Node, New_Item);
- end Replace_Element;
-
- ----------------------
- -- Reserve_Capacity --
- ----------------------
-
- procedure Reserve_Capacity
- (Container : in out Set;
- Capacity : Count_Type)
- is
- begin
- if Capacity > Container.Capacity then
- raise Constraint_Error with "requested capacity is too large";
- end if;
- end Reserve_Capacity;
-
- ------------------
- -- Set_Element --
- ------------------
-
- procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is
- begin
- Node.Element := Item;
- end Set_Element;
-
- --------------
- -- Set_Next --
- --------------
-
- procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
- begin
- Node.Next := Next;
- end Set_Next;
-
- --------------------------
- -- Symmetric_Difference --
- --------------------------
-
- procedure Symmetric_Difference (Target : in out Set; Source : Set) is
- procedure Process (Source_Node : Count_Type);
- pragma Inline (Process);
-
- procedure Iterate is new HT_Ops.Generic_Iteration (Process);
-
- -------------
- -- Process --
- -------------
-
- procedure Process (Source_Node : Count_Type) is
- B : Boolean;
- N : Node_Type renames Source.Content.Nodes (Source_Node);
- Unused_X : Count_Type;
-
- begin
- if Is_In (Target, N) then
- Delete (Target, N.Element);
- else
- Insert (Target, N.Element, Unused_X, B);
- pragma Assert (B);
- end if;
- end Process;
-
- -- Start of processing for Symmetric_Difference
-
- begin
- if Length (Target) = 0 then
- Assign (Target, Source);
- return;
- end if;
-
- Iterate (Source.Content);
- end Symmetric_Difference;
-
- function Symmetric_Difference (Left : Set; Right : Set) return Set is
- begin
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- if Length (Left) = 0 then
- return Copy (Right);
- end if;
-
- declare
- C : constant Count_Type := Length (Left) + Length (Right);
- H : constant Hash_Type := Default_Modulus (C);
- begin
- return S : Set (C, H) do
- Difference (Left, Right, S);
- Difference (Right, Left, S);
- end return;
- end;
- end Symmetric_Difference;
-
- ------------
- -- To_Set --
- ------------
-
- function To_Set (New_Item : Element_Type) return Set is
- Unused_X : Count_Type;
- B : Boolean;
-
- begin
- return S : Set (Capacity => 1, Modulus => 1) do
- Insert (S, New_Item, Unused_X, B);
- pragma Assert (B);
- end return;
- end To_Set;
-
- -----------
- -- Union --
- -----------
-
- procedure Union (Target : in out Set; Source : Set) is
- procedure Process (Src_Node : Count_Type);
-
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
-
- -------------
- -- Process --
- -------------
-
- procedure Process (Src_Node : Count_Type) is
- N : Node_Type renames Source.Content.Nodes (Src_Node);
- E : Element_Type renames N.Element;
-
- Unused_X : Count_Type;
- Unused_B : Boolean;
-
- begin
- Insert (Target, E, Unused_X, Unused_B);
- end Process;
-
- -- Start of processing for Union
-
- begin
- Iterate (Source.Content);
- end Union;
-
- function Union (Left : Set; Right : Set) return Set is
- begin
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- if Length (Left) = 0 then
- return Copy (Right);
- end if;
-
- declare
- C : constant Count_Type := Length (Left) + Length (Right);
- H : constant Hash_Type := Default_Modulus (C);
- begin
- return S : Set (C, H) do
- Assign (Target => S, Source => Left);
- Union (Target => S, Source => Right);
- end return;
- end;
- end Union;
-
- ---------
- -- Vet --
- ---------
-
- function Vet (Container : Set; Position : Cursor) return Boolean is
- begin
- if not Container_Checks'Enabled then
- return True;
- end if;
-
- if Position.Node = 0 then
- return True;
- end if;
-
- declare
- S : Set renames Container;
- N : Nodes_Type renames S.Content.Nodes;
- X : Count_Type;
-
- begin
- if S.Content.Length = 0 then
- return False;
- end if;
-
- if Position.Node > N'Last then
- return False;
- end if;
-
- if N (Position.Node).Next = Position.Node then
- return False;
- end if;
-
- X := S.Content.Buckets
- (Element_Keys.Index (S.Content, N (Position.Node).Element));
-
- for J in 1 .. S.Content.Length loop
- if X = Position.Node then
- return True;
- end if;
-
- if X = 0 then
- return False;
- end if;
-
- if X = N (X).Next then -- to prevent unnecessary looping
- return False;
- end if;
-
- X := N (X).Next;
- end loop;
-
- return False;
- end;
- end Vet;
-
-end Ada.Containers.Formal_Hashed_Sets;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- This spec is derived from package Ada.Containers.Bounded_Hashed_Sets in the
--- Ada 2012 RM. The modifications are meant to facilitate formal proofs by
--- making it easier to express properties, and by making the specification of
--- this unit compatible with SPARK 2014. Note that the API of this unit may be
--- subject to incompatible changes as SPARK 2014 evolves.
-
--- The modifications are:
-
--- A parameter for the container is added to every function reading the
--- content of a container: Element, Next, Query_Element, Has_Element, Key,
--- Iterate, Equivalent_Elements. This change is motivated by the need to
--- have cursors which are valid on different containers (typically a
--- container C and its previous version C'Old) for expressing properties,
--- which is not possible if cursors encapsulate an access to the underlying
--- container.
-
-with Ada.Containers.Functional_Maps;
-with Ada.Containers.Functional_Sets;
-with Ada.Containers.Functional_Vectors;
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-private with Ada.Containers.Hash_Tables;
-
generic
- type Element_Type is private;
-
- with function Hash (Element : Element_Type) return Hash_Type;
-
- with function Equivalent_Elements
- (Left : Element_Type;
- Right : Element_Type) return Boolean is "=";
-
-package Ada.Containers.Formal_Hashed_Sets with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- -- Convert Count_Type to Big_Interger.
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
-
- function Big (J : Count_Type) return Big_Integer renames
- Conversions.To_Big_Integer;
-
- type Set (Capacity : Count_Type; Modulus : Hash_Type) is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Element),
- Default_Initial_Condition => Is_Empty (Set);
- pragma Preelaborable_Initialization (Set);
-
- type Cursor is record
- Node : Count_Type;
- end record;
-
- No_Element : constant Cursor := (Node => 0);
-
- function Length (Container : Set) return Count_Type with
- Global => null,
- Post => Length'Result <= Container.Capacity;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Sets
- (Element_Type => Element_Type,
- Equivalent_Elements => Equivalent_Elements);
-
- function "="
- (Left : M.Set;
- Right : M.Set) return Boolean renames M."=";
-
- function "<="
- (Left : M.Set;
- Right : M.Set) return Boolean renames M."<=";
-
- package E is new Ada.Containers.Functional_Vectors
- (Element_Type => Element_Type,
- Index_Type => Positive_Count_Type);
-
- function "="
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."=";
-
- function "<"
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."<";
-
- function "<="
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."<=";
-
- function Find
- (Container : E.Sequence;
- Item : Element_Type) return Count_Type
- -- Search for Item in Container
-
- with
- Global => null,
- Post =>
- (if Find'Result > 0 then
- Find'Result <= E.Length (Container)
- and Equivalent_Elements
- (Item, E.Get (Container, Find'Result)));
-
- function E_Elements_Included
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean
- -- The elements of Left are contained in Right
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Left) =>
- Find (Right, E.Get (Left, I)) > 0
- and then E.Get (Right, Find (Right, E.Get (Left, I))) =
- E.Get (Left, I));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- function E_Elements_Included
- (Left : E.Sequence;
- Model : M.Set;
- Right : E.Sequence) return Boolean
- -- The elements of Container contained in Model are in Right
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Left) =>
- (if M.Contains (Model, E.Get (Left, I)) then
- Find (Right, E.Get (Left, I)) > 0
- and then E.Get (Right, Find (Right, E.Get (Left, I))) =
- E.Get (Left, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- function E_Elements_Included
- (Container : E.Sequence;
- Model : M.Set;
- Left : E.Sequence;
- Right : E.Sequence) return Boolean
- -- The elements of Container contained in Model are in Left and others
- -- are in Right.
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Container) =>
- (if M.Contains (Model, E.Get (Container, I)) then
- Find (Left, E.Get (Container, I)) > 0
- and then E.Get (Left, Find (Left, E.Get (Container, I))) =
- E.Get (Container, I)
- else
- Find (Right, E.Get (Container, I)) > 0
- and then E.Get
- (Right, Find (Right, E.Get (Container, I))) =
- E.Get (Container, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function Mapping_Preserved
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved'Result then
-
- -- Right contains all the cursors of Left
-
- P.Keys_Included (P_Left, P_Right)
-
- -- Right contains all the elements of Left
-
- and E_Elements_Included (E_Left, E_Right)
-
- -- Mappings from cursors to elements induced by E_Left, P_Left
- -- and E_Right, P_Right are the same.
-
- and (for all C of P_Left =>
- E.Get (E_Left, P.Get (P_Left, C)) =
- E.Get (E_Right, P.Get (P_Right, C))));
-
- function Mapping_Preserved_Except
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map;
- Position : Cursor) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved_Except'Result then
-
- -- Right contains all the cursors of Left
-
- P.Keys_Included (P_Left, P_Right)
-
- -- Mappings from cursors to elements induced by E_Left, P_Left
- -- and E_Right, P_Right are the same except for Position.
-
- and (for all C of P_Left =>
- (if C /= Position then
- E.Get (E_Left, P.Get (P_Left, C)) =
- E.Get (E_Right, P.Get (P_Right, C)))));
-
- function Model (Container : Set) return M.Set with
- -- The high-level model of a set is a set of elements. Neither cursors
- -- nor order of elements are represented in this model. Elements are
- -- modeled up to equivalence.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Big (Length (Container));
-
- function Elements (Container : Set) return E.Sequence with
- -- The Elements sequence represents the underlying list structure of
- -- sets that is used for iteration. It stores the actual values of
- -- elements in the set. It does not model cursors.
-
- Ghost,
- Global => null,
- Post =>
- E.Length (Elements'Result) = Length (Container)
-
- -- It only contains keys contained in Model
-
- and (for all Item of Elements'Result =>
- M.Contains (Model (Container), Item))
-
- -- It contains all the elements contained in Model
-
- and (for all Item of Model (Container) =>
- (Find (Elements'Result, Item) > 0
- and then Equivalent_Elements
- (E.Get (Elements'Result,
- Find (Elements'Result, Item)),
- Item)))
-
- -- It has no duplicate
-
- and (for all I in 1 .. Length (Container) =>
- Find (Elements'Result, E.Get (Elements'Result, I)) = I)
-
- and (for all I in 1 .. Length (Container) =>
- (for all J in 1 .. Length (Container) =>
- (if Equivalent_Elements
- (E.Get (Elements'Result, I),
- E.Get (Elements'Result, J))
- then I = J)));
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements);
-
- function Positions (Container : Set) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and maps them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : Set) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level, cursor-aware view of a container, to a high-level,
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Item of Elements (Container) =>
- (for some I of Positions (Container) =>
- E.Get (Elements (Container), P.Get (Positions (Container), I)) =
- Item));
-
- function Contains
- (C : M.Set;
- K : Element_Type) return Boolean renames M.Contains;
- -- To improve readability of contracts, we rename the function used to
- -- search for an element in the model to Contains.
-
- end Formal_Model;
- use Formal_Model;
-
- Empty_Set : constant Set;
-
- function "=" (Left, Right : Set) return Boolean with
- Global => null,
- Post =>
- "="'Result =
- (Length (Left) = Length (Right)
- and E_Elements_Included (Elements (Left), Elements (Right)))
- and
- "="'Result =
- (E_Elements_Included (Elements (Left), Elements (Right))
- and E_Elements_Included (Elements (Right), Elements (Left)));
- -- For each element in Left, set equality attempts to find the equal
- -- element in Right; if a search fails, then set equality immediately
- -- returns False. The search works by calling Hash to find the bucket in
- -- the Right set that corresponds to the Left element. If the bucket is
- -- non-empty, the search calls the generic formal element equality operator
- -- to compare the element (in Left) to the element of each node in the
- -- bucket (in Right); the search terminates when a matching node in the
- -- bucket is found, or the nodes in the bucket are exhausted. (Note that
- -- element equality is called here, not Equivalent_Elements. Set equality
- -- is the only operation in which element equality is used. Compare set
- -- equality to Equivalent_Sets, which does call Equivalent_Elements.)
-
- function Equivalent_Sets (Left, Right : Set) return Boolean with
- Global => null,
- Post => Equivalent_Sets'Result = (Model (Left) = Model (Right));
- -- Similar to set equality, with the difference that the element in Left is
- -- compared to the elements in Right using the generic formal
- -- Equivalent_Elements operation instead of element equality.
-
- function To_Set (New_Item : Element_Type) return Set with
- Global => null,
- Post =>
- M.Is_Singleton (Model (To_Set'Result), New_Item)
- and Length (To_Set'Result) = 1
- and E.Get (Elements (To_Set'Result), 1) = New_Item;
- -- Constructs a singleton set comprising New_Element. To_Set calls Hash to
- -- determine the bucket for New_Item.
-
- function Capacity (Container : Set) return Count_Type with
- Global => null,
- Post => Capacity'Result = Container.Capacity;
- -- Returns the current capacity of the set. Capacity is the maximum length
- -- before which rehashing in guaranteed not to occur.
-
- procedure Reserve_Capacity
- (Container : in out Set;
- Capacity : Count_Type)
- with
- Global => null,
- Pre => Capacity <= Container.Capacity,
- Post =>
- Model (Container) = Model (Container)'Old
- and Length (Container)'Old = Length (Container)
-
- -- Actual elements are preserved
-
- and E_Elements_Included
- (Elements (Container), Elements (Container)'Old)
- and E_Elements_Included
- (Elements (Container)'Old, Elements (Container));
- -- If the value of the Capacity actual parameter is less or equal to
- -- Container.Capacity, then the operation has no effect. Otherwise it
- -- raises Capacity_Error (as no expansion of capacity is possible for a
- -- bounded form).
-
- function Is_Empty (Container : Set) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
- -- Equivalent to Length (Container) = 0
-
- procedure Clear (Container : in out Set) with
- Global => null,
- Post => Length (Container) = 0 and M.Is_Empty (Model (Container));
- -- Removes all of the items from the set. This will deallocate all memory
- -- associated with this set.
-
- procedure Assign (Target : in out Set; Source : Set) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)
- and Length (Target) = Length (Source)
-
- -- Actual elements are preserved
-
- and E_Elements_Included (Elements (Target), Elements (Source))
- and E_Elements_Included (Elements (Source), Elements (Target));
- -- If Target denotes the same object as Source, then the operation has no
- -- effect. If the Target capacity is less than the Source length, then
- -- Assign raises Capacity_Error. Otherwise, Assign clears Target and then
- -- copies the (active) elements from Source to Target.
-
- function Copy
- (Source : Set;
- Capacity : Count_Type := 0) return Set
- with
- Global => null,
- Pre => Capacity = 0 or else Capacity >= Source.Capacity,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Elements (Copy'Result) = Elements (Source)
- and Positions (Copy'Result) = Positions (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Source.Capacity
- else
- Copy'Result.Capacity = Capacity);
- -- Constructs a new set object whose elements correspond to Source. If the
- -- Capacity parameter is 0, then the capacity of the result is the same as
- -- the length of Source. If the Capacity parameter is equal or greater than
- -- the length of Source, then the capacity of the result is the specified
- -- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter
- -- is 0, then the modulus of the result is the value returned by a call to
- -- Default_Modulus with the capacity parameter determined as above;
- -- otherwise the modulus of the result is the specified value.
-
- function Element
- (Container : Set;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result =
- E.Get (Elements (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Set;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Position now maps to New_Item
-
- and Element (Container, Position) = New_Item
-
- -- New_Item is contained in Container
-
- and Contains (Model (Container), New_Item)
-
- -- Other elements are preserved
-
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Element (Container, Position)'Old)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved_Except
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container),
- Position => Position)
- and Positions (Container) = Positions (Container)'Old;
-
- function Constant_Reference
- (Container : aliased Set;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- E.Get (Elements (Container), P.Get (Positions (Container), Position));
-
- procedure Move (Target : in out Set; Source : in out Set) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Length (Source) = 0
- and Model (Target) = Model (Source)'Old
- and Length (Target) = Length (Source)'Old
-
- -- Actual elements are preserved
-
- and E_Elements_Included (Elements (Target), Elements (Source)'Old)
- and E_Elements_Included (Elements (Source)'Old, Elements (Target));
- -- Clears Target (if it's not empty), and then moves (not copies) the
- -- buckets array and nodes from Source to Target.
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- or Contains (Container, New_Item),
- Post =>
- Contains (Container, New_Item)
- and Has_Element (Container, Position)
- and Equivalent_Elements (Element (Container, Position), New_Item),
- Contract_Cases =>
-
- -- If New_Item is already in Container, it is not modified and Inserted
- -- is set to False.
-
- (Contains (Container, New_Item) =>
- not Inserted
- and Model (Container) = Model (Container)'Old
- and Elements (Container) = Elements (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, New_Item is inserted in Container and Inserted is set to
- -- True.
-
- others =>
- Inserted
- and Length (Container) = Length (Container)'Old + 1
-
- -- Position now maps to New_Item
-
- and Element (Container, Position) = New_Item
-
- -- Other elements are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Position));
- -- Conditionally inserts New_Item into the set. If New_Item is already in
- -- the set, then Inserted returns False and Position designates the node
- -- containing the existing element (which is not modified). If New_Item is
- -- not already in the set, then Inserted returns True and Position
- -- designates the newly-inserted node containing New_Item. The search for
- -- an existing element works as follows. Hash is called to determine
- -- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements
- -- is called to compare New_Item to the element of each node in that
- -- bucket. If the bucket is empty, or there were no equivalent elements in
- -- the bucket, the search "fails" and the New_Item is inserted in the set
- -- (and Inserted returns True); otherwise, the search "succeeds" (and
- -- Inserted returns False).
-
- procedure Insert (Container : in out Set; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Container.Capacity
- and then (not Contains (Container, New_Item)),
- Post =>
- Length (Container) = Length (Container)'Old + 1
- and Contains (Container, New_Item)
- and Element (Container, Find (Container, New_Item)) = New_Item
-
- -- Other elements are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Find (Container, New_Item));
- -- Attempts to insert New_Item into the set, performing the usual insertion
- -- search (which involves calling both Hash and Equivalent_Elements); if
- -- the search succeeds (New_Item is equivalent to an element already in the
- -- set, and so was not inserted), then this operation raises
- -- Constraint_Error. (This version of Insert is similar to Replace, but
- -- having the opposite exception behavior. It is intended for use when you
- -- want to assert that the item is not already in the set.)
-
- procedure Include (Container : in out Set; New_Item : Element_Type) with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- or Contains (Container, New_Item),
- Post =>
- Contains (Container, New_Item)
- and Element (Container, Find (Container, New_Item)) = New_Item,
- Contract_Cases =>
-
- -- If an element equivalent to New_Item is already in Container, it is
- -- replaced by New_Item.
-
- (Contains (Container, New_Item) =>
-
- -- Elements are preserved modulo equivalence
-
- Model (Container) = Model (Container)'Old
-
- -- Cursors are preserved
-
- and Positions (Container) = Positions (Container)'Old
-
- -- The actual value of other elements is preserved
-
- and E.Equal_Except
- (Elements (Container)'Old,
- Elements (Container),
- P.Get (Positions (Container), Find (Container, New_Item))),
-
- -- Otherwise, New_Item is inserted in Container
-
- others =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Other elements are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container))
- and P.Keys_Included_Except
- (Positions (Container),
- Positions (Container)'Old,
- Find (Container, New_Item)));
- -- Attempts to insert New_Item into the set. If an element equivalent to
- -- New_Item is already in the set (the insertion search succeeded, and
- -- hence New_Item was not inserted), then the value of New_Item is assigned
- -- to the existing element. (This insertion operation only raises an
- -- exception if cursor tampering occurs. It is intended for use when you
- -- want to insert the item in the set, and you don't care whether an
- -- equivalent element is already present.)
-
- procedure Replace (Container : in out Set; New_Item : Element_Type) with
- Global => null,
- Pre => Contains (Container, New_Item),
- Post =>
-
- -- Elements are preserved modulo equivalence
-
- Model (Container) = Model (Container)'Old
- and Contains (Container, New_Item)
-
- -- Cursors are preserved
-
- and Positions (Container) = Positions (Container)'Old
-
- -- The element equivalent to New_Item in Container is replaced by
- -- New_Item.
-
- and Element (Container, Find (Container, New_Item)) = New_Item
- and E.Equal_Except
- (Elements (Container)'Old,
- Elements (Container),
- P.Get (Positions (Container), Find (Container, New_Item)));
- -- Searches for New_Item in the set; if the search fails (because an
- -- equivalent element was not in the set), then it raises
- -- Constraint_Error. Otherwise, the existing element is assigned the value
- -- New_Item. (This is similar to Insert, but with the opposite exception
- -- behavior. It is intended for use when you want to assert that the item
- -- is already in the set.)
-
- procedure Exclude (Container : in out Set; Item : Element_Type) with
- Global => null,
- Post => not Contains (Container, Item),
- Contract_Cases =>
-
- -- If Item is not in Container, nothing is changed
-
- (not Contains (Container, Item) =>
- Model (Container) = Model (Container)'Old
- and Elements (Container) = Elements (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Item is removed from Container
-
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container),
- E_Right => Elements (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Item)'Old));
- -- Searches for Item in the set, and if found, removes its node from the
- -- set and then deallocates it. The search works as follows. The operation
- -- calls Hash to determine the item's bucket; if the bucket is not empty,
- -- it calls Equivalent_Elements to compare Item to the element of each node
- -- in the bucket. (This is the deletion analog of Include. It is intended
- -- for use when you want to remove the item from the set, but don't care
- -- whether the item is already in the set.)
-
- procedure Delete (Container : in out Set; Item : Element_Type) with
- Global => null,
- Pre => Contains (Container, Item),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Item is no longer in Container
-
- and not Contains (Container, Item)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container),
- E_Right => Elements (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Item)'Old);
- -- Searches for Item in the set (which involves calling both Hash and
- -- Equivalent_Elements). If the search fails, then the operation raises
- -- Constraint_Error. Otherwise it removes the node from the set and then
- -- deallocates it. (This is the deletion analog of non-conditional
- -- Insert. It is intended for use when you want to assert that the item is
- -- already in the set.)
-
- procedure Delete (Container : in out Set; Position : in out Cursor) with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Position = No_Element
- and Length (Container) = Length (Container)'Old - 1
-
- -- The element at position Position is no longer in Container
-
- and not Contains (Container, Element (Container, Position)'Old)
- and not P.Has_Key (Positions (Container), Position'Old)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Element (Container, Position)'Old)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container),
- E_Right => Elements (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Position'Old);
- -- Removes the node designated by Position from the set, and then
- -- deallocates the node. The operation calls Hash to determine the bucket,
- -- and then compares Position to each node in the bucket until there's a
- -- match (it does not call Equivalent_Elements).
-
- procedure Union (Target : in out Set; Source : Set) with
- Global => null,
- Pre =>
- Length (Source) - Length (Target and Source) <=
- Target.Capacity - Length (Target),
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old)
- - M.Num_Overlaps (Model (Target)'Old, Model (Source))
- + Big (Length (Source))
-
- -- Elements already in Target are still in Target
-
- and Model (Target)'Old <= Model (Target)
-
- -- Elements of Source are included in Target
-
- and Model (Source) <= Model (Target)
-
- -- Elements of Target come from either Source or Target
-
- and M.Included_In_Union
- (Model (Target), Model (Source), Model (Target)'Old)
-
- -- Actual value of elements come from either Left or Right
-
- and E_Elements_Included
- (Elements (Target),
- Model (Target)'Old,
- Elements (Target)'Old,
- Elements (Source))
-
- and E_Elements_Included
- (Elements (Target)'Old, Model (Target)'Old, Elements (Target))
-
- and E_Elements_Included
- (Elements (Source),
- Model (Target)'Old,
- Elements (Source),
- Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target)'Old,
- E_Right => Elements (Target),
- P_Left => Positions (Target)'Old,
- P_Right => Positions (Target));
- -- Iterates over the Source set, and conditionally inserts each element
- -- into Target.
-
- function Union (Left, Right : Set) return Set with
- Global => null,
- Pre => Length (Left) <= Count_Type'Last - Length (Right),
- Post =>
- Big (Length (Union'Result)) = Big (Length (Left))
- - M.Num_Overlaps (Model (Left), Model (Right))
- + Big (Length (Right))
-
- -- Elements of Left and Right are in the result of Union
-
- and Model (Left) <= Model (Union'Result)
- and Model (Right) <= Model (Union'Result)
-
- -- Elements of the result of union come from either Left or Right
-
- and
- M.Included_In_Union
- (Model (Union'Result), Model (Left), Model (Right))
-
- -- Actual value of elements come from either Left or Right
-
- and E_Elements_Included
- (Elements (Union'Result),
- Model (Left),
- Elements (Left),
- Elements (Right))
-
- and E_Elements_Included
- (Elements (Left), Model (Left), Elements (Union'Result))
-
- and E_Elements_Included
- (Elements (Right),
- Model (Left),
- Elements (Right),
- Elements (Union'Result));
- -- The operation first copies the Left set to the result, and then iterates
- -- over the Right set to conditionally insert each element into the result.
-
- function "or" (Left, Right : Set) return Set renames Union;
-
- procedure Intersection (Target : in out Set; Source : Set) with
- Global => null,
- Post =>
- Big (Length (Target)) =
- M.Num_Overlaps (Model (Target)'Old, Model (Source))
-
- -- Elements of Target were already in Target
-
- and Model (Target) <= Model (Target)'Old
-
- -- Elements of Target are in Source
-
- and Model (Target) <= Model (Source)
-
- -- Elements both in Source and Target are in the intersection
-
- and M.Includes_Intersection
- (Model (Target), Model (Source), Model (Target)'Old)
-
- -- Actual value of elements of Target is preserved
-
- and E_Elements_Included (Elements (Target), Elements (Target)'Old)
- and E_Elements_Included
- (Elements (Target)'Old, Model (Source), Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target),
- E_Right => Elements (Target)'Old,
- P_Left => Positions (Target),
- P_Right => Positions (Target)'Old);
- -- Iterates over the Target set (calling First and Next), calling Find to
- -- determine whether the element is in Source. If an equivalent element is
- -- not found in Source, the element is deleted from Target.
-
- function Intersection (Left, Right : Set) return Set with
- Global => null,
- Post =>
- Big (Length (Intersection'Result)) =
- M.Num_Overlaps (Model (Left), Model (Right))
-
- -- Elements in the result of Intersection are in Left and Right
-
- and Model (Intersection'Result) <= Model (Left)
- and Model (Intersection'Result) <= Model (Right)
-
- -- Elements both in Left and Right are in the result of Intersection
-
- and M.Includes_Intersection
- (Model (Intersection'Result), Model (Left), Model (Right))
-
- -- Actual value of elements come from Left
-
- and E_Elements_Included
- (Elements (Intersection'Result), Elements (Left))
-
- and E_Elements_Included
- (Elements (Left), Model (Right),
- Elements (Intersection'Result));
- -- Iterates over the Left set, calling Find to determine whether the
- -- element is in Right. If an equivalent element is found, it is inserted
- -- into the result set.
-
- function "and" (Left, Right : Set) return Set renames Intersection;
-
- procedure Difference (Target : in out Set; Source : Set) with
- Global => null,
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old) -
- M.Num_Overlaps (Model (Target)'Old, Model (Source))
-
- -- Elements of Target were already in Target
-
- and Model (Target) <= Model (Target)'Old
-
- -- Elements of Target are not in Source
-
- and M.No_Overlap (Model (Target), Model (Source))
-
- -- Elements in Target but not in Source are in the difference
-
- and M.Included_In_Union
- (Model (Target)'Old, Model (Target), Model (Source))
-
- -- Actual value of elements of Target is preserved
-
- and E_Elements_Included (Elements (Target), Elements (Target)'Old)
- and E_Elements_Included
- (Elements (Target)'Old, Model (Target), Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target),
- E_Right => Elements (Target)'Old,
- P_Left => Positions (Target),
- P_Right => Positions (Target)'Old);
- -- Iterates over the Source (calling First and Next), calling Find to
- -- determine whether the element is in Target. If an equivalent element is
- -- found, it is deleted from Target.
-
- function Difference (Left, Right : Set) return Set with
- Global => null,
- Post =>
- Big (Length (Difference'Result)) = Big (Length (Left)) -
- M.Num_Overlaps (Model (Left), Model (Right))
-
- -- Elements of the result of Difference are in Left
-
- and Model (Difference'Result) <= Model (Left)
-
- -- Elements of the result of Difference are in Right
-
- and M.No_Overlap (Model (Difference'Result), Model (Right))
-
- -- Elements in Left but not in Right are in the difference
-
- and M.Included_In_Union
- (Model (Left), Model (Difference'Result), Model (Right))
-
- -- Actual value of elements come from Left
-
- and E_Elements_Included
- (Elements (Difference'Result), Elements (Left))
-
- and E_Elements_Included
- (Elements (Left),
- Model (Difference'Result),
- Elements (Difference'Result));
- -- Iterates over the Left set, calling Find to determine whether the
- -- element is in the Right set. If an equivalent element is not found, the
- -- element is inserted into the result set.
-
- function "-" (Left, Right : Set) return Set renames Difference;
-
- procedure Symmetric_Difference (Target : in out Set; Source : Set) with
- Global => null,
- Pre =>
- Length (Source) - Length (Target and Source) <=
- Target.Capacity - Length (Target) + Length (Target and Source),
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old) -
- 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) +
- Big (Length (Source))
-
- -- Elements of the difference were not both in Source and in Target
-
- and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source))
-
- -- Elements in Target but not in Source are in the difference
-
- and M.Included_In_Union
- (Model (Target)'Old, Model (Target), Model (Source))
-
- -- Elements in Source but not in Target are in the difference
-
- and M.Included_In_Union
- (Model (Source), Model (Target), Model (Target)'Old)
-
- -- Actual value of elements come from either Left or Right
-
- and E_Elements_Included
- (Elements (Target),
- Model (Target)'Old,
- Elements (Target)'Old,
- Elements (Source))
-
- and E_Elements_Included
- (Elements (Target)'Old, Model (Target), Elements (Target))
-
- and E_Elements_Included
- (Elements (Source), Model (Target), Elements (Target));
- -- The operation iterates over the Source set, searching for the element
- -- in Target (calling Hash and Equivalent_Elements). If an equivalent
- -- element is found, it is removed from Target; otherwise it is inserted
- -- into Target.
-
- function Symmetric_Difference (Left, Right : Set) return Set with
- Global => null,
- Pre => Length (Left) <= Count_Type'Last - Length (Right),
- Post =>
- Big (Length (Symmetric_Difference'Result)) = Big (Length (Left)) -
- 2 * M.Num_Overlaps (Model (Left), Model (Right)) +
- Big (Length (Right))
-
- -- Elements of the difference were not both in Left and Right
-
- and M.Not_In_Both
- (Model (Symmetric_Difference'Result),
- Model (Left),
- Model (Right))
-
- -- Elements in Left but not in Right are in the difference
-
- and M.Included_In_Union
- (Model (Left),
- Model (Symmetric_Difference'Result),
- Model (Right))
-
- -- Elements in Right but not in Left are in the difference
-
- and M.Included_In_Union
- (Model (Right),
- Model (Symmetric_Difference'Result),
- Model (Left))
-
- -- Actual value of elements come from either Left or Right
-
- and E_Elements_Included
- (Elements (Symmetric_Difference'Result),
- Model (Left),
- Elements (Left),
- Elements (Right))
-
- and E_Elements_Included
- (Elements (Left),
- Model (Symmetric_Difference'Result),
- Elements (Symmetric_Difference'Result))
-
- and E_Elements_Included
- (Elements (Right),
- Model (Symmetric_Difference'Result),
- Elements (Symmetric_Difference'Result));
- -- The operation first iterates over the Left set. It calls Find to
- -- determine whether the element is in the Right set. If no equivalent
- -- element is found, the element from Left is inserted into the result. The
- -- operation then iterates over the Right set, to determine whether the
- -- element is in the Left set. If no equivalent element is found, the Right
- -- element is inserted into the result.
-
- function "xor" (Left, Right : Set) return Set
- renames Symmetric_Difference;
-
- function Overlap (Left, Right : Set) return Boolean with
- Global => null,
- Post =>
- Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right)));
- -- Iterates over the Left set (calling First and Next), calling Find to
- -- determine whether the element is in the Right set. If an equivalent
- -- element is found, the operation immediately returns True. The operation
- -- returns False if the iteration over Left terminates without finding any
- -- equivalent element in Right.
-
- function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with
- Global => null,
- Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set));
- -- Iterates over Subset (calling First and Next), calling Find to determine
- -- whether the element is in Of_Set. If no equivalent element is found in
- -- Of_Set, the operation immediately returns False. The operation returns
- -- True if the iteration over Subset terminates without finding an element
- -- not in Of_Set (that is, every element in Subset is equivalent to an
- -- element in Of_Set).
-
- function First (Container : Set) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
- -- Returns a cursor that designates the first non-empty bucket, by
- -- searching from the beginning of the buckets array.
-
- function Next (Container : Set; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
- -- Returns a cursor that designates the node that follows the current one
- -- designated by Position. If Position designates the last node in its
- -- bucket, the operation calls Hash to compute the index of this bucket,
- -- and searches the buckets array for the first non-empty bucket, starting
- -- from that index; otherwise, it simply follows the link to the next node
- -- in the same bucket.
-
- procedure Next (Container : Set; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
- -- Equivalent to Position := Next (Position)
-
- function Find
- (Container : Set;
- Item : Element_Type) return Cursor
- with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container, Find returns No_Element
-
- (not Contains (Model (Container), Item) =>
- Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
- and P.Get (Positions (Container), Find'Result) =
- Find (Elements (Container), Item)
-
- -- The element designated by the result of Find is Item
-
- and Equivalent_Elements
- (Element (Container, Find'Result), Item));
- -- Searches for Item in the set. Find calls Hash to determine the item's
- -- bucket; if the bucket is not empty, it calls Equivalent_Elements to
- -- compare Item to each element in the bucket. If the search succeeds, Find
- -- returns a cursor designating the node containing the equivalent element;
- -- otherwise, it returns No_Element.
-
- function Contains (Container : Set; Item : Element_Type) return Boolean with
- Global => null,
- Post => Contains'Result = Contains (Model (Container), Item);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Has_Element (Container : Set; Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- function Default_Modulus (Capacity : Count_Type) return Hash_Type with
- Global => null;
-
- generic
- type Key_Type (<>) is private;
-
- with function Key (Element : Element_Type) return Key_Type;
-
- with function Hash (Key : Key_Type) return Hash_Type;
-
- with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
-
- package Generic_Keys with SPARK_Mode is
-
- package Formal_Model with Ghost is
-
- function M_Included_Except
- (Left : M.Set;
- Right : M.Set;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Post =>
- M_Included_Except'Result =
- (for all E of Left =>
- Contains (Right, E)
- or Equivalent_Keys (Generic_Keys.Key (E), Key));
-
- end Formal_Model;
- use Formal_Model;
-
- function Key (Container : Set; Position : Cursor) return Key_Type with
- Global => null,
- Post => Key'Result = Key (Element (Container, Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Key);
-
- function Element (Container : Set; Key : Key_Type) return Element_Type
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Element'Result = Element (Container, Find (Container, Key));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace
- (Container : in out Set;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Key now maps to New_Item
-
- and Element (Container, Key) = New_Item
-
- -- New_Item is contained in Container
-
- and Contains (Model (Container), New_Item)
-
- -- Other elements are preserved
-
- and M_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved_Except
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container),
- Position => Find (Container, Key))
- and Positions (Container) = Positions (Container)'Old;
-
- procedure Exclude (Container : in out Set; Key : Key_Type) with
- Global => null,
- Post => not Contains (Container, Key),
- Contract_Cases =>
-
- -- If Key is not in Container, nothing is changed
-
- (not Contains (Container, Key) =>
- Model (Container) = Model (Container)'Old
- and Elements (Container) = Elements (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Key is removed from Container
-
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container),
- E_Right => Elements (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Key)'Old));
-
- procedure Delete (Container : in out Set; Key : Key_Type) with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Key is no longer in Container
-
- and not Contains (Container, Key)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Container),
- E_Right => Elements (Container)'Old,
- P_Left => Positions (Container),
- P_Right => Positions (Container)'Old)
- and P.Keys_Included_Except
- (Positions (Container)'Old,
- Positions (Container),
- Find (Container, Key)'Old);
-
- function Find (Container : Set; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
-
- -- If Key is not contained in Container, Find returns No_Element
-
- ((for all E of Model (Container) =>
- not Equivalent_Keys (Key, Generic_Keys.Key (E))) =>
- Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
-
- -- The key designated by the result of Find is Key
-
- and Equivalent_Keys
- (Generic_Keys.Key (Container, Find'Result), Key));
-
- function Contains (Container : Set; Key : Key_Type) return Boolean with
- Global => null,
- Post =>
- Contains'Result =
- (for some E of Model (Container) =>
- Equivalent_Keys (Key, Generic_Keys.Key (E)));
-
- end Generic_Keys;
-
-private
- pragma SPARK_Mode (Off);
-
- pragma Inline (Next);
-
- type Node_Type is
- record
- Element : aliased Element_Type;
- Next : Count_Type;
- Has_Element : Boolean := False;
- end record;
-
- package HT_Types is new
- Ada.Containers.Hash_Tables.Generic_Formal_Hash_Table_Types (Node_Type);
-
- type Set (Capacity : Count_Type; Modulus : Hash_Type) is record
- Content : HT_Types.Hash_Table_Type (Capacity, Modulus);
- end record;
-
- use HT_Types;
+package Ada.Containers.Formal_Hashed_Sets with SPARK_Mode is
- Empty_Set : constant Set := (Capacity => 0, Modulus => 0, others => <>);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Hashed_Sets;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FORMAL_INDEFINITE_DOUBLY_LINKED_LISTS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2022-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Unchecked_Deallocation;
-
-with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting;
-
-with System; use type System.Address;
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
-package body Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with
- SPARK_Mode => Off
-is
- -- Convert Count_Type to Big_Integer
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
- use Conversions;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Allocate
- (Container : in out List;
- New_Item : Element_Type;
- New_Node : out Count_Type);
-
- procedure Allocate
- (Container : in out List;
- New_Node : out Count_Type);
-
- procedure Free (Container : in out List; X : Count_Type);
-
- procedure Insert_Internal
- (Container : in out List;
- Before : Count_Type;
- New_Node : Count_Type);
-
- function Vet (L : List; Position : Cursor) return Boolean with Inline;
-
- procedure Resize (Container : in out List) with
- -- Add more room in the internal array
-
- Global => null,
- Pre => Container.Nodes = null
- or else Length (Container) = Container.Nodes'Length,
- Post => Model (Container) = Model (Container)'Old
- and Positions (Container) = Positions (Container)'Old;
-
- procedure Finalize_Element is new Ada.Unchecked_Deallocation
- (Object => Element_Type,
- Name => Element_Access);
-
- procedure Finalize_Nodes is new Ada.Unchecked_Deallocation
- (Object => Node_Array,
- Name => Node_Array_Access);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : List; Right : List) return Boolean is
- LI : Count_Type;
- RI : Count_Type;
-
- begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
- if Left.Length /= Right.Length then
- return False;
- end if;
-
- LI := Left.First;
- RI := Right.First;
- while LI /= 0 loop
- if Left.Nodes (LI).Element.all /= Right.Nodes (RI).Element.all then
- return False;
- end if;
-
- LI := Left.Nodes (LI).Next;
- RI := Right.Nodes (RI).Next;
- end loop;
-
- return True;
- end "=";
-
- ------------
- -- Adjust --
- ------------
-
- overriding procedure Adjust (Container : in out List) is
- N_Src : Node_Array_Access renames Container.Nodes;
- N_Tar : Node_Array_Access;
-
- begin
- if N_Src = null then
- return;
- end if;
-
- if Container.Length = 0 then
- Container.Nodes := null;
- Container.Free := -1;
- return;
- end if;
-
- N_Tar := new Node_Array (1 .. N_Src'Length);
-
- for X in 1 .. Count_Type (N_Src'Length) loop
- N_Tar (X) := N_Src (X);
- if N_Src (X).Element /= null
- then
- N_Tar (X).Element := new Element_Type'(N_Src (X).Element.all);
- end if;
- end loop;
-
- N_Src := N_Tar;
-
- end Adjust;
-
- --------------
- -- Allocate --
- --------------
-
- procedure Allocate
- (Container : in out List;
- New_Node : out Count_Type)
- is
- N : Node_Array_Access renames Container.Nodes;
-
- begin
- if Container.Nodes = null
- or else Length (Container) = Container.Nodes'Length
- then
- Resize (Container);
- end if;
-
- if Container.Free >= 0 then
- New_Node := Container.Free;
- Container.Free := N (New_Node).Next;
- else
- New_Node := abs Container.Free;
- Container.Free := Container.Free - 1;
- end if;
-
- N (New_Node).Element := null;
- end Allocate;
-
- procedure Allocate
- (Container : in out List;
- New_Item : Element_Type;
- New_Node : out Count_Type)
- is
- N : Node_Array_Access renames Container.Nodes;
-
- begin
- Allocate (Container, New_Node);
-
- N (New_Node).Element := new Element_Type'(New_Item);
- end Allocate;
-
- ------------
- -- Append --
- ------------
-
- procedure Append (Container : in out List; New_Item : Element_Type) is
- begin
- Insert (Container, No_Element, New_Item, 1);
- end Append;
-
- procedure Append
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, No_Element, New_Item, Count);
- end Append;
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out List; Source : List) is
- N : Node_Array_Access renames Source.Nodes;
- J : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- Clear (Target);
-
- J := Source.First;
- while J /= 0 loop
- Append (Target, N (J).Element.all);
- J := N (J).Next;
- end loop;
- end Assign;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out List) is
- N : Node_Array_Access renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Container.Length = 0 then
- pragma Assert (Container.First = 0);
- pragma Assert (Container.Last = 0);
- return;
- end if;
-
- pragma Assert (Container.First >= 1);
- pragma Assert (Container.Last >= 1);
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- while Container.Length > 1 loop
- X := Container.First;
-
- Container.First := N (X).Next;
- N (Container.First).Prev := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
-
- X := Container.First;
-
- Container.First := 0;
- Container.Last := 0;
- Container.Length := 0;
-
- Free (Container, X);
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : List;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container => Container, Position => Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : List;
- Item : Element_Type) return Boolean
- is
- begin
- return Find (Container, Item) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy (Source : List) return List
- is
- N : Count_Type;
- P : List;
-
- begin
- if Source.Nodes = null then
- return P;
- end if;
-
- P.Nodes := new Node_Array (1 .. Source.Nodes'Length);
-
- N := 1;
- while N <= Source.Nodes'Length loop
- P.Nodes (N).Prev := Source.Nodes (N).Prev;
- P.Nodes (N).Next := Source.Nodes (N).Next;
- if Source.Nodes (N).Element /= null then
- P.Nodes (N).Element :=
- new Element_Type'(Source.Nodes (N).Element.all);
- end if;
- N := N + 1;
- end loop;
-
- P.Free := Source.Free;
- P.Length := Source.Length;
- P.First := Source.First;
- P.Last := Source.Last;
-
- return P;
- end Copy;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out List; Position : in out Cursor) is
- begin
- Delete
- (Container => Container,
- Position => Position,
- Count => 1);
- end Delete;
-
- procedure Delete
- (Container : in out List;
- Position : in out Cursor;
- Count : Count_Type)
- is
- N : Node_Array_Access renames Container.Nodes;
- X : Count_Type;
-
- begin
- if not Has_Element (Container => Container,
- Position => Position)
- then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container, Position), "bad cursor in Delete");
- pragma Assert (Container.First >= 1);
- pragma Assert (Container.Last >= 1);
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- if Position.Node = Container.First then
- Delete_First (Container, Count);
- Position := No_Element;
- return;
- end if;
-
- if Count = 0 then
- Position := No_Element;
- return;
- end if;
-
- for Index in 1 .. Count loop
- pragma Assert (Container.Length >= 2);
-
- X := Position.Node;
- Container.Length := Container.Length - 1;
-
- if X = Container.Last then
- Position := No_Element;
-
- Container.Last := N (X).Prev;
- N (Container.Last).Next := 0;
-
- Free (Container, X);
- return;
- end if;
-
- Position.Node := N (X).Next;
- pragma Assert (N (Position.Node).Prev >= 0);
-
- N (N (X).Next).Prev := N (X).Prev;
- N (N (X).Prev).Next := N (X).Next;
-
- Free (Container, X);
- end loop;
-
- Position := No_Element;
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out List) is
- begin
- Delete_First
- (Container => Container,
- Count => 1);
- end Delete_First;
-
- procedure Delete_First (Container : in out List; Count : Count_Type) is
- N : Node_Array_Access renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Count >= Container.Length then
- Clear (Container);
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- for J in 1 .. Count loop
- X := Container.First;
- pragma Assert (N (N (X).Next).Prev = Container.First);
-
- Container.First := N (X).Next;
- N (Container.First).Prev := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out List) is
- begin
- Delete_Last
- (Container => Container,
- Count => 1);
- end Delete_Last;
-
- procedure Delete_Last (Container : in out List; Count : Count_Type) is
- N : Node_Array_Access renames Container.Nodes;
- X : Count_Type;
-
- begin
- if Count >= Container.Length then
- Clear (Container);
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- for J in 1 .. Count loop
- X := Container.Last;
- pragma Assert (N (N (X).Prev).Next = Container.Last);
-
- Container.Last := N (X).Prev;
- N (Container.Last).Next := 0;
-
- Container.Length := Container.Length - 1;
-
- Free (Container, X);
- end loop;
- end Delete_Last;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : List;
- Position : Cursor) return Element_Type
- is
- begin
- if not Has_Element (Container => Container, Position => Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element.all;
- end Element;
-
- ----------------
- -- Empty_List --
- ----------------
-
- function Empty_List return List is
- ((Controlled with others => <>));
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Container : in out List) is
- X : Count_Type := Container.First;
- N : Node_Array_Access renames Container.Nodes;
- begin
-
- if N = null then
- return;
- end if;
-
- while X /= 0 loop
- Finalize_Element (N (X).Element);
- X := N (X).Next;
- end loop;
-
- Finalize_Nodes (N);
-
- Container.Free := 0;
- Container.Last := 0;
- Container.First := 0;
- Container.Length := 0;
- end Finalize;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- is
- From : Count_Type := Position.Node;
-
- begin
- if From = 0 and Container.Length = 0 then
- return No_Element;
- end if;
-
- if From = 0 then
- From := Container.First;
- end if;
-
- if Position.Node /= 0 and then not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- while From /= 0 loop
- if Container.Nodes (From).Element.all = Item then
- return (Node => From);
- end if;
-
- From := Container.Nodes (From).Next;
- end loop;
-
- return No_Element;
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : List) return Cursor is
- begin
- if Container.First = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.First);
- end First;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : List) return Element_Type is
- F : constant Count_Type := Container.First;
- begin
- if F = 0 then
- raise Constraint_Error with "list is empty";
- else
- return Container.Nodes (F).Element.all;
- end if;
- end First_Element;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : List) is null;
-
- -------------------------
- -- M_Elements_In_Union --
- -------------------------
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- Elem : Element_Type;
-
- begin
- for Index in 1 .. M.Length (Container) loop
- Elem := Element (Container, Index);
-
- if not M.Contains (Left, 1, M.Length (Left), Elem)
- and then not M.Contains (Right, 1, M.Length (Right), Elem)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_In_Union;
-
- -------------------------
- -- M_Elements_Included --
- -------------------------
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Positive_Count_Type := 1;
- L_Lst : Count_Type;
- Right : M.Sequence;
- R_Fst : Positive_Count_Type := 1;
- R_Lst : Count_Type) return Boolean
- is
- begin
- for I in L_Fst .. L_Lst loop
- declare
- Found : Boolean := False;
- J : Count_Type := R_Fst - 1;
-
- begin
- while not Found and J < R_Lst loop
- J := J + 1;
- if Element (Left, I) = Element (Right, J) then
- Found := True;
- end if;
- end loop;
-
- if not Found then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end M_Elements_Included;
-
- -------------------------
- -- M_Elements_Reversed --
- -------------------------
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- L : constant Count_Type := M.Length (Left);
-
- begin
- if L /= M.Length (Right) then
- return False;
- end if;
-
- for I in 1 .. L loop
- if Element (Left, I) /= Element (Right, L - I + 1) then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Reversed;
-
- ------------------------
- -- M_Elements_Swapped --
- ------------------------
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Positive_Count_Type;
- Y : Positive_Count_Type) return Boolean
- is
- begin
- if M.Length (Left) /= M.Length (Right)
- or else Element (Left, X) /= Element (Right, Y)
- or else Element (Left, Y) /= Element (Right, X)
- then
- return False;
- end if;
-
- for I in 1 .. M.Length (Left) loop
- if I /= X and then I /= Y
- and then Element (Left, I) /= Element (Right, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Swapped;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : List) return M.Sequence is
- Position : Count_Type := Container.First;
- R : M.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := M.Add (R, Container.Nodes (Position).Element.all);
- Position := Container.Nodes (Position).Next;
- end loop;
-
- return R;
- end Model;
-
- -----------------------
- -- Mapping_Preserved --
- -----------------------
-
- function Mapping_Preserved
- (M_Left : M.Sequence;
- M_Right : M.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- is
- begin
- for C of P_Left loop
- if not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > M.Length (M_Left)
- or else P.Get (P_Right, C) > M.Length (M_Right)
- or else M.Get (M_Left, P.Get (P_Left, C)) /=
- M.Get (M_Right, P.Get (P_Right, C))
- then
- return False;
- end if;
- end loop;
-
- for C of P_Right loop
- if not P.Has_Key (P_Left, C) then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved;
-
- -------------------------
- -- P_Positions_Shifted --
- -------------------------
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu) + Count
- then
- return False;
- end if;
-
- else
- if P.Has_Key (Small, Cu) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Shifted;
-
- -------------------------
- -- P_Positions_Swapped --
- -------------------------
-
- function P_Positions_Swapped
- (Left : P.Map;
- Right : P.Map;
- X : Cursor;
- Y : Cursor) return Boolean
- is
- begin
- if not P.Has_Key (Left, X)
- or not P.Has_Key (Left, Y)
- or not P.Has_Key (Right, X)
- or not P.Has_Key (Right, Y)
- then
- return False;
- end if;
-
- if P.Get (Left, X) /= P.Get (Right, Y)
- or P.Get (Left, Y) /= P.Get (Right, X)
- then
- return False;
- end if;
-
- for C of Left loop
- if not P.Has_Key (Right, C) then
- return False;
- end if;
- end loop;
-
- for C of Right loop
- if not P.Has_Key (Left, C)
- or else (C /= X
- and C /= Y
- and P.Get (Left, C) /= P.Get (Right, C))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end P_Positions_Swapped;
-
- ---------------------------
- -- P_Positions_Truncated --
- ---------------------------
-
- function P_Positions_Truncated
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- return False;
-
- elsif P.Has_Key (Small, Cu) then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Truncated;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : List) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := Container.First;
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = To_Big_Integer (I));
- Position := Container.Nodes (Position).Next;
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Container : in out List; X : Count_Type) is
- pragma Assert (X > 0);
- pragma Assert (X <= Container.Nodes'Length);
-
- N : Node_Array_Access renames Container.Nodes;
-
- begin
- N (X).Prev := -1; -- Node is deallocated (not on active list)
-
- if N (X).Element /= null then
- Finalize_Element (N (X).Element);
- end if;
-
- if Container.Free >= 0 then
- N (X).Next := Container.Free;
- Container.Free := X;
- elsif X + 1 = abs Container.Free then
- N (X).Next := 0; -- Not strictly necessary, but marginally safer
- Container.Free := Container.Free + 1;
- else
- Container.Free := abs Container.Free;
-
- for J in Container.Free .. Container.Nodes'Length loop
- N (J).Next := J + 1;
- end loop;
-
- N (Container.Nodes'Length).Next := 0;
-
- N (X).Next := Container.Free;
- Container.Free := X;
- end if;
- end Free;
-
- ---------------------
- -- Generic_Sorting --
- ---------------------
-
- package body Generic_Sorting with SPARK_Mode => Off is
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -----------------------
- -- M_Elements_Sorted --
- -----------------------
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean is
- begin
- if M.Length (Container) = 0 then
- return True;
- end if;
-
- declare
- E1 : Element_Type := Element (Container, 1);
-
- begin
- for I in 2 .. M.Length (Container) loop
- declare
- E2 : constant Element_Type := Element (Container, I);
-
- begin
- if E2 < E1 then
- return False;
- end if;
-
- E1 := E2;
- end;
- end loop;
- end;
-
- return True;
- end M_Elements_Sorted;
-
- end Formal_Model;
-
- ---------------
- -- Is_Sorted --
- ---------------
-
- function Is_Sorted (Container : List) return Boolean is
- Nodes : Node_Array_Access renames Container.Nodes;
- Node : Count_Type := Container.First;
-
- begin
- for J in 2 .. Container.Length loop
- if Nodes (Nodes (Node).Next).Element.all < Nodes (Node).Element.all
- then
- return False;
- else
- Node := Nodes (Node).Next;
- end if;
- end loop;
-
- return True;
- end Is_Sorted;
-
- -----------
- -- Merge --
- -----------
-
- procedure Merge (Target : in out List; Source : in out List) is
- LN : Node_Array_Access renames Target.Nodes;
- RN : Node_Array_Access renames Source.Nodes;
- LI : Cursor;
- RI : Cursor;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- LI := First (Target);
- RI := First (Source);
- while RI.Node /= 0 loop
- pragma Assert
- (RN (RI.Node).Next = 0
- or else not (RN (RN (RI.Node).Next).Element.all <
- RN (RI.Node).Element.all));
-
- if LI.Node = 0 then
- Splice (Target, No_Element, Source);
- return;
- end if;
-
- pragma Assert
- (LN (LI.Node).Next = 0
- or else not (LN (LN (LI.Node).Next).Element.all <
- LN (LI.Node).Element.all));
-
- if RN (RI.Node).Element.all < LN (LI.Node).Element.all then
- declare
- RJ : Cursor := RI;
- pragma Warnings (Off, RJ);
- begin
- RI.Node := RN (RI.Node).Next;
- Splice (Target, LI, Source, RJ);
- end;
-
- else
- LI.Node := LN (LI.Node).Next;
- end if;
- end loop;
- end Merge;
-
- ----------
- -- Sort --
- ----------
-
- procedure Sort (Container : in out List) is
- N : Node_Array_Access renames Container.Nodes;
- begin
- if Container.Length <= 1 then
- return;
- end if;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- declare
- package Descriptors is new List_Descriptors
- (Node_Ref => Count_Type, Nil => 0);
- use Descriptors;
-
- function Next (Idx : Count_Type) return Count_Type is
- (N (Idx).Next);
- procedure Set_Next (Idx : Count_Type; Next : Count_Type)
- with Inline;
- procedure Set_Prev (Idx : Count_Type; Prev : Count_Type)
- with Inline;
- function "<" (L, R : Count_Type) return Boolean is
- (N (L).Element.all < N (R).Element.all);
- procedure Update_Container (List : List_Descriptor) with Inline;
-
- procedure Set_Next (Idx : Count_Type; Next : Count_Type) is
- begin
- N (Idx).Next := Next;
- end Set_Next;
-
- procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is
- begin
- N (Idx).Prev := Prev;
- end Set_Prev;
-
- procedure Update_Container (List : List_Descriptor) is
- begin
- Container.First := List.First;
- Container.Last := List.Last;
- Container.Length := List.Length;
- end Update_Container;
-
- procedure Sort_List is new Doubly_Linked_List_Sort;
- begin
- Sort_List (List_Descriptor'(First => Container.First,
- Last => Container.Last,
- Length => Container.Length));
- end;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Sort;
-
- end Generic_Sorting;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : List; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0 then
- return False;
- end if;
-
- return Container.Nodes (Position.Node).Prev /= -1;
- end Has_Element;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor;
- Count : Count_Type)
- is
- J : Count_Type;
-
- begin
- if Before.Node /= 0 then
- pragma Assert (Vet (Container, Before), "bad cursor in Insert");
- end if;
-
- if Count = 0 then
- Position := Before;
- return;
- end if;
- Allocate (Container, New_Item, New_Node => J);
- Insert_Internal (Container, Before.Node, New_Node => J);
- Position := (Node => J);
-
- for Index in 2 .. Count loop
- Allocate (Container, New_Item, New_Node => J);
- Insert_Internal (Container, Before.Node, New_Node => J);
- end loop;
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor)
- is
- begin
- Insert
- (Container => Container,
- Before => Before,
- New_Item => New_Item,
- Position => Position,
- Count => 1);
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- Position : Cursor;
-
- begin
- Insert (Container, Before, New_Item, Position, Count);
- end Insert;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type)
- is
- Position : Cursor;
-
- begin
- Insert (Container, Before, New_Item, Position, 1);
- end Insert;
-
- ---------------------
- -- Insert_Internal --
- ---------------------
-
- procedure Insert_Internal
- (Container : in out List;
- Before : Count_Type;
- New_Node : Count_Type)
- is
- N : Node_Array_Access renames Container.Nodes;
-
- begin
- if Container.Length = 0 then
- pragma Assert (Before = 0);
- pragma Assert (Container.First = 0);
- pragma Assert (Container.Last = 0);
-
- Container.First := New_Node;
- Container.Last := New_Node;
-
- N (Container.First).Prev := 0;
- N (Container.Last).Next := 0;
-
- elsif Before = 0 then
- pragma Assert (N (Container.Last).Next = 0);
-
- N (Container.Last).Next := New_Node;
- N (New_Node).Prev := Container.Last;
-
- Container.Last := New_Node;
- N (Container.Last).Next := 0;
-
- elsif Before = Container.First then
- pragma Assert (N (Container.First).Prev = 0);
-
- N (Container.First).Prev := New_Node;
- N (New_Node).Next := Container.First;
-
- Container.First := New_Node;
- N (Container.First).Prev := 0;
-
- else
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- N (New_Node).Next := Before;
- N (New_Node).Prev := N (Before).Prev;
-
- N (N (Before).Prev).Next := New_Node;
- N (Before).Prev := New_Node;
- end if;
- Container.Length := Container.Length + 1;
- end Insert_Internal;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : List) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : List) return Cursor is
- begin
- if Container.Last = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.Last);
- end Last;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : List) return Element_Type is
- L : constant Count_Type := Container.Last;
-
- begin
- if L = 0 then
- raise Constraint_Error with "list is empty";
- else
- return Container.Nodes (L).Element.all;
- end if;
- end Last_Element;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : List) return Count_Type is
- begin
- return Container.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out List; Source : in out List) is
- N : Node_Array_Access renames Source.Nodes;
-
- procedure Finalize_Node_Array is new Ada.Unchecked_Deallocation
- (Object => Node_Array,
- Name => Node_Array_Access);
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- Clear (Target);
-
- if Source.Length = 0 then
- return;
- end if;
-
- -- Make sure that Target is large enough
-
- if Target.Nodes = null
- or else Target.Nodes'Length < Source.Length
- then
- if Target.Nodes /= null then
- Finalize_Node_Array (Target.Nodes);
- end if;
- Target.Nodes := new Node_Array (1 .. Source.Length);
- end if;
-
- -- Copy first element from Source to Target
-
- Target.First := 1;
-
- Target.Nodes (1).Prev := 0;
- Target.Nodes (1).Element := N (Source.First).Element;
- N (Source.First).Element := null;
-
- -- Copy the other elements
-
- declare
- X_Src : Count_Type := N (Source.First).Next;
- X_Tar : Count_Type := 2;
-
- begin
- while X_Src /= 0 loop
- Target.Nodes (X_Tar).Prev := X_Tar - 1;
- Target.Nodes (X_Tar - 1).Next := X_Tar;
-
- Target.Nodes (X_Tar).Element := N (X_Src).Element;
- N (X_Src).Element := null;
-
- X_Src := N (X_Src).Next;
- X_Tar := X_Tar + 1;
- end loop;
- end;
-
- Target.Last := Source.Length;
- Target.Length := Source.Length;
- Target.Nodes (Target.Last).Next := 0;
-
- -- Set up the free list
-
- Target.Free := -Source.Length - 1;
-
- -- It is possible to Clear Source because the Element accesses were
- -- set to null.
-
- Clear (Source);
- end Move;
-
- ----------
- -- Next --
- ----------
-
- procedure Next (Container : List; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- function Next (Container : List; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Program_Error with "Position cursor has no element";
- end if;
-
- return (Node => Container.Nodes (Position.Node).Next);
- end Next;
-
- -------------
- -- Prepend --
- -------------
-
- procedure Prepend (Container : in out List; New_Item : Element_Type) is
- begin
- Insert (Container, First (Container), New_Item, 1);
- end Prepend;
-
- procedure Prepend
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, First (Container), New_Item, Count);
- end Prepend;
-
- --------------
- -- Previous --
- --------------
-
- procedure Previous (Container : List; Position : in out Cursor) is
- begin
- Position := Previous (Container, Position);
- end Previous;
-
- function Previous (Container : List; Position : Cursor) return Cursor is
- begin
- if Position.Node = 0 then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Program_Error with "Position cursor has no element";
- end if;
-
- return (Node => Container.Nodes (Position.Node).Prev);
- end Previous;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference
- (Container : not null access List;
- Position : Cursor) return not null access Element_Type
- is
- begin
- if not Has_Element (Container.all, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- return Container.Nodes (Position.Node).Element;
- end Reference;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out List;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad cursor in Replace_Element");
-
- Finalize_Element (Container.Nodes (Position.Node).Element);
- Container.Nodes (Position.Node).Element := new Element_Type'(New_Item);
- end Replace_Element;
-
- ------------
- -- Resize --
- ------------
-
- procedure Resize (Container : in out List) is
- Min_Size : constant Count_Type := 100;
- begin
- if Container.Nodes = null then
- Container.Nodes := new Node_Array (1 .. Min_Size);
- Container.First := 0;
- Container.Last := 0;
- Container.Length := 0;
- Container.Free := -1;
-
- return;
- end if;
-
- if Container.Length /= Container.Nodes'Length then
- raise Program_Error with "List must be at size max to resize";
- end if;
-
- declare
- procedure Finalize_Node_Array is new Ada.Unchecked_Deallocation
- (Object => Node_Array,
- Name => Node_Array_Access);
-
- New_Size : constant Count_Type :=
- (if Container.Nodes'Length > Count_Type'Last / 2
- then Count_Type'Last
- else 2 * Container.Nodes'Length);
- New_Nodes : Node_Array_Access;
-
- begin
- New_Nodes :=
- new Node_Array (1 .. Count_Type'Max (New_Size, Min_Size));
-
- New_Nodes (1 .. Container.Nodes'Length) :=
- Container.Nodes (1 .. Container.Nodes'Length);
-
- Container.Free := -Container.Nodes'Length - 1;
-
- Finalize_Node_Array (Container.Nodes);
- Container.Nodes := New_Nodes;
- end;
- end Resize;
-
- ----------------------
- -- Reverse_Elements --
- ----------------------
-
- procedure Reverse_Elements (Container : in out List) is
- N : Node_Array_Access renames Container.Nodes;
- I : Count_Type := Container.First;
- J : Count_Type := Container.Last;
-
- procedure Swap (L : Count_Type; R : Count_Type);
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap (L : Count_Type; R : Count_Type) is
- LN : constant Count_Type := N (L).Next;
- LP : constant Count_Type := N (L).Prev;
-
- RN : constant Count_Type := N (R).Next;
- RP : constant Count_Type := N (R).Prev;
-
- begin
- if LP /= 0 then
- N (LP).Next := R;
- end if;
-
- if RN /= 0 then
- N (RN).Prev := L;
- end if;
-
- N (L).Next := RN;
- N (R).Prev := LP;
-
- if LN = R then
- pragma Assert (RP = L);
-
- N (L).Prev := R;
- N (R).Next := L;
-
- else
- N (L).Prev := RP;
- N (RP).Next := L;
-
- N (R).Next := LN;
- N (LN).Prev := R;
- end if;
- end Swap;
-
- -- Start of processing for Reverse_Elements
-
- begin
- if Container.Length <= 1 then
- return;
- end if;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
-
- Container.First := J;
- Container.Last := I;
- loop
- Swap (L => I, R => J);
-
- J := N (J).Next;
- exit when I = J;
-
- I := N (I).Prev;
- exit when I = J;
-
- Swap (L => J, R => I);
-
- I := N (I).Next;
- exit when I = J;
-
- J := N (J).Prev;
- exit when I = J;
- end loop;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Reverse_Elements;
-
- ------------------
- -- Reverse_Find --
- ------------------
-
- function Reverse_Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- is
- CFirst : Count_Type := Position.Node;
-
- begin
- if CFirst = 0 then
- CFirst := Container.Last;
- end if;
-
- if Container.Length = 0 then
- return No_Element;
- else
- while CFirst /= 0 loop
- if Container.Nodes (CFirst).Element.all = Item then
- return (Node => CFirst);
- else
- CFirst := Container.Nodes (CFirst).Prev;
- end if;
- end loop;
-
- return No_Element;
- end if;
- end Reverse_Find;
-
- ------------
- -- Splice --
- ------------
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List)
- is
- SN : Node_Array_Access renames Source.Nodes;
- TN : Node_Array_Access renames Target.Nodes;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Before.Node /= 0 then
- pragma Assert (Vet (Target, Before), "bad cursor in Splice");
- end if;
-
- if Is_Empty (Source) then
- return;
- end if;
-
- pragma Assert (SN (Source.First).Prev = 0);
- pragma Assert (SN (Source.Last).Next = 0);
-
- declare
- X : Count_Type;
-
- begin
- while not Is_Empty (Source) loop
- Allocate (Target, X);
-
- TN (X).Element := SN (Source.Last).Element;
-
- -- Insert the new node in Target
-
- Insert_Internal (Target, Before.Node, X);
-
- -- Free the last node of Source
-
- SN (Source.Last).Element := null;
- Delete_Last (Source);
- end loop;
- end;
-
- end Splice;
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List;
- Position : in out Cursor)
- is
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Position.Node = 0 then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Source, Position), "bad Position cursor in Splice");
-
- declare
- X : Count_Type;
-
- begin
- Allocate (Target, X);
-
- Target.Nodes (X).Element := Source.Nodes (Position.Node).Element;
-
- -- Insert the new node in Target
-
- Insert_Internal (Target, Before.Node, X);
-
- -- Free the node at position Position in Source
-
- Source.Nodes (Position.Node).Element := null;
- Delete (Source, Position);
-
- Position := (Node => X);
- end;
- end Splice;
-
- procedure Splice
- (Container : in out List;
- Before : Cursor;
- Position : Cursor)
- is
- N : Node_Array_Access renames Container.Nodes;
-
- begin
- if Before.Node /= 0 then
- pragma Assert
- (Vet (Container, Before), "bad Before cursor in Splice");
- end if;
-
- if Position.Node = 0 then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container, Position), "bad Position cursor in Splice");
-
- if Position.Node = Before.Node
- or else N (Position.Node).Next = Before.Node
- then
- return;
- end if;
-
- pragma Assert (Container.Length >= 2);
-
- if Before.Node = 0 then
- pragma Assert (Position.Node /= Container.Last);
-
- if Position.Node = Container.First then
- Container.First := N (Position.Node).Next;
- N (Container.First).Prev := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (Container.Last).Next := Position.Node;
- N (Position.Node).Prev := Container.Last;
-
- Container.Last := Position.Node;
- N (Container.Last).Next := 0;
-
- return;
- end if;
-
- if Before.Node = Container.First then
- pragma Assert (Position.Node /= Container.First);
-
- if Position.Node = Container.Last then
- Container.Last := N (Position.Node).Prev;
- N (Container.Last).Next := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (Container.First).Prev := Position.Node;
- N (Position.Node).Next := Container.First;
-
- Container.First := Position.Node;
- N (Container.First).Prev := 0;
-
- return;
- end if;
-
- if Position.Node = Container.First then
- Container.First := N (Position.Node).Next;
- N (Container.First).Prev := 0;
-
- elsif Position.Node = Container.Last then
- Container.Last := N (Position.Node).Prev;
- N (Container.Last).Next := 0;
-
- else
- N (N (Position.Node).Prev).Next := N (Position.Node).Next;
- N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
- end if;
-
- N (N (Before.Node).Prev).Next := Position.Node;
- N (Position.Node).Prev := N (Before.Node).Prev;
-
- N (Before.Node).Prev := Position.Node;
- N (Position.Node).Next := Before.Node;
-
- pragma Assert (N (Container.First).Prev = 0);
- pragma Assert (N (Container.Last).Next = 0);
- end Splice;
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- is
- begin
- if I.Node = 0 then
- raise Constraint_Error with "I cursor has no element";
- end if;
-
- if J.Node = 0 then
- raise Constraint_Error with "J cursor has no element";
- end if;
-
- if I.Node = J.Node then
- return;
- end if;
-
- pragma Assert (Vet (Container, I), "bad I cursor in Swap");
- pragma Assert (Vet (Container, J), "bad J cursor in Swap");
-
- declare
- NN : Node_Array_Access renames Container.Nodes;
- NI : Node_Type renames NN (I.Node);
- NJ : Node_Type renames NN (J.Node);
-
- EI_Copy : constant Element_Access := NI.Element;
-
- begin
- NI.Element := NJ.Element;
- NJ.Element := EI_Copy;
- end;
- end Swap;
-
- ----------------
- -- Swap_Links --
- ----------------
-
- procedure Swap_Links
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- is
- I_Next : Cursor;
- J_Next : Cursor;
-
- begin
- if I.Node = 0 then
- raise Constraint_Error with "I cursor has no element";
- end if;
-
- if J.Node = 0 then
- raise Constraint_Error with "J cursor has no element";
- end if;
-
- if I.Node = J.Node then
- return;
- end if;
-
- pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links");
- pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links");
-
- I_Next := Next (Container, I);
-
- if I_Next = J then
- Splice (Container, Before => I, Position => J);
-
- else
- J_Next := Next (Container, J);
-
- if J_Next = I then
- Splice (Container, Before => J, Position => I);
-
- else
- pragma Assert (Container.Length >= 3);
- Splice (Container, Before => I_Next, Position => J);
- Splice (Container, Before => J_Next, Position => I);
- end if;
- end if;
- end Swap_Links;
-
- ---------
- -- Vet --
- ---------
-
- function Vet (L : List; Position : Cursor) return Boolean is
- N : Node_Array_Access renames L.Nodes;
- begin
- if not Container_Checks'Enabled then
- return True;
- end if;
-
- if L.Length = 0 then
- return False;
- end if;
-
- if L.First = 0 then
- return False;
- end if;
-
- if L.Last = 0 then
- return False;
- end if;
-
- if Position.Node > L.Nodes'Length then
- return False;
- end if;
-
- if N (Position.Node).Prev < 0
- or else N (Position.Node).Prev > L.Nodes'Length
- then
- return False;
- end if;
-
- if N (Position.Node).Next > L.Nodes'Length then
- return False;
- end if;
-
- if N (L.First).Prev /= 0 then
- return False;
- end if;
-
- if N (L.Last).Next /= 0 then
- return False;
- end if;
-
- if N (Position.Node).Prev = 0 and then Position.Node /= L.First then
- return False;
- end if;
-
- if N (Position.Node).Next = 0 and then Position.Node /= L.Last then
- return False;
- end if;
-
- if L.Length = 1 then
- return L.First = L.Last;
- end if;
-
- if L.First = L.Last then
- return False;
- end if;
-
- if N (L.First).Next = 0 then
- return False;
- end if;
-
- if N (L.Last).Prev = 0 then
- return False;
- end if;
-
- if N (N (L.First).Next).Prev /= L.First then
- return False;
- end if;
-
- if N (N (L.Last).Prev).Next /= L.Last then
- return False;
- end if;
-
- if L.Length = 2 then
- if N (L.First).Next /= L.Last then
- return False;
- end if;
-
- if N (L.Last).Prev /= L.First then
- return False;
- end if;
-
- return True;
- end if;
-
- if N (L.First).Next = L.Last then
- return False;
- end if;
-
- if N (L.Last).Prev = L.First then
- return False;
- end if;
-
- if Position.Node = L.First then
- return True;
- end if;
-
- if Position.Node = L.Last then
- return True;
- end if;
-
- if N (Position.Node).Next = 0 then
- return False;
- end if;
-
- if N (Position.Node).Prev = 0 then
- return False;
- end if;
-
- if N (N (Position.Node).Next).Prev /= Position.Node then
- return False;
- end if;
-
- if N (N (Position.Node).Prev).Next /= Position.Node then
- return False;
- end if;
-
- if L.Length = 3 then
- if N (L.First).Next /= Position.Node then
- return False;
- end if;
-
- if N (L.Last).Prev /= Position.Node then
- return False;
- end if;
- end if;
-
- return True;
- end Vet;
-
-end Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-with Ada.Containers.Functional_Vectors;
-with Ada.Containers.Functional_Maps;
-private with Ada.Finalization;
-
generic
- type Element_Type is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with
- SPARK_Mode
-is
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- type List is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Element),
- Default_Initial_Condition => Is_Empty (List);
-
- type Cursor is record
- Node : Count_Type := 0;
- end record;
-
- No_Element : constant Cursor := Cursor'(Node => 0);
-
- function Length (Container : List) return Count_Type with
- Global => null;
-
- function Empty_List return List with
- Global => null,
- Post => Length (Empty_List'Result) = 0;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Vectors
- (Index_Type => Positive_Count_Type,
- Element_Type => Element_Type);
-
- function "="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."=";
-
- function "<"
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<";
-
- function "<="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<=";
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- The elements of Container are contained in either Left or Right
- with
- Global => null,
- Post =>
- M_Elements_In_Union'Result =
- (for all I in 1 .. M.Length (Container) =>
- (for some J in 1 .. M.Length (Left) =>
- Element (Container, I) = Element (Left, J))
- or (for some J in 1 .. M.Length (Right) =>
- Element (Container, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union);
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Positive_Count_Type := 1;
- L_Lst : Count_Type;
- Right : M.Sequence;
- R_Fst : Positive_Count_Type := 1;
- R_Lst : Count_Type) return Boolean
- -- The elements of the slice from L_Fst to L_Lst in Left are contained
- -- in the slide from R_Fst to R_Lst in Right.
- with
- Global => null,
- Pre => L_Lst <= M.Length (Left) and R_Lst <= M.Length (Right),
- Post =>
- M_Elements_Included'Result =
- (for all I in L_Fst .. L_Lst =>
- (for some J in R_Fst .. R_Lst =>
- Element (Left, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included);
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- Right is Left in reverse order
- with
- Global => null,
- Post =>
- M_Elements_Reversed'Result =
- (M.Length (Left) = M.Length (Right)
- and (for all I in 1 .. M.Length (Left) =>
- Element (Left, I) =
- Element (Right, M.Length (Left) - I + 1))
- and (for all I in 1 .. M.Length (Left) =>
- Element (Right, I) =
- Element (Left, M.Length (Left) - I + 1)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed);
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Positive_Count_Type;
- Y : Positive_Count_Type) return Boolean
- -- Elements stored at X and Y are reversed in Left and Right
- with
- Global => null,
- Pre => X <= M.Length (Left) and Y <= M.Length (Left),
- Post =>
- M_Elements_Swapped'Result =
- (M.Length (Left) = M.Length (Right)
- and Element (Left, X) = Element (Right, Y)
- and Element (Left, Y) = Element (Right, X)
- and M.Equal_Except (Left, Right, X, Y));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped);
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Global => null,
- Post =>
- P_Positions_Shifted'Result =
-
- -- Big contains all cursors of Small
-
- (P.Keys_Included (Small, Big)
-
- -- Cursors located before Cut are not moved, cursors located
- -- after are shifted by Count.
-
- and (for all I of Small =>
- (if P.Get (Small, I) < Cut then
- P.Get (Big, I) = P.Get (Small, I)
- else
- P.Get (Big, I) - Count = P.Get (Small, I)))
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function P_Positions_Swapped
- (Left : P.Map;
- Right : P.Map;
- X : Cursor;
- Y : Cursor) return Boolean
- -- Left and Right contain the same cursors, but the positions of X and Y
- -- are reversed.
- with
- Ghost,
- Global => null,
- Post =>
- P_Positions_Swapped'Result =
- (P.Same_Keys (Left, Right)
- and P.Elements_Equal_Except (Left, Right, X, Y)
- and P.Has_Key (Left, X)
- and P.Has_Key (Left, Y)
- and P.Get (Left, X) = P.Get (Right, Y)
- and P.Get (Left, Y) = P.Get (Right, X));
-
- function P_Positions_Truncated
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- P_Positions_Truncated'Result =
-
- -- Big contains all cursors of Small at the same position
-
- (Small <= Big
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function Mapping_Preserved
- (M_Left : M.Sequence;
- M_Right : M.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved'Result then
-
- -- Left and Right contain the same cursors
-
- P.Same_Keys (P_Left, P_Right)
-
- -- Mappings from cursors to elements induced by M_Left, P_Left
- -- and M_Right, P_Right are the same.
-
- and (for all C of P_Left =>
- M.Get (M_Left, P.Get (P_Left, C)) =
- M.Get (M_Right, P.Get (P_Right, C))));
-
- function Model (Container : List) return M.Sequence with
- -- The high-level model of a list is a sequence of elements. Cursors are
- -- not represented in this model.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Length (Container);
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model);
-
- function Positions (Container : List) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and map them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : List) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access to the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level cursor-aware view of a container to a high-level
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Elt of Model (Container) =>
- (for some I of Positions (Container) =>
- M.Get (Model (Container), P.Get (Positions (Container), I)) =
- Elt));
-
- function Element
- (S : M.Sequence;
- I : Count_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
-
- end Formal_Model;
- use Formal_Model;
-
- function "=" (Left, Right : List) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function Is_Empty (Container : List) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out List) with
- Global => null,
- Post => Length (Container) = 0;
-
- procedure Assign (Target : in out List; Source : List) with
- Global => null,
- Post => Model (Target) = Model (Source);
-
- function Copy (Source : List) return List with
- Global => null,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Positions (Copy'Result) = Positions (Source);
-
- function Element
- (Container : List;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result =
- Element (Model (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out List;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Cursors are preserved
-
- and Positions (Container)'Old = Positions (Container)
-
- -- The element at the position of Position in Container is New_Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Position)) = New_Item
-
- -- Other elements are preserved
-
- and M.Equal_Except
- (Model (Container)'Old,
- Model (Container),
- P.Get (Positions (Container), Position));
-
- function At_End (E : access constant List) return access constant List
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : List;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- Element (Model (Container), P.Get (Positions (Container), Position));
-
- function Reference
- (Container : not null access List;
- Position : Cursor) return not null access Element_Type
- with
- Global => null,
- Pre => Has_Element (Container.all, Position),
- Post =>
- Length (Container.all) = Length (At_End (Container).all)
-
- -- Cursors are preserved
-
- and Positions (Container.all) = Positions (At_End (Container).all)
-
- -- Container will have Result.all at position Position
-
- and At_End (Reference'Result).all =
- Element (Model (At_End (Container).all),
- P.Get (Positions (At_End (Container).all), Position))
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Model (Container.all),
- Model (At_End (Container).all),
- P.Get (Positions (At_End (Container).all), Position));
-
- procedure Move (Target : in out List; Source : in out List) with
- Global => null,
- Post => Model (Target) = Model (Source'Old) and Length (Source) = 0;
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Count_Type'Last
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + 1,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- Positions contains a new mapping from the last cursor of
- -- Container to its length.
-
- P.Get (Positions (Container), Last (Container)) = Length (Container)
-
- -- Other cursors come from Container'Old
-
- and P.Keys_Included_Except
- (Left => Positions (Container),
- Right => Positions (Container)'Old,
- New_Key => Last (Container))
-
- -- Cursors of Container'Old keep the same position
-
- and Positions (Container)'Old <= Positions (Container)
-
- -- Model contains a new element New_Item at the end
-
- and Element (Model (Container), Length (Container)) = New_Item
-
- -- Elements of Container'Old are preserved
-
- and Model (Container)'Old <= Model (Container),
-
- others =>
-
- -- The elements of Container located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is stored at the previous position of Before in
- -- Container.
-
- and Element
- (Model (Container),
- P.Get (Positions (Container)'Old, Before)) = New_Item
-
- -- A new cursor has been inserted at position Before in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container)'Old, Before)));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Count_Type'Last - Count
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + Count,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- The elements of Container are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old)
-
- -- Container contains Count times New_Item at the end
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Length (Container)'Old + 1,
- Lst => Length (Container),
- Item => New_Item))
-
- -- Count cursors have been inserted at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Length (Container)'Old + 1,
- Count => Count),
-
- others =>
-
- -- The elements of Container located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1)
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container contains Count times New_Item after position Before
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before),
- Lst =>
- P.Get (Positions (Container)'Old, Before) - 1 + Count,
- Item => New_Item)
-
- -- Count cursors have been inserted at position Before in
- -- Container.
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container)'Old, Before),
- Count => Count));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor)
- with
- Global => null,
- Pre =>
- Length (Container) < Count_Type'Last
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Positions is valid in Container and it is located either before
- -- Before if it is valid in Container or at the end if it is
- -- No_Element.
-
- and P.Has_Key (Positions (Container), Position)
- and (if Before = No_Element then
- P.Get (Positions (Container), Position) = Length (Container)
- else
- P.Get (Positions (Container), Position) =
- P.Get (Positions (Container)'Old, Before))
-
- -- The elements of Container located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is stored at Position in Container
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Position)) = New_Item
-
- -- A new cursor has been inserted at position Position in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position));
-
- procedure Insert
- (Container : in out List;
- Before : Cursor;
- New_Item : Element_Type;
- Position : out Cursor;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Count_Type'Last - Count
- and then (Has_Element (Container, Before)
- or else Before = No_Element),
- Post => Length (Container) = Length (Container)'Old + Count,
- Contract_Cases =>
- (Count = 0 =>
- Position = Before
- and Model (Container) = Model (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- others =>
-
- -- Positions is valid in Container and it is located either before
- -- Before if it is valid in Container or at the end if it is
- -- No_Element.
-
- P.Has_Key (Positions (Container), Position)
- and (if Before = No_Element then
- P.Get (Positions (Container), Position) =
- Length (Container)'Old + 1
- else
- P.Get (Positions (Container), Position) =
- P.Get (Positions (Container)'Old, Before))
-
- -- The elements of Container located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container contains Count times New_Item after position Position
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst =>
- P.Get (Positions (Container), Position) - 1 + Count,
- Item => New_Item)
-
- -- Count cursor have been inserted at Position in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position),
- Count => Count));
-
- procedure Prepend (Container : in out List; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Count_Type'Last,
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- New_Item is the first element of Container
-
- and Element (Model (Container), 1) = New_Item
-
- -- A new cursor has been inserted at the beginning of Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => 1);
-
- procedure Prepend
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Count_Type'Last - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => Length (Container)'Old,
- Offset => Count)
-
- -- Container starts with Count times New_Item
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => 1,
- Lst => Count,
- Item => New_Item)
-
- -- Count cursors have been inserted at the beginning of Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => 1,
- Count => Count);
-
- procedure Append (Container : in out List; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Count_Type'Last,
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Positions contains a new mapping from the last cursor of Container
- -- to its length.
-
- and P.Get (Positions (Container), Last (Container)) =
- Length (Container)
-
- -- Other cursors come from Container'Old
-
- and P.Keys_Included_Except
- (Left => Positions (Container),
- Right => Positions (Container)'Old,
- New_Key => Last (Container))
-
- -- Cursors of Container'Old keep the same position
-
- and Positions (Container)'Old <= Positions (Container)
-
- -- Model contains a new element New_Item at the end
-
- and Element (Model (Container), Length (Container)) = New_Item
-
- -- Elements of Container'Old are preserved
-
- and Model (Container)'Old <= Model (Container);
-
- procedure Append
- (Container : in out List;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Count_Type'Last - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- The elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- Container contains Count times New_Item at the end
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Length (Container)'Old + 1,
- Lst => Length (Container),
- Item => New_Item))
-
- -- Count cursors have been inserted at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Length (Container)'Old + 1,
- Count => Count);
-
- procedure Delete (Container : in out List; Position : in out Cursor) with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Position is set to No_Element
-
- and Position = No_Element
-
- -- The elements of Container located before Position are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => 1)
-
- -- Position has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old));
-
- procedure Delete
- (Container : in out List;
- Position : in out Cursor;
- Count : Count_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) in
- Length (Container)'Old - Count .. Length (Container)'Old
-
- -- Position is set to No_Element
-
- and Position = No_Element
-
- -- The elements of Container located before Position are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1),
-
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) - Count < P.Get (Positions (Container), Position) =>
- Length (Container) =
- P.Get (Positions (Container)'Old, Position'Old) - 1
-
- -- At most Count cursors have been removed at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old),
- Count => Count),
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => Count)
-
- -- Count cursors have been removed from Container at Position
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old),
- Count => Count));
-
- procedure Delete_First (Container : in out List) with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => 1)
-
- -- The first cursor of Container has been removed
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1);
-
- procedure Delete_First (Container : in out List; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count =>
- Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Elements of Container are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => Count)
-
- -- The first Count cursors have been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1,
- Count => Count));
-
- procedure Delete_Last (Container : in out List) with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old
-
- -- The last cursor of Container has been removed
-
- and not P.Has_Key (Positions (Container), Last (Container)'Old)
-
- -- Other cursors are still valid
-
- and P.Keys_Included_Except
- (Left => Positions (Container)'Old,
- Right => Positions (Container)'Old,
- New_Key => Last (Container)'Old)
-
- -- The positions of other cursors are preserved
-
- and Positions (Container) <= Positions (Container)'Old;
-
- procedure Delete_Last (Container : in out List; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count =>
- Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old
-
- -- At most Count cursors have been removed at the end of Container
-
- and P_Positions_Truncated
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Length (Container) + 1,
- Count => Count));
-
- procedure Reverse_Elements (Container : in out List) with
- Global => null,
- Post => M_Elements_Reversed (Model (Container)'Old, Model (Container));
-
- procedure Swap
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- with
- Global => null,
- Pre => Has_Element (Container, I) and then Has_Element (Container, J),
- Post =>
- M_Elements_Swapped
- (Model (Container)'Old,
- Model (Container),
- X => P.Get (Positions (Container)'Old, I),
- Y => P.Get (Positions (Container)'Old, J))
-
- and Positions (Container) = Positions (Container)'Old;
-
- procedure Swap_Links
- (Container : in out List;
- I : Cursor;
- J : Cursor)
- with
- Global => null,
- Pre => Has_Element (Container, I) and then Has_Element (Container, J),
- Post =>
- M_Elements_Swapped
- (Model (Container'Old),
- Model (Container),
- X => P.Get (Positions (Container)'Old, I),
- Y => P.Get (Positions (Container)'Old, J))
- and P_Positions_Swapped
- (Positions (Container)'Old, Positions (Container), I, J);
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List)
- -- Target and Source should not be aliased
- with
- Global => null,
- Pre =>
- Length (Source) <= Count_Type'Last - Length (Target)
- and then (Has_Element (Target, Before) or else Before = No_Element),
- Post =>
- Length (Source) = 0
- and Length (Target) = Length (Target)'Old + Length (Source)'Old,
- Contract_Cases =>
- (Before = No_Element =>
-
- -- The elements of Target are preserved
-
- M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => Length (Target)'Old)
-
- -- The elements of Source are appended to target, the order is not
- -- specified.
-
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Fst => Length (Target)'Old + 1,
- R_Lst => Length (Target))
-
- and M_Elements_Included
- (Left => Model (Target),
- L_Fst => Length (Target)'Old + 1,
- L_Lst => Length (Target),
- Right => Model (Source)'Old,
- R_Lst => Length (Source)'Old)
-
- -- Cursors have been inserted at the end of Target
-
- and P_Positions_Truncated
- (Positions (Target)'Old,
- Positions (Target),
- Cut => Length (Target)'Old + 1,
- Count => Length (Source)'Old),
-
- others =>
-
- -- The elements of Target located before Before are preserved
-
- M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => P.Get (Positions (Target)'Old, Before) - 1)
-
- -- The elements of Source are inserted before Before, the order is
- -- not specified.
-
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Fst => P.Get (Positions (Target)'Old, Before),
- R_Lst =>
- P.Get (Positions (Target)'Old, Before) - 1 +
- Length (Source)'Old)
-
- and M_Elements_Included
- (Left => Model (Target),
- L_Fst => P.Get (Positions (Target)'Old, Before),
- L_Lst =>
- P.Get (Positions (Target)'Old, Before) - 1 +
- Length (Source)'Old,
- Right => Model (Source)'Old,
- R_Lst => Length (Source)'Old)
-
- -- Other elements are shifted by the length of Source
-
- and M.Range_Shifted
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => P.Get (Positions (Target)'Old, Before),
- Lst => Length (Target)'Old,
- Offset => Length (Source)'Old)
-
- -- Cursors have been inserted at position Before in Target
-
- and P_Positions_Shifted
- (Positions (Target)'Old,
- Positions (Target),
- Cut => P.Get (Positions (Target)'Old, Before),
- Count => Length (Source)'Old));
-
- procedure Splice
- (Target : in out List;
- Before : Cursor;
- Source : in out List;
- Position : in out Cursor)
- -- Target and Source should not be aliased
- with
- Global => null,
- Pre =>
- (Has_Element (Target, Before) or else Before = No_Element)
- and then Has_Element (Source, Position)
- and then Length (Target) < Count_Type'Last,
- Post =>
- Length (Target) = Length (Target)'Old + 1
- and Length (Source) = Length (Source)'Old - 1
-
- -- The elements of Source located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Source)'Old,
- Right => Model (Source),
- Fst => 1,
- Lst => P.Get (Positions (Source)'Old, Position'Old) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Source)'Old,
- Right => Model (Source),
- Fst => P.Get (Positions (Source)'Old, Position'Old) + 1,
- Lst => Length (Source)'Old,
- Offset => -1)
-
- -- Position has been removed from Source
-
- and P_Positions_Shifted
- (Positions (Source),
- Positions (Source)'Old,
- Cut => P.Get (Positions (Source)'Old, Position'Old))
-
- -- Positions is valid in Target and it is located either before
- -- Before if it is valid in Target or at the end if it is No_Element.
-
- and P.Has_Key (Positions (Target), Position)
- and (if Before = No_Element then
- P.Get (Positions (Target), Position) = Length (Target)
- else
- P.Get (Positions (Target), Position) =
- P.Get (Positions (Target)'Old, Before))
-
- -- The elements of Target located before Position are preserved
-
- and M.Range_Equal
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => 1,
- Lst => P.Get (Positions (Target), Position) - 1)
-
- -- Other elements are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Target)'Old,
- Right => Model (Target),
- Fst => P.Get (Positions (Target), Position),
- Lst => Length (Target)'Old,
- Offset => 1)
-
- -- The element located at Position in Source is moved to Target
-
- and Element (Model (Target),
- P.Get (Positions (Target), Position)) =
- Element (Model (Source)'Old,
- P.Get (Positions (Source)'Old, Position'Old))
-
- -- A new cursor has been inserted at position Position in Target
-
- and P_Positions_Shifted
- (Positions (Target)'Old,
- Positions (Target),
- Cut => P.Get (Positions (Target), Position));
-
- procedure Splice
- (Container : in out List;
- Before : Cursor;
- Position : Cursor)
- with
- Global => null,
- Pre =>
- (Has_Element (Container, Before) or else Before = No_Element)
- and then Has_Element (Container, Position),
- Post => Length (Container) = Length (Container)'Old,
- Contract_Cases =>
- (Before = Position =>
- Model (Container) = Model (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- Before = No_Element =>
-
- -- The elements located before Position are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Position) + 1,
- Lst => Length (Container)'Old,
- Offset => -1)
-
- -- The last element of Container is the one that was previously at
- -- Position.
-
- and Element (Model (Container),
- Length (Container)) =
- Element (Model (Container)'Old,
- P.Get (Positions (Container)'Old, Position))
-
- -- Cursors from Container continue designating the same elements
-
- and Mapping_Preserved
- (M_Left => Model (Container)'Old,
- M_Right => Model (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container)),
-
- others =>
-
- -- The elements located before Position and Before are preserved
-
- M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => 1,
- Lst =>
- Count_Type'Min
- (P.Get (Positions (Container)'Old, Position) - 1,
- P.Get (Positions (Container)'Old, Before) - 1))
-
- -- The elements located after Position and Before are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst =>
- Count_Type'Max
- (P.Get (Positions (Container)'Old, Position) + 1,
- P.Get (Positions (Container)'Old, Before) + 1),
- Lst => Length (Container))
-
- -- The elements located after Before and before Position are
- -- shifted by 1 to the right.
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Before) + 1,
- Lst => P.Get (Positions (Container)'Old, Position) - 1,
- Offset => 1)
-
- -- The elements located after Position and before Before are
- -- shifted by 1 to the left.
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => P.Get (Positions (Container)'Old, Position) + 1,
- Lst => P.Get (Positions (Container)'Old, Before) - 1,
- Offset => -1)
-
- -- The element previously at Position is now before Before
-
- and Element
- (Model (Container),
- P.Get (Positions (Container)'Old, Before)) =
- Element
- (Model (Container)'Old,
- P.Get (Positions (Container)'Old, Position))
-
- -- Cursors from Container continue designating the same elements
-
- and Mapping_Preserved
- (M_Left => Model (Container)'Old,
- M_Right => Model (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container)));
-
- function First (Container : List) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
-
- function First_Element (Container : List) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post => First_Element'Result = M.Get (Model (Container), 1);
-
- function Last (Container : List) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- Last'Result = No_Element,
-
- others =>
- Has_Element (Container, Last'Result)
- and P.Get (Positions (Container), Last'Result) =
- Length (Container));
-
- function Last_Element (Container : List) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result = M.Get (Model (Container), Length (Container));
-
- function Next (Container : List; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
-
- procedure Next (Container : List; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
-
- function Previous (Container : List; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Previous'Result = No_Element,
-
- others =>
- Has_Element (Container, Previous'Result)
- and then P.Get (Positions (Container), Previous'Result) =
- P.Get (Positions (Container), Position) - 1);
-
- procedure Previous (Container : List; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) - 1);
-
- function Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
-
- -- If Item is not contained in Container after Position, Find returns
- -- No_Element.
-
- (not M.Contains
- (Container => Model (Container),
- Fst =>
- (if Position = No_Element then
- 1
- else
- P.Get (Positions (Container), Position)),
- Lst => Length (Container),
- Item => Item)
- =>
- Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
-
- -- The element designated by the result of Find is Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Find'Result)) = Item
-
- -- The result of Find is located after Position
-
- and (if Position /= No_Element then
- P.Get (Positions (Container), Find'Result) >=
- P.Get (Positions (Container), Position))
-
- -- It is the first occurrence of Item in this slice
-
- and not M.Contains
- (Container => Model (Container),
- Fst =>
- (if Position = No_Element then
- 1
- else
- P.Get (Positions (Container), Position)),
- Lst =>
- P.Get (Positions (Container), Find'Result) - 1,
- Item => Item));
-
- function Reverse_Find
- (Container : List;
- Item : Element_Type;
- Position : Cursor := No_Element) return Cursor
- with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
-
- -- If Item is not contained in Container before Position, Find returns
- -- No_Element.
-
- (not M.Contains
- (Container => Model (Container),
- Fst => 1,
- Lst =>
- (if Position = No_Element then
- Length (Container)
- else
- P.Get (Positions (Container), Position)),
- Item => Item)
- =>
- Reverse_Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Reverse_Find'Result)
-
- -- The element designated by the result of Find is Item
-
- and Element
- (Model (Container),
- P.Get (Positions (Container), Reverse_Find'Result)) = Item
-
- -- The result of Find is located before Position
-
- and (if Position /= No_Element then
- P.Get (Positions (Container), Reverse_Find'Result) <=
- P.Get (Positions (Container), Position))
-
- -- It is the last occurrence of Item in this slice
-
- and not M.Contains
- (Container => Model (Container),
- Fst =>
- P.Get (Positions (Container),
- Reverse_Find'Result) + 1,
- Lst =>
- (if Position = No_Element then
- Length (Container)
- else
- P.Get (Positions (Container), Position)),
- Item => Item));
-
- function Contains
- (Container : List;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Post =>
- Contains'Result = M.Contains (Container => Model (Container),
- Fst => 1,
- Lst => Length (Container),
- Item => Item);
-
- function Has_Element
- (Container : List;
- Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- generic
- with function "<" (Left, Right : Element_Type) return Boolean is <>;
-
- package Generic_Sorting with SPARK_Mode is
-
- package Formal_Model with Ghost is
- function M_Elements_Sorted (Container : M.Sequence) return Boolean
- with
- Global => null,
- Post =>
- M_Elements_Sorted'Result =
- (for all I in 1 .. M.Length (Container) =>
- (for all J in I .. M.Length (Container) =>
- not (Element (Container, J) < Element (Container, I))));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted);
-
- end Formal_Model;
- use Formal_Model;
-
- function Is_Sorted (Container : List) return Boolean with
- Global => null,
- Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container));
-
- procedure Sort (Container : in out List) with
- Global => null,
- Post =>
- Length (Container) = Length (Container)'Old
- and M_Elements_Sorted (Model (Container))
- and M_Elements_Included
- (Left => Model (Container)'Old,
- L_Lst => Length (Container),
- Right => Model (Container),
- R_Lst => Length (Container))
- and M_Elements_Included
- (Left => Model (Container),
- L_Lst => Length (Container),
- Right => Model (Container)'Old,
- R_Lst => Length (Container));
-
- procedure Merge (Target : in out List; Source : in out List) with
- -- Target and Source should not be aliased
- Global => null,
- Pre => Length (Target) <= Count_Type'Last - Length (Source),
- Post =>
- Length (Target) = Length (Target)'Old + Length (Source)'Old
- and Length (Source) = 0
- and (if M_Elements_Sorted (Model (Target)'Old)
- and M_Elements_Sorted (Model (Source)'Old)
- then
- M_Elements_Sorted (Model (Target)))
- and M_Elements_Included
- (Left => Model (Target)'Old,
- L_Lst => Length (Target)'Old,
- Right => Model (Target),
- R_Lst => Length (Target))
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Length (Source)'Old,
- Right => Model (Target),
- R_Lst => Length (Target))
- and M_Elements_In_Union
- (Model (Target),
- Model (Source)'Old,
- Model (Target)'Old);
- end Generic_Sorting;
-
-private
- pragma SPARK_Mode (Off);
-
- use Ada.Finalization;
-
- type Element_Access is access all Element_Type;
-
- type Node_Type is record
- Prev : Count_Type'Base := -1;
- Next : Count_Type := 0;
- Element : Element_Access := null;
- end record;
-
- type Node_Access is access all Node_Type;
-
- function "=" (L, R : Node_Type) return Boolean is abstract;
-
- type Node_Array is array (Count_Type range <>) of Node_Type;
- function "=" (L, R : Node_Array) return Boolean is abstract;
-
- type Node_Array_Access is access all Node_Array;
+package Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with SPARK_Mode is
- type List is new Controlled with record
- Free : Count_Type'Base := -1;
- Length : Count_Type := 0;
- First : Count_Type := 0;
- Last : Count_Type := 0;
- Nodes : Node_Array_Access := null;
- end record;
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
- overriding procedure Finalize (Container : in out List);
- overriding procedure Adjust (Container : in out List);
end Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_INFINITE_SEQUENCE --
--- --
--- B o d y --
--- --
--- Copyright (C) 2022-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-pragma Ada_2012;
-
-package body Ada.Containers.Functional_Infinite_Sequences
-with SPARK_Mode => Off
-is
- use Containers;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- package Big_From_Count is new Signed_Conversions
- (Int => Count_Type);
-
- function Big (C : Count_Type) return Big_Integer renames
- Big_From_Count.To_Big_Integer;
-
- -- Store Count_Type'Last as a Big Natural because it is often used
-
- Count_Type_Big_Last : constant Big_Natural := Big (Count_Type'Last);
-
- function To_Count (C : Big_Natural) return Count_Type;
- -- Convert Big_Natural to Count_Type
-
- ---------
- -- "<" --
- ---------
-
- function "<" (Left : Sequence; Right : Sequence) return Boolean is
- (Length (Left) < Length (Right)
- and then (for all N in Left =>
- Get (Left, N) = Get (Right, N)));
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (Left : Sequence; Right : Sequence) return Boolean is
- (Length (Left) <= Length (Right)
- and then (for all N in Left =>
- Get (Left, N) = Get (Right, N)));
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Sequence; Right : Sequence) return Boolean is
- (Left.Content = Right.Content);
-
- ---------
- -- Add --
- ---------
-
- function Add (Container : Sequence; New_Item : Element_Type) return Sequence
- is
- (Add (Container, Last (Container) + 1, New_Item));
-
- function Add
- (Container : Sequence;
- Position : Big_Positive;
- New_Item : Element_Type) return Sequence is
- (Content => Add (Container.Content, To_Count (Position), New_Item));
-
- --------------------
- -- Constant_Range --
- --------------------
-
- function Constant_Range
- (Container : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Item : Element_Type) return Boolean
- is
- Count_Fst : constant Count_Type := To_Count (Fst);
- Count_Lst : constant Count_Type := To_Count (Lst);
-
- begin
- for J in Count_Fst .. Count_Lst loop
- if Get (Container.Content, J) /= Item then
- return False;
- end if;
- end loop;
-
- return True;
- end Constant_Range;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Item : Element_Type) return Boolean
- is
- Count_Fst : constant Count_Type := To_Count (Fst);
- Count_Lst : constant Count_Type := To_Count (Lst);
-
- begin
- for J in Count_Fst .. Count_Lst loop
- if Get (Container.Content, J) = Item then
- return True;
- end if;
- end loop;
-
- return False;
- end Contains;
-
- --------------------
- -- Empty_Sequence --
- --------------------
-
- function Empty_Sequence return Sequence is
- (Content => <>);
-
- ------------------
- -- Equal_Except --
- ------------------
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- Position : Big_Positive) return Boolean
- is
- Count_Pos : constant Count_Type := To_Count (Position);
- Count_Lst : constant Count_Type := To_Count (Last (Left));
-
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- for J in 1 .. Count_Lst loop
- if J /= Count_Pos
- and then Get (Left.Content, J) /= Get (Right.Content, J)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Equal_Except;
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- X : Big_Positive;
- Y : Big_Positive) return Boolean
- is
- Count_X : constant Count_Type := To_Count (X);
- Count_Y : constant Count_Type := To_Count (Y);
- Count_Lst : constant Count_Type := To_Count (Last (Left));
-
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- for J in 1 .. Count_Lst loop
- if J /= Count_X
- and then J /= Count_Y
- and then Get (Left.Content, J) /= Get (Right.Content, J)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Equal_Except;
-
- ---------
- -- Get --
- ---------
-
- function Get
- (Container : Sequence;
- Position : Big_Integer) return Element_Type is
- (Get (Container.Content, To_Count (Position)));
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : Sequence) return Big_Natural is
- (Length (Container));
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Sequence) return Big_Natural is
- (Big (Length (Container.Content)));
-
- -----------------
- -- Range_Equal --
- -----------------
-
- function Range_Equal
- (Left : Sequence;
- Right : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural) return Boolean
- is
- Count_Fst : constant Count_Type := To_Count (Fst);
- Count_Lst : constant Count_Type := To_Count (Lst);
-
- begin
- for J in Count_Fst .. Count_Lst loop
- if Get (Left.Content, J) /= Get (Right.Content, J) then
- return False;
- end if;
- end loop;
-
- return True;
- end Range_Equal;
-
- -------------------
- -- Range_Shifted --
- -------------------
-
- function Range_Shifted
- (Left : Sequence;
- Right : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Offset : Big_Integer) return Boolean
- is
- Count_Fst : constant Count_Type := To_Count (Fst);
- Count_Lst : constant Count_Type := To_Count (Lst);
-
- begin
- for J in Count_Fst .. Count_Lst loop
- if Get (Left.Content, J) /= Get (Right, Big (J) + Offset) then
- return False;
- end if;
- end loop;
-
- return True;
- end Range_Shifted;
-
- ------------
- -- Remove --
- ------------
-
- function Remove
- (Container : Sequence;
- Position : Big_Positive) return Sequence is
- (Content => Remove (Container.Content, To_Count (Position)));
-
- ---------
- -- Set --
- ---------
-
- function Set
- (Container : Sequence;
- Position : Big_Positive;
- New_Item : Element_Type) return Sequence is
- (Content => Set (Container.Content, To_Count (Position), New_Item));
-
- --------------
- -- To_Count --
- --------------
-
- function To_Count (C : Big_Natural) return Count_Type is
- begin
- if C > Count_Type_Big_Last then
- raise Program_Error with "Big_Integer too large for Count_Type";
- end if;
- return Big_From_Count.From_Big_Integer (C);
- end To_Count;
-
-end Ada.Containers.Functional_Infinite_Sequences;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-pragma Ada_2012;
-private with Ada.Containers.Functional_Base;
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
generic
- type Element_Type (<>) is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Functional_Infinite_Sequences with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- type Sequence is private
- with Default_Initial_Condition => Length (Sequence) = 0,
- Iterable => (First => Iter_First,
- Has_Element => Iter_Has_Element,
- Next => Iter_Next,
- Element => Get);
- -- Sequences are empty when default initialized.
- -- Quantification over sequences can be done using the regular
- -- quantification over its range or directly on its elements with "for of".
-
- -----------------------
- -- Basic operations --
- -----------------------
-
- -- Sequences are axiomatized using Length and Get, providing respectively
- -- the length of a sequence and an accessor to its Nth element:
-
- function Length (Container : Sequence) return Big_Natural with
- -- Length of a sequence
-
- Global => null;
-
- function Get
- (Container : Sequence;
- Position : Big_Integer) return Element_Type
- -- Access the Element at position Position in Container
-
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Position);
-
- function Last (Container : Sequence) return Big_Natural with
- -- Last index of a sequence
-
- Global => null,
- Post =>
- Last'Result = Length (Container);
- pragma Annotate (GNATprove, Inline_For_Proof, Last);
-
- function First return Big_Positive is (1) with
- -- First index of a sequence
-
- Global => null;
-
- ------------------------
- -- Property Functions --
- ------------------------
-
- function "=" (Left : Sequence; Right : Sequence) return Boolean with
- -- Extensional equality over sequences
-
- Global => null,
- Post =>
- "="'Result =
- (Length (Left) = Length (Right)
- and then (for all N in Left => Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "=");
-
- function "<" (Left : Sequence; Right : Sequence) return Boolean with
- -- Left is a strict subsequence of Right
-
- Global => null,
- Post =>
- "<"'Result =
- (Length (Left) < Length (Right)
- and then (for all N in Left => Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "<");
-
- function "<=" (Left : Sequence; Right : Sequence) return Boolean with
- -- Left is a subsequence of Right
-
- Global => null,
- Post =>
- "<="'Result =
- (Length (Left) <= Length (Right)
- and then (for all N in Left => Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "<=");
-
- function Contains
- (Container : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Item : Element_Type) return Boolean
- -- Returns True if Item occurs in the range from Fst to Lst of Container
-
- with
- Global => null,
- Pre => Lst <= Last (Container),
- Post =>
- Contains'Result =
- (for some J in Container =>
- Fst <= J and J <= Lst and Get (Container, J) = Item);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Constant_Range
- (Container : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Item : Element_Type) return Boolean
- -- Returns True if every element of the range from Fst to Lst of Container
- -- is equal to Item.
-
- with
- Global => null,
- Pre => Lst <= Last (Container),
- Post =>
- Constant_Range'Result =
- (for all J in Container =>
- (if Fst <= J and J <= Lst then Get (Container, J) = Item));
- pragma Annotate (GNATprove, Inline_For_Proof, Constant_Range);
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- Position : Big_Positive) return Boolean
- -- Returns True is Left and Right are the same except at position Position
-
- with
- Global => null,
- Pre => Position <= Last (Left),
- Post =>
- Equal_Except'Result =
- (Length (Left) = Length (Right)
- and then (for all J in Left =>
- (if J /= Position then
- Get (Left, J) = Get (Right, J))));
- pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except);
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- X : Big_Positive;
- Y : Big_Positive) return Boolean
- -- Returns True is Left and Right are the same except at positions X and Y
-
- with
- Global => null,
- Pre => X <= Last (Left) and Y <= Last (Left),
- Post =>
- Equal_Except'Result =
- (Length (Left) = Length (Right)
- and then (for all J in Left =>
- (if J /= X and J /= Y then
- Get (Left, J) = Get (Right, J))));
- pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except);
-
- function Range_Equal
- (Left : Sequence;
- Right : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural) return Boolean
- -- Returns True if the ranges from Fst to Lst contain the same elements in
- -- Left and Right.
-
- with
- Global => null,
- Pre => Lst <= Last (Left) and Lst <= Last (Right),
- Post =>
- Range_Equal'Result =
- (for all J in Left =>
- (if Fst <= J and J <= Lst then Get (Left, J) = Get (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, Range_Equal);
-
- function Range_Shifted
- (Left : Sequence;
- Right : Sequence;
- Fst : Big_Positive;
- Lst : Big_Natural;
- Offset : Big_Integer) return Boolean
- -- Returns True if the range from Fst to Lst in Left contains the same
- -- elements as the range from Fst + Offset to Lst + Offset in Right.
-
- with
- Global => null,
- Pre =>
- Lst <= Last (Left)
- and then
- (if Fst <= Lst then
- Offset + Fst >= 1 and Offset + Lst <= Length (Right)),
- Post =>
- Range_Shifted'Result =
- ((for all J in Left =>
- (if Fst <= J and J <= Lst then
- Get (Left, J) = Get (Right, J + Offset)))
- and
- (for all J in Right =>
- (if Fst + Offset <= J and J <= Lst + Offset then
- Get (Left, J - Offset) = Get (Right, J))));
- pragma Annotate (GNATprove, Inline_For_Proof, Range_Shifted);
-
- ----------------------------
- -- Construction Functions --
- ----------------------------
-
- -- For better efficiency of both proofs and execution, avoid using
- -- construction functions in annotations and rather use property functions.
-
- function Set
- (Container : Sequence;
- Position : Big_Positive;
- New_Item : Element_Type) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- except for the one at position Position which is replaced by New_Item.
-
- with
- Global => null,
- Pre => Position <= Last (Container),
- Post =>
- Get (Set'Result, Position) = New_Item
- and then Equal_Except (Container, Set'Result, Position);
-
- function Add (Container : Sequence; New_Item : Element_Type) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- plus New_Item at the end.
-
- with
- Global => null,
- Post =>
- Length (Add'Result) = Length (Container) + 1
- and then Get (Add'Result, Last (Add'Result)) = New_Item
- and then Container <= Add'Result;
-
- function Add
- (Container : Sequence;
- Position : Big_Positive;
- New_Item : Element_Type) return Sequence
- with
- -- Returns a new sequence which contains the same elements as Container
- -- except that New_Item has been inserted at position Position.
-
- Global => null,
- Pre => Position <= Last (Container) + 1,
- Post =>
- Length (Add'Result) = Length (Container) + 1
- and then Get (Add'Result, Position) = New_Item
- and then Range_Equal
- (Left => Container,
- Right => Add'Result,
- Fst => 1,
- Lst => Position - 1)
- and then Range_Shifted
- (Left => Container,
- Right => Add'Result,
- Fst => Position,
- Lst => Last (Container),
- Offset => 1);
-
- function Remove
- (Container : Sequence;
- Position : Big_Positive) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- except that the element at position Position has been removed.
-
- with
- Global => null,
- Pre => Position <= Last (Container),
- Post =>
- Length (Remove'Result) = Length (Container) - 1
- and then Range_Equal
- (Left => Container,
- Right => Remove'Result,
- Fst => 1,
- Lst => Position - 1)
- and then Range_Shifted
- (Left => Remove'Result,
- Right => Container,
- Fst => Position,
- Lst => Last (Remove'Result),
- Offset => 1);
-
- function Copy_Element (Item : Element_Type) return Element_Type is (Item);
- -- Elements of containers are copied by numerous primitives in this
- -- package. This function causes GNATprove to verify that such a copy is
- -- valid (in particular, it does not break the ownership policy of SPARK,
- -- i.e. it does not contain pointers that could be used to alias mutable
- -- data).
-
- function Empty_Sequence return Sequence with
- -- Return an empty Sequence
-
- Global => null,
- Post => Length (Empty_Sequence'Result) = 0;
-
- ---------------------------
- -- Iteration Primitives --
- ---------------------------
-
- function Iter_First (Container : Sequence) return Big_Integer with
- Global => null,
- Post => Iter_First'Result = 1;
-
- function Iter_Has_Element
- (Container : Sequence;
- Position : Big_Integer) return Boolean
- with
- Global => null,
- Post => Iter_Has_Element'Result =
- In_Range (Position, 1, Length (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element);
-
- function Iter_Next
- (Container : Sequence;
- Position : Big_Integer) return Big_Integer
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Position),
- Post => Iter_Next'Result = Position + 1;
-
-private
- pragma SPARK_Mode (Off);
-
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package Containers is new Ada.Containers.Functional_Base
- (Index_Type => Positive_Count_Type,
- Element_Type => Element_Type);
-
- type Sequence is record
- Content : Containers.Container;
- end record;
-
- function Iter_First (Container : Sequence) return Big_Integer is (1);
+package Ada.Containers.Functional_Infinite_Sequences with SPARK_Mode is
- function Iter_Next
- (Container : Sequence;
- Position : Big_Integer) return Big_Integer
- is
- (Position + 1);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
- function Iter_Has_Element
- (Container : Sequence;
- Position : Big_Integer) return Boolean
- is
- (In_Range (Position, 1, Length (Container)));
end Ada.Containers.Functional_Infinite_Sequences;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FORMAL_INDEFINITE_VECTORS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Generic_Array_Sort;
-with Ada.Unchecked_Deallocation;
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Indefinite_Vectors with
- SPARK_Mode => Off
-is
- function H (New_Item : Element_Type) return Holder renames To_Holder;
- function E (Container : Holder) return Element_Type renames Get;
-
- Growth_Factor : constant := 2;
- -- When growing a container, multiply current capacity by this. Doubling
- -- leads to amortized linear-time copying.
-
- subtype Int is Long_Long_Integer;
-
- procedure Free is
- new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr);
-
- type Maximal_Array_Ptr is access all Elements_Array (Array_Index)
- with Storage_Size => 0;
- type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index)
- with Storage_Size => 0;
-
- function Elems (Container : in out Vector) return Maximal_Array_Ptr;
- function Elemsc
- (Container : Vector) return Maximal_Array_Ptr_Const;
- -- Returns a pointer to the Elements array currently in use -- either
- -- Container.Elements_Ptr or a pointer to Container.Elements. We work with
- -- pointers to a bogus array subtype that is constrained with the maximum
- -- possible bounds. This means that the pointer is a thin pointer. This is
- -- necessary because 'Unrestricted_Access doesn't work when it produces
- -- access-to-unconstrained and is returned from a function.
- --
- -- Note that this is dangerous: make sure calls to this use an indexed
- -- component or slice that is within the bounds 1 .. Length (Container).
-
- function Get_Element
- (Container : Vector;
- Position : Capacity_Range) return Element_Type;
-
- function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base;
-
- function Current_Capacity (Container : Vector) return Capacity_Range;
-
- procedure Insert_Space
- (Container : in out Vector;
- Before : Extended_Index;
- Count : Count_Type := 1);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Vector; Right : Vector) return Boolean is
- begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- for J in 1 .. Length (Left) loop
- if Get_Element (Left, J) /= Get_Element (Right, J) then
- return False;
- end if;
- end loop;
-
- return True;
- end "=";
-
- ------------
- -- Append --
- ------------
-
- procedure Append (Container : in out Vector; New_Item : Vector) is
- begin
- if Is_Empty (New_Item) then
- return;
- end if;
-
- if Container.Last >= Index_Type'Last then
- raise Constraint_Error with "vector is already at its maximum length";
- end if;
-
- Insert (Container, Container.Last + 1, New_Item);
- end Append;
-
- procedure Append (Container : in out Vector; New_Item : Element_Type) is
- begin
- Append (Container, New_Item, 1);
- end Append;
-
- procedure Append
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- if Count = 0 then
- return;
- end if;
-
- if Container.Last >= Index_Type'Last then
- raise Constraint_Error with "vector is already at its maximum length";
- end if;
-
- Insert (Container, Container.Last + 1, New_Item, Count);
- end Append;
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out Vector; Source : Vector) is
- LS : constant Capacity_Range := Length (Source);
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Bounded and then Target.Capacity < LS then
- raise Constraint_Error;
- end if;
-
- Clear (Target);
- Append (Target, Source);
- end Assign;
-
- --------------
- -- Capacity --
- --------------
-
- function Capacity (Container : Vector) return Capacity_Range is
- begin
- return
- (if Bounded then
- Container.Capacity
- else
- Capacity_Range'Last);
- end Capacity;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Vector) is
- begin
- Container.Last := No_Index;
-
- -- Free element, note that this is OK if Elements_Ptr is null
-
- Free (Container.Elements_Ptr);
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Vector;
- Index : Index_Type) return not null access constant Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
-
- begin
- return Constant_Reference (Elemsc (Container) (I));
- end;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Vector;
- Item : Element_Type) return Boolean
- is
- begin
- return Find_Index (Container, Item) /= No_Index;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy
- (Source : Vector;
- Capacity : Capacity_Range := 0) return Vector
- is
- LS : constant Capacity_Range := Length (Source);
- C : Capacity_Range;
-
- begin
- if Capacity = 0 then
- C := LS;
- elsif Capacity >= LS then
- C := Capacity;
- else
- raise Capacity_Error;
- end if;
-
- return Target : Vector (C) do
- Elems (Target) (1 .. LS) := Elemsc (Source) (1 .. LS);
- Target.Last := Source.Last;
- end return;
- end Copy;
-
- ----------------------
- -- Current_Capacity --
- ----------------------
-
- function Current_Capacity (Container : Vector) return Capacity_Range is
- begin
- return
- (if Container.Elements_Ptr = null then
- Container.Elements'Length
- else
- Container.Elements_Ptr.all'Length);
- end Current_Capacity;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Vector; Index : Extended_Index) is
- begin
- Delete (Container, Index, 1);
- end Delete;
-
- procedure Delete
- (Container : in out Vector;
- Index : Extended_Index;
- Count : Count_Type)
- is
- Old_Last : constant Index_Type'Base := Container.Last;
- Old_Len : constant Count_Type := Length (Container);
- New_Last : Index_Type'Base;
- Count2 : Count_Type'Base; -- count of items from Index to Old_Last
- Off : Count_Type'Base; -- Index expressed as offset from IT'First
-
- begin
- -- Delete removes items from the vector, the number of which is the
- -- minimum of the specified Count and the items (if any) that exist from
- -- Index to Container.Last. There are no constraints on the specified
- -- value of Count (it can be larger than what's available at this
- -- position in the vector, for example), but there are constraints on
- -- the allowed values of the Index.
-
- -- As a precondition on the generic actual Index_Type, the base type
- -- must include Index_Type'Pred (Index_Type'First); this is the value
- -- that Container.Last assumes when the vector is empty. However, we do
- -- not allow that as the value for Index when specifying which items
- -- should be deleted, so we must manually check. (That the user is
- -- allowed to specify the value at all here is a consequence of the
- -- declaration of the Extended_Index subtype, which includes the values
- -- in the base range that immediately precede and immediately follow the
- -- values in the Index_Type.)
-
- if Index < Index_Type'First then
- raise Constraint_Error with "Index is out of range (too small)";
- end if;
-
- -- We do allow a value greater than Container.Last to be specified as
- -- the Index, but only if it's immediately greater. This allows the
- -- corner case of deleting no items from the back end of the vector to
- -- be treated as a no-op. (It is assumed that specifying an index value
- -- greater than Last + 1 indicates some deeper flaw in the caller's
- -- algorithm, so that case is treated as a proper error.)
-
- if Index > Old_Last then
- if Index > Old_Last + 1 then
- raise Constraint_Error with "Index is out of range (too large)";
- end if;
-
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- -- We first calculate what's available for deletion starting at
- -- Index. Here and elsewhere we use the wider of Index_Type'Base and
- -- Count_Type'Base as the type for intermediate values. (See function
- -- Length for more information.)
-
- if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
- Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
- else
- Count2 := Count_Type'Base (Old_Last - Index + 1);
- end if;
-
- -- If more elements are requested (Count) for deletion than are
- -- available (Count2) for deletion beginning at Index, then everything
- -- from Index is deleted. There are no elements to slide down, and so
- -- all we need to do is set the value of Container.Last.
-
- if Count >= Count2 then
- Container.Last := Index - 1;
- return;
- end if;
-
- -- There are some elements that aren't being deleted (the requested
- -- count was less than the available count), so we must slide them down
- -- to Index. We first calculate the index values of the respective array
- -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
- -- type for intermediate calculations.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Off := Count_Type'Base (Index - Index_Type'First);
- New_Last := Old_Last - Index_Type'Base (Count);
- else
- Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
- New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
- end if;
-
- -- The array index values for each slice have already been determined,
- -- so we just slide down to Index the elements that weren't deleted.
-
- declare
- EA : Maximal_Array_Ptr renames Elems (Container);
- Idx : constant Count_Type := EA'First + Off;
-
- begin
- EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
- Container.Last := New_Last;
- end;
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out Vector) is
- begin
- Delete_First (Container, 1);
- end Delete_First;
-
- procedure Delete_First (Container : in out Vector; Count : Count_Type) is
- begin
- if Count = 0 then
- return;
-
- elsif Count >= Length (Container) then
- Clear (Container);
- return;
-
- else
- Delete (Container, Index_Type'First, Count);
- end if;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out Vector) is
- begin
- Delete_Last (Container, 1);
- end Delete_Last;
-
- procedure Delete_Last (Container : in out Vector; Count : Count_Type) is
- begin
- if Count = 0 then
- return;
- end if;
-
- -- There is no restriction on how large Count can be when deleting
- -- items. If it is equal or greater than the current length, then this
- -- is equivalent to clearing the vector. (In particular, there's no need
- -- for us to actually calculate the new value for Last.)
-
- -- If the requested count is less than the current length, then we must
- -- calculate the new value for Last. For the type we use the widest of
- -- Index_Type'Base and Count_Type'Base for the intermediate values of
- -- our calculation. (See the comments in Length for more information.)
-
- if Count >= Length (Container) then
- Container.Last := No_Index;
-
- elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Container.Last := Container.Last - Index_Type'Base (Count);
-
- else
- Container.Last :=
- Index_Type'Base (Count_Type'Base (Container.Last) - Count);
- end if;
- end Delete_Last;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : Vector;
- Index : Extended_Index) return Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
-
- begin
- return Get_Element (Container, I);
- end;
- end Element;
-
- -----------
- -- Elems --
- -----------
-
- function Elems (Container : in out Vector) return Maximal_Array_Ptr is
- begin
- return
- (if Container.Elements_Ptr = null then
- Container.Elements'Unrestricted_Access
- else
- Container.Elements_Ptr.all'Unrestricted_Access);
- end Elems;
-
- function Elemsc (Container : Vector) return Maximal_Array_Ptr_Const is
- begin
- return
- (if Container.Elements_Ptr = null then
- Container.Elements'Unrestricted_Access
- else
- Container.Elements_Ptr.all'Unrestricted_Access);
- end Elemsc;
-
- ----------------
- -- Find_Index --
- ----------------
-
- function Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'First) return Extended_Index
- is
- K : Count_Type;
- Last : constant Extended_Index := Last_Index (Container);
-
- begin
- K := Capacity_Range (Int (Index) - Int (No_Index));
- for Indx in Index .. Last loop
- if Get_Element (Container, K) = Item then
- return Indx;
- end if;
-
- K := K + 1;
- end loop;
-
- return No_Index;
- end Find_Index;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : Vector) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "Container is empty";
- else
- return Get_Element (Container, 1);
- end if;
- end First_Element;
-
- -----------------
- -- First_Index --
- -----------------
-
- function First_Index (Container : Vector) return Index_Type is
- pragma Unreferenced (Container);
- begin
- return Index_Type'First;
- end First_Index;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -------------------------
- -- M_Elements_In_Union --
- -------------------------
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- begin
- for Index in Index_Type'First .. M.Last (Container) loop
- declare
- Elem : constant Element_Type := Element (Container, Index);
- begin
- if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem)
- and then
- not M.Contains
- (Right, Index_Type'First, M.Last (Right), Elem)
- then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end M_Elements_In_Union;
-
- -------------------------
- -- M_Elements_Included --
- -------------------------
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Index_Type := Index_Type'First;
- L_Lst : Extended_Index;
- Right : M.Sequence;
- R_Fst : Index_Type := Index_Type'First;
- R_Lst : Extended_Index) return Boolean
- is
- begin
- for I in L_Fst .. L_Lst loop
- declare
- Found : Boolean := False;
- J : Extended_Index := R_Fst - 1;
-
- begin
- while not Found and J < R_Lst loop
- J := J + 1;
- if Element (Left, I) = Element (Right, J) then
- Found := True;
- end if;
- end loop;
-
- if not Found then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end M_Elements_Included;
-
- -------------------------
- -- M_Elements_Reversed --
- -------------------------
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- L : constant Index_Type := M.Last (Left);
-
- begin
- if L /= M.Last (Right) then
- return False;
- end if;
-
- for I in Index_Type'First .. L loop
- if Element (Left, I) /= Element (Right, L - I + 1)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Reversed;
-
- ------------------------
- -- M_Elements_Swapped --
- ------------------------
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- is
- begin
- if M.Length (Left) /= M.Length (Right)
- or else Element (Left, X) /= Element (Right, Y)
- or else Element (Left, Y) /= Element (Right, X)
- then
- return False;
- end if;
-
- for I in Index_Type'First .. M.Last (Left) loop
- if I /= X and then I /= Y
- and then Element (Left, I) /= Element (Right, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Swapped;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Vector) return M.Sequence is
- R : M.Sequence;
-
- begin
- for Position in 1 .. Length (Container) loop
- R := M.Add (R, E (Elemsc (Container) (Position)));
- end loop;
-
- return R;
- end Model;
-
- end Formal_Model;
-
- ---------------------
- -- Generic_Sorting --
- ---------------------
-
- package body Generic_Sorting with SPARK_Mode => Off is
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -----------------------
- -- M_Elements_Sorted --
- -----------------------
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean is
- begin
- if M.Length (Container) = 0 then
- return True;
- end if;
-
- declare
- E1 : Element_Type := Element (Container, Index_Type'First);
-
- begin
- for I in Index_Type'First + 1 .. M.Last (Container) loop
- declare
- E2 : constant Element_Type := Element (Container, I);
-
- begin
- if E2 < E1 then
- return False;
- end if;
-
- E1 := E2;
- end;
- end loop;
- end;
-
- return True;
- end M_Elements_Sorted;
-
- end Formal_Model;
-
- ---------------
- -- Is_Sorted --
- ---------------
-
- function Is_Sorted (Container : Vector) return Boolean is
- L : constant Capacity_Range := Length (Container);
-
- begin
- for J in 1 .. L - 1 loop
- if Get_Element (Container, J + 1) < Get_Element (Container, J) then
- return False;
- end if;
- end loop;
-
- return True;
- end Is_Sorted;
-
- ----------
- -- Sort --
- ----------
-
- procedure Sort (Container : in out Vector) is
- function "<" (Left : Holder; Right : Holder) return Boolean is
- (E (Left) < E (Right));
-
- procedure Sort is new Generic_Array_Sort
- (Index_Type => Array_Index,
- Element_Type => Holder,
- Array_Type => Elements_Array,
- "<" => "<");
-
- Len : constant Capacity_Range := Length (Container);
-
- begin
- if Container.Last <= Index_Type'First then
- return;
- else
- Sort (Elems (Container) (1 .. Len));
- end if;
- end Sort;
-
- -----------
- -- Merge --
- -----------
-
- procedure Merge (Target : in out Vector; Source : in out Vector) is
- I : Count_Type;
- J : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Length (Source) = 0 then
- return;
- end if;
-
- if Length (Target) = 0 then
- Move (Target => Target, Source => Source);
- return;
- end if;
-
- I := Length (Target);
-
- declare
- New_Length : constant Count_Type := I + Length (Source);
-
- begin
- if not Bounded
- and then Current_Capacity (Target) < Capacity_Range (New_Length)
- then
- Reserve_Capacity
- (Target,
- Capacity_Range'Max
- (Current_Capacity (Target) * Growth_Factor,
- Capacity_Range (New_Length)));
- end if;
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Target.Last := No_Index + Index_Type'Base (New_Length);
-
- else
- Target.Last :=
- Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
- end if;
- end;
-
- declare
- TA : Maximal_Array_Ptr renames Elems (Target);
- SA : Maximal_Array_Ptr renames Elems (Source);
-
- begin
- J := Length (Target);
- while Length (Source) /= 0 loop
- if I = 0 then
- TA (1 .. J) := SA (1 .. Length (Source));
- Source.Last := No_Index;
- exit;
- end if;
-
- if E (SA (Length (Source))) < E (TA (I)) then
- TA (J) := TA (I);
- I := I - 1;
-
- else
- TA (J) := SA (Length (Source));
- Source.Last := Source.Last - 1;
- end if;
-
- J := J - 1;
- end loop;
- end;
- end Merge;
-
- end Generic_Sorting;
-
- -----------------
- -- Get_Element --
- -----------------
-
- function Get_Element
- (Container : Vector;
- Position : Capacity_Range) return Element_Type
- is
- begin
- return E (Elemsc (Container) (Position));
- end Get_Element;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- is
- begin
- return Position in First_Index (Container) .. Last_Index (Container);
- end Has_Element;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type)
- is
- begin
- Insert (Container, Before, New_Item, 1);
- end Insert;
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- J : Count_Type'Base; -- scratch
-
- begin
- -- Use Insert_Space to create the "hole" (the destination slice)
-
- Insert_Space (Container, Before, Count);
-
- J := To_Array_Index (Before);
-
- Elems (Container) (J .. J - 1 + Count) := [others => H (New_Item)];
- end Insert;
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Vector)
- is
- N : constant Count_Type := Length (New_Item);
- B : Count_Type; -- index Before converted to Count_Type
-
- begin
- if Container'Address = New_Item'Address then
- raise Program_Error with
- "Container and New_Item denote same container";
- end if;
-
- -- Use Insert_Space to create the "hole" (the destination slice) into
- -- which we copy the source items.
-
- Insert_Space (Container, Before, Count => N);
-
- if N = 0 then
- -- There's nothing else to do here (vetting of parameters was
- -- performed already in Insert_Space), so we simply return.
-
- return;
- end if;
-
- B := To_Array_Index (Before);
-
- Elems (Container) (B .. B + N - 1) := Elemsc (New_Item) (1 .. N);
- end Insert;
-
- ------------------
- -- Insert_Space --
- ------------------
-
- procedure Insert_Space
- (Container : in out Vector;
- Before : Extended_Index;
- Count : Count_Type := 1)
- is
- Old_Length : constant Count_Type := Length (Container);
-
- Max_Length : Count_Type'Base; -- determined from range of Index_Type
- New_Length : Count_Type'Base; -- sum of current length and Count
-
- Index : Index_Type'Base; -- scratch for intermediate values
- J : Count_Type'Base; -- scratch
-
- begin
- -- As a precondition on the generic actual Index_Type, the base type
- -- must include Index_Type'Pred (Index_Type'First); this is the value
- -- that Container.Last assumes when the vector is empty. However, we do
- -- not allow that as the value for Index when specifying where the new
- -- items should be inserted, so we must manually check. (That the user
- -- is allowed to specify the value at all here is a consequence of the
- -- declaration of the Extended_Index subtype, which includes the values
- -- in the base range that immediately precede and immediately follow the
- -- values in the Index_Type.)
-
- if Before < Index_Type'First then
- raise Constraint_Error with
- "Before index is out of range (too small)";
- end if;
-
- -- We do allow a value greater than Container.Last to be specified as
- -- the Index, but only if it's immediately greater. This allows for the
- -- case of appending items to the back end of the vector. (It is assumed
- -- that specifying an index value greater than Last + 1 indicates some
- -- deeper flaw in the caller's algorithm, so that case is treated as a
- -- proper error.)
-
- if Before > Container.Last
- and then Before - 1 > Container.Last
- then
- raise Constraint_Error with
- "Before index is out of range (too large)";
- end if;
-
- -- We treat inserting 0 items into the container as a no-op, so we
- -- simply return.
-
- if Count = 0 then
- return;
- end if;
-
- -- There are two constraints we need to satisfy. The first constraint is
- -- that a container cannot have more than Count_Type'Last elements, so
- -- we must check the sum of the current length and the insertion
- -- count. Note that we cannot simply add these values, because of the
- -- possibility of overflow.
-
- if Old_Length > Count_Type'Last - Count then
- raise Constraint_Error with "Count is out of range";
- end if;
-
- -- It is now safe compute the length of the new vector, without fear of
- -- overflow.
-
- New_Length := Old_Length + Count;
-
- -- The second constraint is that the new Last index value cannot exceed
- -- Index_Type'Last. In each branch below, we calculate the maximum
- -- length (computed from the range of values in Index_Type), and then
- -- compare the new length to the maximum length. If the new length is
- -- acceptable, then we compute the new last index from that.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-
- -- We have to handle the case when there might be more values in the
- -- range of Index_Type than in the range of Count_Type.
-
- if Index_Type'First <= 0 then
-
- -- We know that No_Index (the same as Index_Type'First - 1) is
- -- less than 0, so it is safe to compute the following sum without
- -- fear of overflow.
-
- Index := No_Index + Index_Type'Base (Count_Type'Last);
-
- if Index <= Index_Type'Last then
-
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the
- -- maximum number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than in Count_Type,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
- end if;
-
- else
- -- No_Index is equal or greater than 0, so we can safely compute
- -- the difference without fear of overflow (which we would have to
- -- worry about if No_Index were less than 0, but that case is
- -- handled above).
-
- if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last)
- then
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the
- -- maximum number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than in Count_Type,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
- end if;
- end if;
-
- elsif Index_Type'First <= 0 then
-
- -- We know that No_Index (the same as Index_Type'First - 1) is less
- -- than 0, so it is safe to compute the following sum without fear of
- -- overflow.
-
- J := Count_Type'Base (No_Index) + Count_Type'Last;
-
- if J <= Count_Type'Base (Index_Type'Last) then
-
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the maximum
- -- number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than Count_Type does,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length :=
- Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
- end if;
-
- else
- -- No_Index is equal or greater than 0, so we can safely compute the
- -- difference without fear of overflow (which we would have to worry
- -- about if No_Index were less than 0, but that case is handled
- -- above).
-
- Max_Length :=
- Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
- end if;
-
- -- We have just computed the maximum length (number of items). We must
- -- now compare the requested length to the maximum length, as we do not
- -- allow a vector expand beyond the maximum (because that would create
- -- an internal array with a last index value greater than
- -- Index_Type'Last, with no way to index those elements).
-
- if New_Length > Max_Length then
- raise Constraint_Error with "Count is out of range";
- end if;
-
- J := To_Array_Index (Before);
-
- -- Increase the capacity of container if needed
-
- if not Bounded
- and then Current_Capacity (Container) < Capacity_Range (New_Length)
- then
- Reserve_Capacity
- (Container,
- Capacity_Range'Max
- (Current_Capacity (Container) * Growth_Factor,
- Capacity_Range (New_Length)));
- end if;
-
- declare
- EA : Maximal_Array_Ptr renames Elems (Container);
-
- begin
- if Before <= Container.Last then
-
- -- The new items are being inserted before some existing
- -- elements, so we must slide the existing elements up to their
- -- new home.
-
- EA (J + Count .. New_Length) := EA (J .. Old_Length);
- end if;
- end;
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Container.Last := No_Index + Index_Type'Base (New_Length);
-
- else
- Container.Last :=
- Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
- end if;
- end Insert_Space;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Vector) return Boolean is
- begin
- return Last_Index (Container) < Index_Type'First;
- end Is_Empty;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : Vector) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "Container is empty";
- else
- return Get_Element (Container, Length (Container));
- end if;
- end Last_Element;
-
- ----------------
- -- Last_Index --
- ----------------
-
- function Last_Index (Container : Vector) return Extended_Index is
- begin
- return Container.Last;
- end Last_Index;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Vector) return Capacity_Range is
- L : constant Int := Int (Container.Last);
- F : constant Int := Int (Index_Type'First);
- N : constant Int'Base := L - F + 1;
-
- begin
- return Capacity_Range (N);
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out Vector; Source : in out Vector) is
- LS : constant Capacity_Range := Length (Source);
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Bounded and then Target.Capacity < LS then
- raise Constraint_Error;
- end if;
-
- Clear (Target);
- Append (Target, Source);
- Clear (Source);
- end Move;
-
- ------------
- -- Prepend --
- ------------
-
- procedure Prepend (Container : in out Vector; New_Item : Vector) is
- begin
- Insert (Container, Index_Type'First, New_Item);
- end Prepend;
-
- procedure Prepend (Container : in out Vector; New_Item : Element_Type) is
- begin
- Prepend (Container, New_Item, 1);
- end Prepend;
-
- procedure Prepend
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, Index_Type'First, New_Item, Count);
- end Prepend;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference
- (Container : not null access Vector;
- Index : Index_Type) return not null access Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
-
- begin
- if Container.Elements_Ptr = null then
- return Reference (Container.Elements (I)'Access);
- else
- return Reference (Container.Elements_Ptr (I)'Access);
- end if;
- end;
- end Reference;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out Vector;
- Index : Index_Type;
- New_Item : Element_Type)
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
-
- begin
- Elems (Container) (I) := H (New_Item);
- end;
- end Replace_Element;
-
- ----------------------
- -- Reserve_Capacity --
- ----------------------
-
- procedure Reserve_Capacity
- (Container : in out Vector;
- Capacity : Capacity_Range)
- is
- begin
- if Bounded then
- if Capacity > Container.Capacity then
- raise Constraint_Error with "Capacity is out of range";
- end if;
-
- else
- if Capacity > Current_Capacity (Container) then
- declare
- New_Elements : constant Elements_Array_Ptr :=
- new Elements_Array (1 .. Capacity);
- L : constant Capacity_Range := Length (Container);
-
- begin
- New_Elements (1 .. L) := Elemsc (Container) (1 .. L);
- Free (Container.Elements_Ptr);
- Container.Elements_Ptr := New_Elements;
- end;
- end if;
- end if;
- end Reserve_Capacity;
-
- ----------------------
- -- Reverse_Elements --
- ----------------------
-
- procedure Reverse_Elements (Container : in out Vector) is
- begin
- if Length (Container) <= 1 then
- return;
- end if;
-
- declare
- I : Capacity_Range;
- J : Capacity_Range;
- E : Elements_Array renames
- Elems (Container) (1 .. Length (Container));
-
- begin
- I := 1;
- J := Length (Container);
- while I < J loop
- declare
- EI : constant Holder := E (I);
-
- begin
- E (I) := E (J);
- E (J) := EI;
- end;
-
- I := I + 1;
- J := J - 1;
- end loop;
- end;
- end Reverse_Elements;
-
- ------------------------
- -- Reverse_Find_Index --
- ------------------------
-
- function Reverse_Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'Last) return Extended_Index
- is
- Last : Index_Type'Base;
- K : Count_Type'Base;
-
- begin
- if Index > Last_Index (Container) then
- Last := Last_Index (Container);
- else
- Last := Index;
- end if;
-
- K := Capacity_Range (Int (Last) - Int (No_Index));
- for Indx in reverse Index_Type'First .. Last loop
- if Get_Element (Container, K) = Item then
- return Indx;
- end if;
-
- K := K - 1;
- end loop;
-
- return No_Index;
- end Reverse_Find_Index;
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap
- (Container : in out Vector;
- I : Index_Type;
- J : Index_Type)
- is
- begin
- if I > Container.Last then
- raise Constraint_Error with "I index is out of range";
- end if;
-
- if J > Container.Last then
- raise Constraint_Error with "J index is out of range";
- end if;
-
- if I = J then
- return;
- end if;
-
- declare
- II : constant Int'Base := Int (I) - Int (No_Index);
- JJ : constant Int'Base := Int (J) - Int (No_Index);
-
- EI : Holder renames Elems (Container) (Capacity_Range (II));
- EJ : Holder renames Elems (Container) (Capacity_Range (JJ));
-
- EI_Copy : constant Holder := EI;
-
- begin
- EI := EJ;
- EJ := EI_Copy;
- end;
- end Swap;
-
- --------------------
- -- To_Array_Index --
- --------------------
-
- function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is
- Offset : Count_Type'Base;
-
- begin
- -- We know that
- -- Index >= Index_Type'First
- -- hence we also know that
- -- Index - Index_Type'First >= 0
-
- -- The issue is that even though 0 is guaranteed to be a value in the
- -- type Index_Type'Base, there's no guarantee that the difference is a
- -- value in that type. To prevent overflow we use the wider of
- -- Count_Type'Base and Index_Type'Base to perform intermediate
- -- calculations.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Offset := Count_Type'Base (Index - Index_Type'First);
-
- else
- Offset := Count_Type'Base (Index) -
- Count_Type'Base (Index_Type'First);
- end if;
-
- -- The array index subtype for all container element arrays always
- -- starts with 1.
-
- return 1 + Offset;
- end To_Array_Index;
-
- ---------------
- -- To_Vector --
- ---------------
-
- function To_Vector
- (New_Item : Element_Type;
- Length : Capacity_Range) return Vector
- is
- begin
- if Length = 0 then
- return Empty_Vector;
- end if;
-
- declare
- First : constant Int := Int (Index_Type'First);
- Last_As_Int : constant Int'Base := First + Int (Length) - 1;
- Last : Index_Type;
-
- begin
- if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
- raise Constraint_Error with "Length is out of range"; -- ???
- end if;
-
- Last := Index_Type (Last_As_Int);
-
- return
- (Capacity => Length,
- Last => Last,
- Elements_Ptr => <>,
- Elements => [others => H (New_Item)]);
- end;
- end To_Vector;
-
-end Ada.Containers.Formal_Indefinite_Vectors;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- Similar to Ada.Containers.Formal_Vectors. The main difference is that
--- Element_Type may be indefinite (but not an unconstrained array).
-
-with Ada.Containers.Bounded_Holders;
-with Ada.Containers.Functional_Vectors;
-
generic
- type Index_Type is range <>;
- type Element_Type (<>) is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
- Max_Size_In_Storage_Elements : Natural;
- -- Maximum size of Vector elements in bytes. This has the same meaning as
- -- in Ada.Containers.Bounded_Holders, with the same restrictions. Note that
- -- setting this too small can lead to erroneous execution; see comments in
- -- Ada.Containers.Bounded_Holders. If Element_Type is class-wide, it is the
- -- responsibility of clients to calculate the maximum size of all types in
- -- the class.
-
- Bounded : Boolean := True;
- -- If True, the containers are bounded; the initial capacity is the maximum
- -- size, and heap allocation will be avoided. If False, the containers can
- -- grow via heap allocation.
-
-package Ada.Containers.Formal_Indefinite_Vectors with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- subtype Extended_Index is Index_Type'Base
- range Index_Type'First - 1 ..
- Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
-
- No_Index : constant Extended_Index := Extended_Index'First;
-
- Last_Count : constant Count_Type :=
- (if Index_Type'Last < Index_Type'First then
- 0
- elsif Index_Type'Last < -1
- or else Index_Type'Pos (Index_Type'First) >
- Index_Type'Pos (Index_Type'Last) - Count_Type'Last
- then
- Index_Type'Pos (Index_Type'Last) -
- Index_Type'Pos (Index_Type'First) + 1
- else
- Count_Type'Last);
- -- Maximal capacity of any vector. It is the minimum of the size of the
- -- index range and the last possible Count_Type.
-
- subtype Capacity_Range is Count_Type range 0 .. Last_Count;
-
- type Vector (Capacity : Capacity_Range) is limited private with
- Default_Initial_Condition => Is_Empty (Vector);
- -- In the bounded case, Capacity is the capacity of the container, which
- -- never changes. In the unbounded case, Capacity is the initial capacity
- -- of the container, and operations such as Reserve_Capacity and Append can
- -- increase the capacity. The capacity never shrinks, except in the case of
- -- Clear.
- --
- -- Note that all objects of type Vector are constrained, including in the
- -- unbounded case; you can't assign from one object to another if the
- -- Capacity is different.
-
- function Length (Container : Vector) return Capacity_Range with
- Global => null,
- Post => Length'Result <= Capacity (Container);
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
-
- package M is new Ada.Containers.Functional_Vectors
- (Index_Type => Index_Type,
- Element_Type => Element_Type);
-
- function "="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."=";
-
- function "<"
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<";
-
- function "<="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<=";
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- The elements of Container are contained in either Left or Right
- with
- Global => null,
- Post =>
- M_Elements_In_Union'Result =
- (for all I in Index_Type'First .. M.Last (Container) =>
- (for some J in Index_Type'First .. M.Last (Left) =>
- Element (Container, I) = Element (Left, J))
- or (for some J in Index_Type'First .. M.Last (Right) =>
- Element (Container, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union);
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Index_Type := Index_Type'First;
- L_Lst : Extended_Index;
- Right : M.Sequence;
- R_Fst : Index_Type := Index_Type'First;
- R_Lst : Extended_Index) return Boolean
- -- The elements of the slice from L_Fst to L_Lst in Left are contained
- -- in the slide from R_Fst to R_Lst in Right.
- with
- Global => null,
- Pre => L_Lst <= M.Last (Left) and R_Lst <= M.Last (Right),
- Post =>
- M_Elements_Included'Result =
- (for all I in L_Fst .. L_Lst =>
- (for some J in R_Fst .. R_Lst =>
- Element (Left, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included);
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- Right is Left in reverse order
- with
- Global => null,
- Post =>
- M_Elements_Reversed'Result =
- (M.Length (Left) = M.Length (Right)
- and (for all I in Index_Type'First .. M.Last (Left) =>
- Element (Left, I) =
- Element (Right, M.Last (Left) - I + 1))
- and (for all I in Index_Type'First .. M.Last (Right) =>
- Element (Right, I) =
- Element (Left, M.Last (Left) - I + 1)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed);
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- -- Elements stored at X and Y are reversed in Left and Right
- with
- Global => null,
- Pre => X <= M.Last (Left) and Y <= M.Last (Left),
- Post =>
- M_Elements_Swapped'Result =
- (M.Length (Left) = M.Length (Right)
- and Element (Left, X) = Element (Right, Y)
- and Element (Left, Y) = Element (Right, X)
- and M.Equal_Except (Left, Right, X, Y));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped);
-
- function Model (Container : Vector) return M.Sequence with
- -- The high-level model of a vector is a sequence of elements. The
- -- sequence really is similar to the vector itself. However, it is not
- -- limited which allows usage of 'Old and 'Loop_Entry attributes.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Length (Container);
-
- function Element
- (S : M.Sequence;
- I : Index_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
-
- end Formal_Model;
- use Formal_Model;
-
- function Empty_Vector return Vector with
- Global => null,
- Post => Length (Empty_Vector'Result) = 0;
-
- function "=" (Left, Right : Vector) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function To_Vector
- (New_Item : Element_Type;
- Length : Capacity_Range) return Vector
- with
- Global => null,
- Post =>
- Formal_Indefinite_Vectors.Length (To_Vector'Result) = Length
- and M.Constant_Range
- (Container => Model (To_Vector'Result),
- Fst => Index_Type'First,
- Lst => Last_Index (To_Vector'Result),
- Item => New_Item);
-
- function Capacity (Container : Vector) return Capacity_Range with
- Global => null,
- Post =>
- Capacity'Result =
- (if Bounded then
- Container.Capacity
- else
- Capacity_Range'Last);
- pragma Annotate (GNATprove, Inline_For_Proof, Capacity);
-
- procedure Reserve_Capacity
- (Container : in out Vector;
- Capacity : Capacity_Range)
- with
- Global => null,
- Pre => (if Bounded then Capacity <= Container.Capacity),
- Post => Model (Container) = Model (Container)'Old;
-
- function Is_Empty (Container : Vector) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out Vector) with
- Global => null,
- Post => Length (Container) = 0;
- -- Note that this reclaims storage in the unbounded case. You need to call
- -- this before a container goes out of scope in order to avoid storage
- -- leaks. In addition, "X := ..." can leak unless you Clear(X) first.
-
- procedure Assign (Target : in out Vector; Source : Vector) with
- Global => null,
- Pre => (if Bounded then Length (Source) <= Target.Capacity),
- Post => Model (Target) = Model (Source);
-
- function Copy
- (Source : Vector;
- Capacity : Capacity_Range := 0) return Vector
- with
- Global => null,
- Pre => (if Bounded then (Capacity = 0 or Length (Source) <= Capacity)),
- Post =>
- Model (Copy'Result) = Model (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Length (Source)
- else
- Copy'Result.Capacity = Capacity);
-
- procedure Move (Target : in out Vector; Source : in out Vector)
- with
- Global => null,
- Pre => (if Bounded then Length (Source) <= Capacity (Target)),
- Post => Model (Target) = Model (Source)'Old and Length (Source) = 0;
-
- function Element
- (Container : Vector;
- Index : Extended_Index) return Element_Type
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post => Element'Result = Element (Model (Container), Index);
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Vector;
- Index : Index_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Container now has New_Item at index Index
-
- and Element (Model (Container), Index) = New_Item
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Position => Index);
-
- function At_End (E : access constant Vector) return access constant Vector
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : aliased Vector;
- Index : Index_Type) return not null access constant Element_Type
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Constant_Reference'Result.all = Element (Model (Container), Index);
-
- function Reference
- (Container : not null access Vector;
- Index : Index_Type) return not null access Element_Type
- with
- Global => null,
- Pre =>
- Index in First_Index (Container.all) .. Last_Index (Container.all),
- Post =>
- Length (Container.all) = Length (At_End (Container).all)
-
- -- Container will have Result.all at index Index
-
- and At_End (Reference'Result).all =
- Element (Model (At_End (Container).all), Index)
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Left => Model (Container.all),
- Right => Model (At_End (Container).all),
- Position => Index);
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Vector)
- with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Length (New_Item)
- and (Before in Index_Type'First .. Last_Index (Container)
- or (Before /= No_Index
- and then Before - 1 = Last_Index (Container))),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- Elements of New_Item are inserted at position Before
-
- and (if Length (New_Item) > 0 then
- M.Range_Shifted
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item),
- Offset => Count_Type (Before - Index_Type'First)))
-
- -- Elements located after Before in Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => Length (New_Item));
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Capacity (Container)
- and then (Before in Index_Type'First .. Last_Index (Container) + 1),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- Container now has New_Item at index Before
-
- and Element (Model (Container), Before) = New_Item
-
- -- Elements located after Before in Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => 1);
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Count
- and (Before in Index_Type'First .. Last_Index (Container)
- or (Before /= No_Index
- and then Before - 1 = Last_Index (Container))),
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- New_Item is inserted Count times at position Before
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Before,
- Lst => Before + Index_Type'Base (Count - 1),
- Item => New_Item))
-
- -- Elements located after Before in Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => Count);
-
- procedure Prepend (Container : in out Vector; New_Item : Vector) with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Length (New_Item),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- Elements of New_Item are inserted at the beginning of Container
-
- and M.Range_Equal
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item))
-
- -- Elements of Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => Length (New_Item));
-
- procedure Prepend (Container : in out Vector; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Capacity (Container),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Container now has New_Item at Index_Type'First
-
- and Element (Model (Container), Index_Type'First) = New_Item
-
- -- Elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => 1);
-
- procedure Prepend
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- New_Item is inserted Count times at the beginning of Container
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => Index_Type'First + Index_Type'Base (Count - 1),
- Item => New_Item)
-
- -- Elements of Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => Count);
-
- procedure Append (Container : in out Vector; New_Item : Vector) with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Length (New_Item),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- The elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- Elements of New_Item are inserted at the end of Container
-
- and (if Length (New_Item) > 0 then
- M.Range_Shifted
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item),
- Offset =>
- Count_Type
- (Last_Index (Container)'Old - Index_Type'First + 1)));
-
- procedure Append (Container : in out Vector; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Capacity (Container),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements of Container are preserved
-
- and Model (Container)'Old < Model (Container)
-
- -- Container now has New_Item at the end of Container
-
- and Element
- (Model (Container), Last_Index (Container)'Old + 1) = New_Item;
-
- procedure Append
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- New_Item is inserted Count times at the end of Container
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Last_Index (Container)'Old + 1,
- Lst =>
- Last_Index (Container)'Old + Index_Type'Base (Count),
- Item => New_Item));
-
- procedure Delete (Container : in out Vector; Index : Extended_Index) with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements located before Index in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Index - 1)
-
- -- Elements located after Index in Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index,
- Lst => Last_Index (Container),
- Offset => 1);
-
- procedure Delete
- (Container : in out Vector;
- Index : Extended_Index;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) in
- Length (Container)'Old - Count .. Length (Container)'Old
-
- -- The elements of Container located before Index are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Index - 1),
-
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) - Count <= Count_Type (Index - Index_Type'First) =>
- Length (Container) = Count_Type (Index - Index_Type'First),
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index,
- Lst => Last_Index (Container),
- Offset => Count));
-
- procedure Delete_First (Container : in out Vector) with
- Global => null,
- Pre => Length (Container) > 0,
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Offset => 1);
-
- procedure Delete_First (Container : in out Vector; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count => Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Elements of Container are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Offset => Count));
-
- procedure Delete_Last (Container : in out Vector) with
- Global => null,
- Pre => Length (Container) > 0,
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements of Container are preserved
-
- and Model (Container) < Model (Container)'Old;
-
- procedure Delete_Last (Container : in out Vector; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) <= Count => Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old);
-
- procedure Reverse_Elements (Container : in out Vector) with
- Global => null,
- Post => M_Elements_Reversed (Model (Container)'Old, Model (Container));
-
- procedure Swap
- (Container : in out Vector;
- I : Index_Type;
- J : Index_Type)
- with
- Global => null,
- Pre =>
- I in First_Index (Container) .. Last_Index (Container)
- and then J in First_Index (Container) .. Last_Index (Container),
- Post =>
- M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J);
-
- function First_Index (Container : Vector) return Index_Type with
- Global => null,
- Post => First_Index'Result = Index_Type'First;
- pragma Annotate (GNATprove, Inline_For_Proof, First_Index);
-
- function First_Element (Container : Vector) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- First_Element'Result = Element (Model (Container), Index_Type'First);
- pragma Annotate (GNATprove, Inline_For_Proof, First_Element);
-
- function Last_Index (Container : Vector) return Extended_Index with
- Global => null,
- Post => Last_Index'Result = M.Last (Model (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Last_Index);
-
- function Last_Element (Container : Vector) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result =
- Element (Model (Container), Last_Index (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Last_Element);
-
- function Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'First) return Extended_Index
- with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container after Index, Find_Index
- -- returns No_Index.
-
- (Index > Last_Index (Container)
- or else not M.Contains
- (Container => Model (Container),
- Fst => Index,
- Lst => Last_Index (Container),
- Item => Item)
- =>
- Find_Index'Result = No_Index,
-
- -- Otherwise, Find_Index returns a valid index greater than Index
-
- others =>
- Find_Index'Result in Index .. Last_Index (Container)
-
- -- The element at this index in Container is Item
-
- and Element (Model (Container), Find_Index'Result) = Item
-
- -- It is the first occurrence of Item after Index in Container
-
- and not M.Contains
- (Container => Model (Container),
- Fst => Index,
- Lst => Find_Index'Result - 1,
- Item => Item));
-
- function Reverse_Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'Last) return Extended_Index
- with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container before Index,
- -- Reverse_Find_Index returns No_Index.
-
- (not M.Contains
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => (if Index <= Last_Index (Container) then Index
- else Last_Index (Container)),
- Item => Item)
- =>
- Reverse_Find_Index'Result = No_Index,
-
- -- Otherwise, Reverse_Find_Index returns a valid index smaller than
- -- Index
-
- others =>
- Reverse_Find_Index'Result in Index_Type'First .. Index
- and Reverse_Find_Index'Result <= Last_Index (Container)
-
- -- The element at this index in Container is Item
-
- and Element (Model (Container), Reverse_Find_Index'Result) = Item
-
- -- It is the last occurrence of Item before Index in Container
-
- and not M.Contains
- (Container => Model (Container),
- Fst => Reverse_Find_Index'Result + 1,
- Lst =>
- (if Index <= Last_Index (Container) then
- Index
- else
- Last_Index (Container)),
- Item => Item));
-
- function Contains
- (Container : Vector;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Post =>
- Contains'Result =
- M.Contains
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Item => Item);
-
- function Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result =
- (Position in Index_Type'First .. Last_Index (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- generic
- with function "<" (Left, Right : Element_Type) return Boolean is <>;
- package Generic_Sorting with SPARK_Mode is
-
- package Formal_Model with Ghost is
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean
- with
- Global => null,
- Post =>
- M_Elements_Sorted'Result =
- (for all I in Index_Type'First .. M.Last (Container) =>
- (for all J in I .. M.Last (Container) =>
- Element (Container, I) = Element (Container, J)
- or Element (Container, I) < Element (Container, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted);
-
- end Formal_Model;
- use Formal_Model;
-
- function Is_Sorted (Container : Vector) return Boolean with
- Global => null,
- Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container));
-
- procedure Sort (Container : in out Vector) with
- Global => null,
- Post =>
- Length (Container) = Length (Container)'Old
- and M_Elements_Sorted (Model (Container))
- and M_Elements_Included
- (Left => Model (Container)'Old,
- L_Lst => Last_Index (Container),
- Right => Model (Container),
- R_Lst => Last_Index (Container))
- and M_Elements_Included
- (Left => Model (Container),
- L_Lst => Last_Index (Container),
- Right => Model (Container)'Old,
- R_Lst => Last_Index (Container));
-
- procedure Merge (Target : in out Vector; Source : in out Vector) with
- -- Target and Source should not be aliased
- Global => null,
- Pre => Length (Source) <= Capacity (Target) - Length (Target),
- Post =>
- Length (Target) = Length (Target)'Old + Length (Source)'Old
- and Length (Source) = 0
- and (if M_Elements_Sorted (Model (Target)'Old)
- and M_Elements_Sorted (Model (Source)'Old)
- then
- M_Elements_Sorted (Model (Target)))
- and M_Elements_Included
- (Left => Model (Target)'Old,
- L_Lst => Last_Index (Target)'Old,
- Right => Model (Target),
- R_Lst => Last_Index (Target))
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Last_Index (Source)'Old,
- Right => Model (Target),
- R_Lst => Last_Index (Target))
- and M_Elements_In_Union
- (Model (Target),
- Model (Source)'Old,
- Model (Target)'Old);
- end Generic_Sorting;
-
-private
- pragma SPARK_Mode (Off);
-
- pragma Inline (First_Index);
- pragma Inline (Last_Index);
- pragma Inline (Element);
- pragma Inline (First_Element);
- pragma Inline (Last_Element);
- pragma Inline (Replace_Element);
- pragma Inline (Contains);
-
- -- The implementation method is to instantiate Bounded_Holders to get a
- -- definite type for Element_Type.
-
- package Holders is new Bounded_Holders
- (Element_Type, Max_Size_In_Storage_Elements, "=");
- use Holders;
-
- subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last;
- type Elements_Array is array (Array_Index range <>) of aliased Holder;
- function "=" (L, R : Elements_Array) return Boolean is abstract;
-
- type Elements_Array_Ptr is access all Elements_Array;
-
- type Vector (Capacity : Capacity_Range) is limited record
-
- -- In the bounded case, the elements are stored in Elements. In the
- -- unbounded case, the elements are initially stored in Elements, until
- -- we run out of room, then we switch to Elements_Ptr.
-
- Last : Extended_Index := No_Index;
- Elements_Ptr : Elements_Array_Ptr := null;
- Elements : aliased Elements_Array (1 .. Capacity);
- end record;
-
- -- The primary reason Vector is limited is that in the unbounded case, once
- -- Elements_Ptr is in use, assignment statements won't work. "X := Y;" will
- -- cause X and Y to share state; that is, X.Elements_Ptr = Y.Elements_Ptr,
- -- so for example "Append (X, ...);" will modify BOTH X and Y. That would
- -- allow SPARK to "prove" things that are false. We could fix that by
- -- making Vector a controlled type, and override Adjust to make a deep
- -- copy, but finalization is not allowed in SPARK.
- --
- -- Note that (unfortunately) this means that 'Old and 'Loop_Entry are not
- -- allowed on Vectors.
+package Ada.Containers.Formal_Indefinite_Vectors with SPARK_Mode is
- function Empty_Vector return Vector is
- ((Capacity => 0, others => <>));
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Indefinite_Vectors;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
-pragma Elaborate_All
- (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
-
-with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
-pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Ordered_Maps with
- SPARK_Mode => Off
-is
-
- -- Convert Count_Type to Big_Interger
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
-
- function Big (J : Count_Type) return Big_Integer renames
- Conversions.To_Big_Integer;
-
- -----------------------------
- -- Node Access Subprograms --
- -----------------------------
-
- -- These subprograms provide a functional interface to access fields
- -- of a node, and a procedural interface for modifying these values.
-
- function Color
- (Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type;
- pragma Inline (Color);
-
- function Left_Son (Node : Node_Type) return Count_Type;
- pragma Inline (Left_Son);
-
- function Parent (Node : Node_Type) return Count_Type;
- pragma Inline (Parent);
-
- function Right_Son (Node : Node_Type) return Count_Type;
- pragma Inline (Right_Son);
-
- procedure Set_Color
- (Node : in out Node_Type;
- Color : Ada.Containers.Red_Black_Trees.Color_Type);
- pragma Inline (Set_Color);
-
- procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
- pragma Inline (Set_Left);
-
- procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
- pragma Inline (Set_Right);
-
- procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
- pragma Inline (Set_Parent);
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- -- All need comments ???
-
- generic
- with procedure Set_Element (Node : in out Node_Type);
- procedure Generic_Allocate
- (Tree : in out Tree_Types.Tree_Type'Class;
- Node : out Count_Type);
-
- procedure Free (Tree : in out Map; X : Count_Type);
-
- function Is_Greater_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Greater_Key_Node);
-
- function Is_Less_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Less_Key_Node);
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package Tree_Operations is
- new Red_Black_Trees.Generic_Bounded_Operations
- (Tree_Types => Tree_Types,
- Left => Left_Son,
- Right => Right_Son);
-
- use Tree_Operations;
-
- package Key_Ops is
- new Red_Black_Trees.Generic_Bounded_Keys
- (Tree_Operations => Tree_Operations,
- Key_Type => Key_Type,
- Is_Less_Key_Node => Is_Less_Key_Node,
- Is_Greater_Key_Node => Is_Greater_Key_Node);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left, Right : Map) return Boolean is
- Lst : Count_Type;
- Node : Count_Type;
- ENode : Count_Type;
-
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- if Is_Empty (Left) then
- return True;
- end if;
-
- Lst := Next (Left.Content, Last (Left).Node);
-
- Node := First (Left).Node;
- while Node /= Lst loop
- ENode := Find (Right, Left.Content.Nodes (Node).Key).Node;
-
- if ENode = 0 or else
- Left.Content.Nodes (Node).Element /=
- Right.Content.Nodes (ENode).Element
- then
- return False;
- end if;
-
- Node := Next (Left.Content, Node);
- end loop;
-
- return True;
- end "=";
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out Map; Source : Map) is
- procedure Append_Element (Source_Node : Count_Type);
-
- procedure Append_Elements is
- new Tree_Operations.Generic_Iteration (Append_Element);
-
- --------------------
- -- Append_Element --
- --------------------
-
- procedure Append_Element (Source_Node : Count_Type) is
- SN : Node_Type renames Source.Content.Nodes (Source_Node);
-
- procedure Set_Element (Node : in out Node_Type);
- pragma Inline (Set_Element);
-
- function New_Node return Count_Type;
- pragma Inline (New_Node);
-
- procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node);
-
- procedure Unconditional_Insert_Sans_Hint is
- new Key_Ops.Generic_Unconditional_Insert (Insert_Post);
-
- procedure Unconditional_Insert_Avec_Hint is
- new Key_Ops.Generic_Unconditional_Insert_With_Hint
- (Insert_Post,
- Unconditional_Insert_Sans_Hint);
-
- procedure Allocate is new Generic_Allocate (Set_Element);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Count_Type is
- Result : Count_Type;
- begin
- Allocate (Target.Content, Result);
- return Result;
- end New_Node;
-
- -----------------
- -- Set_Element --
- -----------------
-
- procedure Set_Element (Node : in out Node_Type) is
- begin
- Node.Key := SN.Key;
- Node.Element := SN.Element;
- end Set_Element;
-
- Target_Node : Count_Type;
-
- -- Start of processing for Append_Element
-
- begin
- Unconditional_Insert_Avec_Hint
- (Tree => Target.Content,
- Hint => 0,
- Key => SN.Key,
- Node => Target_Node);
- end Append_Element;
-
- -- Start of processing for Assign
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Length (Source) then
- raise Storage_Error with "not enough capacity"; -- SE or CE? ???
- end if;
-
- Tree_Operations.Clear_Tree (Target.Content);
- Append_Elements (Source.Content);
- end Assign;
-
- -------------
- -- Ceiling --
- -------------
-
- function Ceiling (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Ceiling (Container.Content, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Ceiling;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Map) is
- begin
- Tree_Operations.Clear_Tree (Container.Content);
- end Clear;
-
- -----------
- -- Color --
- -----------
-
- function Color (Node : Node_Type) return Color_Type is
- begin
- return Node.Color;
- end Color;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Map;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in function Constant_Reference");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Constant_Reference;
-
- function Constant_Reference
- (Container : aliased Map;
- Key : Key_Type) return not null access constant Element_Type
- is
- Node : constant Node_Access := Find (Container, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "no element available because key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains (Container : Map; Key : Key_Type) return Boolean is
- begin
- return Find (Container, Key) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy (Source : Map; Capacity : Count_Type := 0) return Map is
- Node : Count_Type := 1;
- N : Count_Type;
-
- begin
- if 0 < Capacity and then Capacity < Source.Capacity then
- raise Capacity_Error;
- end if;
-
- return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do
- if Length (Source) > 0 then
- Target.Content.Length := Source.Content.Length;
- Target.Content.Root := Source.Content.Root;
- Target.Content.First := Source.Content.First;
- Target.Content.Last := Source.Content.Last;
- Target.Content.Free := Source.Content.Free;
-
- while Node <= Source.Capacity loop
- Target.Content.Nodes (Node).Element :=
- Source.Content.Nodes (Node).Element;
- Target.Content.Nodes (Node).Key :=
- Source.Content.Nodes (Node).Key;
- Target.Content.Nodes (Node).Parent :=
- Source.Content.Nodes (Node).Parent;
- Target.Content.Nodes (Node).Left :=
- Source.Content.Nodes (Node).Left;
- Target.Content.Nodes (Node).Right :=
- Source.Content.Nodes (Node).Right;
- Target.Content.Nodes (Node).Color :=
- Source.Content.Nodes (Node).Color;
- Target.Content.Nodes (Node).Has_Element :=
- Source.Content.Nodes (Node).Has_Element;
- Node := Node + 1;
- end loop;
-
- while Node <= Target.Capacity loop
- N := Node;
- Free (Tree => Target, X => N);
- Node := Node + 1;
- end loop;
- end if;
- end return;
- end Copy;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Map; Position : in out Cursor) is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of Delete has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "Position cursor of Delete is bad");
-
- Tree_Operations.Delete_Node_Sans_Free (Container.Content,
- Position.Node);
- Free (Container, Position.Node);
- Position := No_Element;
- end Delete;
-
- procedure Delete (Container : in out Map; Key : Key_Type) is
- X : constant Node_Access := Key_Ops.Find (Container.Content, Key);
-
- begin
- if X = 0 then
- raise Constraint_Error with "key not in map";
- end if;
-
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out Map) is
- X : constant Node_Access := First (Container).Node;
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out Map) is
- X : constant Node_Access := Last (Container).Node;
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Delete_Last;
-
- -------------
- -- Element --
- -------------
-
- function Element (Container : Map; Position : Cursor) return Element_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of function Element has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "Position cursor of function Element is bad");
-
- return Container.Content.Nodes (Position.Node).Element;
-
- end Element;
-
- function Element (Container : Map; Key : Key_Type) return Element_Type is
- Node : constant Node_Access := Find (Container, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with "key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element;
- end Element;
-
- ---------------------
- -- Equivalent_Keys --
- ---------------------
-
- function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
- begin
- if Left < Right
- or else Right < Left
- then
- return False;
- else
- return True;
- end if;
- end Equivalent_Keys;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Map; Key : Key_Type) is
- X : constant Node_Access := Key_Ops.Find (Container.Content, Key);
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : Map) return Cursor is
- begin
- if Length (Container) = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.Content.First);
- end First;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : Map) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "map is empty";
- end if;
-
- return Container.Content.Nodes (First (Container).Node).Element;
- end First_Element;
-
- ---------------
- -- First_Key --
- ---------------
-
- function First_Key (Container : Map) return Key_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "map is empty";
- end if;
-
- return Container.Content.Nodes (First (Container).Node).Key;
- end First_Key;
-
- -----------
- -- Floor --
- -----------
-
- function Floor (Container : Map; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Ops.Floor (Container.Content, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Floor;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : K.Sequence;
- Key : Key_Type) return Count_Type
- is
- begin
- for I in 1 .. K.Length (Container) loop
- if Equivalent_Keys (Key, K.Get (Container, I)) then
- return I;
- elsif Key < K.Get (Container, I) then
- return 0;
- end if;
- end loop;
- return 0;
- end Find;
-
- -------------------------
- -- K_Bigger_Than_Range --
- -------------------------
-
- function K_Bigger_Than_Range
- (Container : K.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (K.Get (Container, I) < Key) then
- return False;
- end if;
- end loop;
- return True;
- end K_Bigger_Than_Range;
-
- ---------------
- -- K_Is_Find --
- ---------------
-
- function K_Is_Find
- (Container : K.Sequence;
- Key : Key_Type;
- Position : Count_Type) return Boolean
- is
- begin
- for I in 1 .. Position - 1 loop
- if Key < K.Get (Container, I) then
- return False;
- end if;
- end loop;
-
- if Position < K.Length (Container) then
- for I in Position + 1 .. K.Length (Container) loop
- if K.Get (Container, I) < Key then
- return False;
- end if;
- end loop;
- end if;
- return True;
- end K_Is_Find;
-
- --------------------------
- -- K_Smaller_Than_Range --
- --------------------------
-
- function K_Smaller_Than_Range
- (Container : K.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (Key < K.Get (Container, I)) then
- return False;
- end if;
- end loop;
- return True;
- end K_Smaller_Than_Range;
-
- ----------
- -- Keys --
- ----------
-
- function Keys (Container : Map) return K.Sequence is
- Position : Count_Type := Container.Content.First;
- R : K.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := K.Add (R, Container.Content.Nodes (Position).Key);
- Position := Tree_Operations.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Keys;
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : Map) is null;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Map) return M.Map is
- Position : Count_Type := Container.Content.First;
- R : M.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R :=
- M.Add
- (Container => R,
- New_Key => Container.Content.Nodes (Position).Key,
- New_Item => Container.Content.Nodes (Position).Element);
-
- Position := Tree_Operations.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Model;
-
- -------------------------
- -- P_Positions_Shifted --
- -------------------------
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu) + Count
- then
- return False;
- end if;
-
- else
- if P.Has_Key (Small, Cu) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Shifted;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : Map) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := Container.Content.First;
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = Big (I));
- Position := Tree_Operations.Next (Container.Content, Position);
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free
- (Tree : in out Map;
- X : Count_Type)
- is
- begin
- Tree.Content.Nodes (X).Has_Element := False;
- Tree_Operations.Free (Tree.Content, X);
- end Free;
-
- ----------------------
- -- Generic_Allocate --
- ----------------------
-
- procedure Generic_Allocate
- (Tree : in out Tree_Types.Tree_Type'Class;
- Node : out Count_Type)
- is
- procedure Allocate is
- new Tree_Operations.Generic_Allocate (Set_Element);
- begin
- Allocate (Tree, Node);
- Tree.Nodes (Node).Has_Element := True;
- end Generic_Allocate;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : Map; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0 then
- return False;
- end if;
-
- return Container.Content.Nodes (Position.Node).Has_Element;
- end Has_Element;
-
- -------------
- -- Include --
- -------------
-
- procedure Include
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, Key, New_Item, Position, Inserted);
-
- if not Inserted then
- declare
- N : Node_Type renames Container.Content.Nodes (Position.Node);
- begin
- N.Key := Key;
- N.Element := New_Item;
- end;
- end if;
- end Include;
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- is
- function New_Node return Node_Access;
- -- Comment ???
-
- procedure Insert_Post is
- new Key_Ops.Generic_Insert_Post (New_Node);
-
- procedure Insert_Sans_Hint is
- new Key_Ops.Generic_Conditional_Insert (Insert_Post);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Node_Access is
- procedure Initialize (Node : in out Node_Type);
- procedure Allocate_Node is new Generic_Allocate (Initialize);
-
- procedure Initialize (Node : in out Node_Type) is
- begin
- Node.Key := Key;
- Node.Element := New_Item;
- end Initialize;
-
- X : Node_Access;
-
- begin
- Allocate_Node (Container.Content, X);
- return X;
- end New_Node;
-
- -- Start of processing for Insert
-
- begin
- Insert_Sans_Hint
- (Container.Content,
- Key,
- Position.Node,
- Inserted);
- end Insert;
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, Key, New_Item, Position, Inserted);
-
- if not Inserted then
- raise Constraint_Error with "key already in map";
- end if;
- end Insert;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Map) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- -------------------------
- -- Is_Greater_Key_Node --
- -------------------------
-
- function Is_Greater_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean
- is
- begin
- -- k > node same as node < k
-
- return Right.Key < Left;
- end Is_Greater_Key_Node;
-
- ----------------------
- -- Is_Less_Key_Node --
- ----------------------
-
- function Is_Less_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean
- is
- begin
- return Left < Right.Key;
- end Is_Less_Key_Node;
-
- ---------
- -- Key --
- ---------
-
- function Key (Container : Map; Position : Cursor) return Key_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of function Key has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "Position cursor of function Key is bad");
-
- return Container.Content.Nodes (Position.Node).Key;
- end Key;
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : Map) return Cursor is
- begin
- if Length (Container) = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.Content.Last);
- end Last;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : Map) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "map is empty";
- end if;
-
- return Container.Content.Nodes (Last (Container).Node).Element;
- end Last_Element;
-
- --------------
- -- Last_Key --
- --------------
-
- function Last_Key (Container : Map) return Key_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "map is empty";
- end if;
-
- return Container.Content.Nodes (Last (Container).Node).Key;
- end Last_Key;
-
- --------------
- -- Left_Son --
- --------------
-
- function Left_Son (Node : Node_Type) return Count_Type is
- begin
- return Node.Left;
- end Left_Son;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Map) return Count_Type is
- begin
- return Container.Content.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out Map; Source : in out Map) is
- NN : Tree_Types.Nodes_Type renames Source.Content.Nodes;
- X : Node_Access;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Length (Source) then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- loop
- X := First (Source).Node;
- exit when X = 0;
-
- -- Here we insert a copy of the source element into the target, and
- -- then delete the element from the source. Another possibility is
- -- that delete it first (and hang onto its index), then insert it.
- -- ???
-
- Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
-
- Tree_Operations.Delete_Node_Sans_Free (Source.Content, X);
- Formal_Ordered_Maps.Free (Source, X);
- end loop;
- end Move;
-
- ----------
- -- Next --
- ----------
-
- procedure Next (Container : Map; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- function Next (Container : Map; Position : Cursor) return Cursor is
- begin
- if Position = No_Element then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error;
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Next");
-
- return (Node => Tree_Operations.Next (Container.Content, Position.Node));
- end Next;
-
- ------------
- -- Parent --
- ------------
-
- function Parent (Node : Node_Type) return Count_Type is
- begin
- return Node.Parent;
- end Parent;
-
- --------------
- -- Previous --
- --------------
-
- procedure Previous (Container : Map; Position : in out Cursor) is
- begin
- Position := Previous (Container, Position);
- end Previous;
-
- function Previous (Container : Map; Position : Cursor) return Cursor is
- begin
- if Position = No_Element then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error;
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Previous");
-
- declare
- Node : constant Count_Type :=
- Tree_Operations.Previous (Container.Content, Position.Node);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
- end Previous;
-
- --------------
- -- Reference --
- --------------
-
- function Reference
- (Container : not null access Map;
- Position : Cursor) return not null access Element_Type
- is
- begin
- if not Has_Element (Container.all, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert
- (Vet (Container.Content, Position.Node),
- "bad cursor in function Reference");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Reference;
-
- function Reference
- (Container : not null access Map;
- Key : Key_Type) return not null access Element_Type
- is
- Node : constant Count_Type := Find (Container.all, Key).Node;
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "no element available because key not in map";
- end if;
-
- return Container.Content.Nodes (Node).Element'Access;
- end Reference;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- begin
- declare
- Node : constant Node_Access := Key_Ops.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- raise Constraint_Error with "key not in map";
- end if;
-
- declare
- N : Node_Type renames Container.Content.Nodes (Node);
- begin
- N.Key := Key;
- N.Element := New_Item;
- end;
- end;
- end Replace;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out Map;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor of Replace_Element has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "Position cursor of Replace_Element is bad");
-
- Container.Content.Nodes (Position.Node).Element := New_Item;
- end Replace_Element;
-
- ---------------
- -- Right_Son --
- ---------------
-
- function Right_Son (Node : Node_Type) return Count_Type is
- begin
- return Node.Right;
- end Right_Son;
-
- ---------------
- -- Set_Color --
- ---------------
-
- procedure Set_Color (Node : in out Node_Type; Color : Color_Type) is
- begin
- Node.Color := Color;
- end Set_Color;
-
- --------------
- -- Set_Left --
- --------------
-
- procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
- begin
- Node.Left := Left;
- end Set_Left;
-
- ----------------
- -- Set_Parent --
- ----------------
-
- procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
- begin
- Node.Parent := Parent;
- end Set_Parent;
-
- ---------------
- -- Set_Right --
- ---------------
-
- procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
- begin
- Node.Right := Right;
- end Set_Right;
-
-end Ada.Containers.Formal_Ordered_Maps;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- This spec is derived from package Ada.Containers.Bounded_Ordered_Maps in
--- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by
--- making it easier to express properties, and by making the specification of
--- this unit compatible with SPARK 2014. Note that the API of this unit may be
--- subject to incompatible changes as SPARK 2014 evolves.
-
--- The modifications are:
-
--- A parameter for the container is added to every function reading the
--- content of a container: Key, Element, Next, Query_Element, Previous,
--- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the
--- need to have cursors which are valid on different containers (typically a
--- container C and its previous version C'Old) for expressing properties,
--- which is not possible if cursors encapsulate an access to the underlying
--- container. The operators "<" and ">" that could not be modified that way
--- have been removed.
-
--- Iteration over maps is done using the Iterable aspect, which is SPARK
--- compatible. "For of" iteration ranges over keys instead of elements.
-
-with Ada.Containers.Functional_Vectors;
-with Ada.Containers.Functional_Maps;
-private with Ada.Containers.Red_Black_Trees;
-
generic
- type Key_Type is private;
- type Element_Type is private;
-
- with function "<" (Left, Right : Key_Type) return Boolean is <>;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Ordered_Maps with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- function Equivalent_Keys (Left, Right : Key_Type) return Boolean with
- Global => null,
- Post =>
- Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left));
- pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys);
-
- type Map (Capacity : Count_Type) is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Key),
- Default_Initial_Condition => Is_Empty (Map);
- pragma Preelaborable_Initialization (Map);
-
- type Cursor is record
- Node : Count_Type;
- end record;
-
- No_Element : constant Cursor := (Node => 0);
-
- Empty_Map : constant Map;
-
- function Length (Container : Map) return Count_Type with
- Global => null,
- Post => Length'Result <= Container.Capacity;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Maps
- (Element_Type => Element_Type,
- Key_Type => Key_Type,
- Equivalent_Keys => Equivalent_Keys);
-
- function "="
- (Left : M.Map;
- Right : M.Map) return Boolean renames M."=";
-
- function "<="
- (Left : M.Map;
- Right : M.Map) return Boolean renames M."<=";
-
- package K is new Ada.Containers.Functional_Vectors
- (Element_Type => Key_Type,
- Index_Type => Positive_Count_Type);
-
- function "="
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."=";
-
- function "<"
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."<";
-
- function "<="
- (Left : K.Sequence;
- Right : K.Sequence) return Boolean renames K."<=";
-
- function K_Bigger_Than_Range
- (Container : K.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= K.Length (Container),
- Post =>
- K_Bigger_Than_Range'Result =
- (for all I in Fst .. Lst => K.Get (Container, I) < Key);
- pragma Annotate (GNATprove, Inline_For_Proof, K_Bigger_Than_Range);
-
- function K_Smaller_Than_Range
- (Container : K.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= K.Length (Container),
- Post =>
- K_Smaller_Than_Range'Result =
- (for all I in Fst .. Lst => Key < K.Get (Container, I));
- pragma Annotate (GNATprove, Inline_For_Proof, K_Smaller_Than_Range);
-
- function K_Is_Find
- (Container : K.Sequence;
- Key : Key_Type;
- Position : Count_Type) return Boolean
- with
- Global => null,
- Pre => Position - 1 <= K.Length (Container),
- Post =>
- K_Is_Find'Result =
- ((if Position > 0 then
- K_Bigger_Than_Range (Container, 1, Position - 1, Key))
-
- and
- (if Position < K.Length (Container) then
- K_Smaller_Than_Range
- (Container,
- Position + 1,
- K.Length (Container),
- Key)));
- pragma Annotate (GNATprove, Inline_For_Proof, K_Is_Find);
-
- function Find (Container : K.Sequence; Key : Key_Type) return Count_Type
- -- Search for Key in Container
-
- with
- Global => null,
- Post =>
- (if Find'Result > 0 then
- Find'Result <= K.Length (Container)
- and Equivalent_Keys (Key, K.Get (Container, Find'Result)));
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Global => null,
- Post =>
- P_Positions_Shifted'Result =
-
- -- Big contains all cursors of Small
-
- (P.Keys_Included (Small, Big)
-
- -- Cursors located before Cut are not moved, cursors located
- -- after are shifted by Count.
-
- and (for all I of Small =>
- (if P.Get (Small, I) < Cut then
- P.Get (Big, I) = P.Get (Small, I)
- else
- P.Get (Big, I) - Count = P.Get (Small, I)))
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function Model (Container : Map) return M.Map with
- -- The high-level model of a map is a map from keys to elements. Neither
- -- cursors nor order of elements are represented in this model. Keys are
- -- modeled up to equivalence.
-
- Ghost,
- Global => null;
-
- function Keys (Container : Map) return K.Sequence with
- -- The Keys sequence represents the underlying list structure of maps
- -- that is used for iteration. It stores the actual values of keys in
- -- the map. It does not model cursors nor elements.
-
- Ghost,
- Global => null,
- Post =>
- K.Length (Keys'Result) = Length (Container)
-
- -- It only contains keys contained in Model
-
- and (for all Key of Keys'Result =>
- M.Has_Key (Model (Container), Key))
-
- -- It contains all the keys contained in Model
-
- and (for all Key of Model (Container) =>
- (Find (Keys'Result, Key) > 0
- and then Equivalent_Keys
- (K.Get (Keys'Result, Find (Keys'Result, Key)),
- Key)))
-
- -- It is sorted in increasing order
-
- and (for all I in 1 .. Length (Container) =>
- Find (Keys'Result, K.Get (Keys'Result, I)) = I
- and K_Is_Find (Keys'Result, K.Get (Keys'Result, I), I));
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys);
-
- function Positions (Container : Map) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and maps them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length.
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : Map) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level, cursor-aware view of a container, to a high-level,
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Key of Keys (Container) =>
- (for some I of Positions (Container) =>
- K.Get (Keys (Container), P.Get (Positions (Container), I)) =
- Key));
-
- function Contains
- (C : M.Map;
- K : Key_Type) return Boolean renames M.Has_Key;
- -- To improve readability of contracts, we rename the function used to
- -- search for a key in the model to Contains.
-
- function Element
- (C : M.Map;
- K : Key_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
- end Formal_Model;
- use Formal_Model;
-
- function "=" (Left, Right : Map) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function Is_Empty (Container : Map) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out Map) with
- Global => null,
- Post => Length (Container) = 0 and M.Is_Empty (Model (Container));
-
- procedure Assign (Target : in out Map; Source : Map) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)
- and Keys (Target) = Keys (Source)
- and Length (Source) = Length (Target);
-
- function Copy (Source : Map; Capacity : Count_Type := 0) return Map with
- Global => null,
- Pre => Capacity = 0 or else Capacity >= Source.Capacity,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Keys (Copy'Result) = Keys (Source)
- and Positions (Copy'Result) = Positions (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Source.Capacity
- else
- Copy'Result.Capacity = Capacity);
-
- function Key (Container : Map; Position : Cursor) return Key_Type with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Key'Result =
- K.Get (Keys (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Key);
-
- function Element
- (Container : Map;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result = Element (Model (Container), Key (Container, Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Map;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old
-
- -- New_Item is now associated with the key at position Position in
- -- Container.
-
- and Element (Container, Position) = New_Item
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key (Container, Position));
-
- function At_End
- (E : not null access constant Map) return not null access constant Map
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : aliased Map;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- Element (Model (Container), Key (Container, Position));
-
- function Reference
- (Container : not null access Map;
- Position : Cursor) return not null access Element_Type
- with
- Global => null,
- Pre => Has_Element (Container.all, Position),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (At_End (Container).all) = Keys (Container.all)
- and Positions (At_End (Container).all) = Positions (Container.all)
-
- -- The value designated by the result of Reference is now associated
- -- with the key at position Position in Container.
-
- and Element (At_End (Container).all, Position) =
- At_End (Reference'Result).all
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys
- (Model (At_End (Container).all),
- Model (Container.all))
- and M.Elements_Equal_Except
- (Model (At_End (Container).all),
- Model (Container.all),
- Key (At_End (Container).all, Position));
-
- function Constant_Reference
- (Container : aliased Map;
- Key : Key_Type) return not null access constant Element_Type
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Constant_Reference'Result.all = Element (Model (Container), Key);
-
- function Reference
- (Container : not null access Map;
- Key : Key_Type) return not null access Element_Type
- with
- Global => null,
- Pre => Contains (Container.all, Key),
- Post =>
-
- -- Order of keys and cursors is preserved
-
- Keys (At_End (Container).all) = Keys (Container.all)
- and Positions (At_End (Container).all) = Positions (Container.all)
-
- -- The value designated by the result of Reference is now associated
- -- with Key in Container.
-
- and Element (Model (At_End (Container).all), Key) =
- At_End (Reference'Result).all
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys
- (Model (At_End (Container).all),
- Model (Container.all))
- and M.Elements_Equal_Except
- (Model (At_End (Container).all),
- Model (Container.all),
- Key);
-
- procedure Move (Target : in out Map; Source : in out Map) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)'Old
- and Keys (Target) = Keys (Source)'Old
- and Length (Source)'Old = Length (Target)
- and Length (Source) = 0;
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity or Contains (Container, Key),
- Post =>
- Contains (Container, Key)
- and Has_Element (Container, Position)
- and Equivalent_Keys
- (Formal_Ordered_Maps.Key (Container, Position), Key)
- and K_Is_Find
- (Keys (Container),
- Key,
- P.Get (Positions (Container), Position)),
- Contract_Cases =>
-
- -- If Key is already in Container, it is not modified and Inserted is
- -- set to False.
-
- (Contains (Container, Key) =>
- not Inserted
- and Model (Container) = Model (Container)'Old
- and Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Key is inserted in Container and Inserted is set to True
-
- others =>
- Inserted
- and Length (Container) = Length (Container)'Old + 1
-
- -- Key now maps to New_Item
-
- and Formal_Ordered_Maps.Key (Container, Position) = Key
- and Element (Model (Container), Key) = New_Item
-
- -- Other mappings are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- The keys of Container located before Position are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other keys are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted at position Position in
- -- Container.
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position)));
-
- procedure Insert
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- and then (not Contains (Container, Key)),
- Post =>
- Length (Container) = Length (Container)'Old + 1
- and Contains (Container, Key)
-
- -- Key now maps to New_Item
-
- and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key
- and Element (Model (Container), Key) = New_Item
-
- -- Other mappings are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- The keys of Container located before Key are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => Find (Keys (Container), Key) - 1)
-
- -- Other keys are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => Find (Keys (Container), Key),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Find (Keys (Container), Key));
-
- procedure Include
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity or Contains (Container, Key),
- Post =>
- Contains (Container, Key) and Element (Container, Key) = New_Item,
- Contract_Cases =>
-
- -- If Key is already in Container, Key is mapped to New_Item
-
- (Contains (Container, Key) =>
-
- -- Cursors are preserved
-
- Positions (Container) = Positions (Container)'Old
-
- -- The key equivalent to Key in Container is replaced by Key
-
- and K.Get
- (Keys (Container), Find (Keys (Container), Key)) = Key
-
- and K.Equal_Except
- (Keys (Container)'Old,
- Keys (Container),
- Find (Keys (Container), Key))
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key),
-
- -- Otherwise, Key is inserted in Container
-
- others =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Other mappings are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Keys_Included_Except
- (Model (Container),
- Model (Container)'Old,
- Key)
-
- -- Key is inserted in Container
-
- and K.Get
- (Keys (Container), Find (Keys (Container), Key)) = Key
-
- -- The keys of Container located before Key are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => Find (Keys (Container), Key) - 1)
-
- -- Other keys are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => Find (Keys (Container), Key),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Find (Keys (Container), Key)));
-
- procedure Replace
- (Container : in out Map;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
-
- -- Cursors are preserved
-
- Positions (Container) = Positions (Container)'Old
-
- -- The key equivalent to Key in Container is replaced by Key
-
- and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key
- and K.Equal_Except
- (Keys (Container)'Old,
- Keys (Container),
- Find (Keys (Container), Key))
-
- -- New_Item is now associated with the Key in Container
-
- and Element (Model (Container), Key) = New_Item
-
- -- Elements associated with other keys are preserved
-
- and M.Same_Keys (Model (Container), Model (Container)'Old)
- and M.Elements_Equal_Except
- (Model (Container),
- Model (Container)'Old,
- Key);
-
- procedure Exclude (Container : in out Map; Key : Key_Type) with
- Global => null,
- Post => not Contains (Container, Key),
- Contract_Cases =>
-
- -- If Key is not in Container, nothing is changed
-
- (not Contains (Container, Key) =>
- Model (Container) = Model (Container)'Old
- and Keys (Container) = Keys (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Key is removed from Container
-
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Other mappings are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- The keys of Container located before Key are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => Find (Keys (Container), Key)'Old - 1)
-
- -- The keys located after Key are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container),
- Right => Keys (Container)'Old,
- Fst => Find (Keys (Container), Key)'Old,
- Lst => Length (Container),
- Offset => 1)
-
- -- A cursor has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Find (Keys (Container), Key)'Old));
-
- procedure Delete (Container : in out Map; Key : Key_Type) with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Key is no longer in Container
-
- and not Contains (Container, Key)
-
- -- Other mappings are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key)
-
- -- The keys of Container located before Key are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => Find (Keys (Container), Key)'Old - 1)
-
- -- The keys located after Key are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container),
- Right => Keys (Container)'Old,
- Fst => Find (Keys (Container), Key)'Old,
- Lst => Length (Container),
- Offset => 1)
-
- -- A cursor has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Find (Keys (Container), Key)'Old);
-
- procedure Delete (Container : in out Map; Position : in out Cursor) with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Position = No_Element
- and Length (Container) = Length (Container)'Old - 1
-
- -- The key at position Position is no longer in Container
-
- and not Contains (Container, Key (Container, Position)'Old)
- and not P.Has_Key (Positions (Container), Position'Old)
-
- -- Other mappings are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Key (Container, Position)'Old)
-
- -- The keys of Container located before Position are preserved.
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1)
-
- -- The keys located after Position are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container),
- Right => Keys (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => 1)
-
- -- Position has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old));
-
- procedure Delete_First (Container : in out Map) with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 => Length (Container) = 0,
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The first key has been removed from Container
-
- and not Contains (Container, First_Key (Container)'Old)
-
- -- Other mappings are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- First_Key (Container)'Old)
-
- -- Other keys are shifted by 1
-
- and K.Range_Shifted
- (Left => Keys (Container),
- Right => Keys (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => 1)
-
- -- First has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1));
-
- procedure Delete_Last (Container : in out Map) with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 => Length (Container) = 0,
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The last key has been removed from Container
-
- and not Contains (Container, Last_Key (Container)'Old)
-
- -- Other mappings are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Keys_Included_Except
- (Model (Container)'Old,
- Model (Container),
- Last_Key (Container)'Old)
-
- -- Others keys of Container are preserved
-
- and K.Range_Equal
- (Left => Keys (Container)'Old,
- Right => Keys (Container),
- Fst => 1,
- Lst => Length (Container))
-
- -- Last cursor has been removed from Container
-
- and Positions (Container) <= Positions (Container)'Old);
-
- function First (Container : Map) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
-
- function First_Element (Container : Map) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- First_Element'Result =
- Element (Model (Container), First_Key (Container));
-
- function First_Key (Container : Map) return Key_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- First_Key'Result = K.Get (Keys (Container), 1)
- and K_Smaller_Than_Range
- (Keys (Container), 2, Length (Container), First_Key'Result);
-
- function Last (Container : Map) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- Last'Result = No_Element,
-
- others =>
- Has_Element (Container, Last'Result)
- and P.Get (Positions (Container), Last'Result) =
- Length (Container));
-
- function Last_Element (Container : Map) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result = Element (Model (Container), Last_Key (Container));
-
- function Last_Key (Container : Map) return Key_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Key'Result = K.Get (Keys (Container), Length (Container))
- and K_Bigger_Than_Range
- (Keys (Container), 1, Length (Container) - 1, Last_Key'Result);
-
- function Next (Container : Map; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
-
- procedure Next (Container : Map; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
-
- function Previous (Container : Map; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Previous'Result = No_Element,
-
- others =>
- Has_Element (Container, Previous'Result)
- and then P.Get (Positions (Container), Previous'Result) =
- P.Get (Positions (Container), Position) - 1);
-
- procedure Previous (Container : Map; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) - 1);
-
- function Find (Container : Map; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
-
- -- If Key is not contained in Container, Find returns No_Element
-
- (not Contains (Model (Container), Key) =>
- not P.Has_Key (Positions (Container), Find'Result)
- and Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
- and P.Get (Positions (Container), Find'Result) =
- Find (Keys (Container), Key)
-
- -- The key designated by the result of Find is Key
-
- and Equivalent_Keys
- (Formal_Ordered_Maps.Key (Container, Find'Result), Key));
-
- function Element (Container : Map; Key : Key_Type) return Element_Type with
- Global => null,
- Pre => Contains (Container, Key),
- Post => Element'Result = Element (Model (Container), Key);
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- function Floor (Container : Map; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 or else Key < First_Key (Container) =>
- Floor'Result = No_Element,
-
- others =>
- Has_Element (Container, Floor'Result)
- and not (Key < K.Get (Keys (Container),
- P.Get (Positions (Container), Floor'Result)))
- and K_Is_Find
- (Keys (Container),
- Key,
- P.Get (Positions (Container), Floor'Result)));
-
- function Ceiling (Container : Map; Key : Key_Type) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 or else Last_Key (Container) < Key =>
- Ceiling'Result = No_Element,
- others =>
- Has_Element (Container, Ceiling'Result)
- and not (K.Get
- (Keys (Container),
- P.Get (Positions (Container), Ceiling'Result)) < Key)
- and K_Is_Find
- (Keys (Container),
- Key,
- P.Get (Positions (Container), Ceiling'Result)));
-
- function Contains (Container : Map; Key : Key_Type) return Boolean with
- Global => null,
- Post => Contains'Result = Contains (Model (Container), Key);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Has_Element (Container : Map; Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
-private
- pragma SPARK_Mode (Off);
-
- pragma Inline (Next);
- pragma Inline (Previous);
-
- subtype Node_Access is Count_Type;
-
- use Red_Black_Trees;
-
- type Node_Type is record
- Has_Element : Boolean := False;
- Parent : Node_Access := 0;
- Left : Node_Access := 0;
- Right : Node_Access := 0;
- Color : Red_Black_Trees.Color_Type := Red;
- Key : Key_Type;
- Element : aliased Element_Type;
- end record;
-
- package Tree_Types is
- new Ada.Containers.Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
-
- type Map (Capacity : Count_Type) is record
- Content : Tree_Types.Tree_Type (Capacity);
- end record;
+package Ada.Containers.Formal_Ordered_Maps with SPARK_Mode is
- Empty_Map : constant Map := (Capacity => 0, others => <>);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Ordered_Maps;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
-pragma Elaborate_All
- (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
-
-with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
-pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
-
-with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
-pragma Elaborate_All
- (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations);
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Ordered_Sets with
- SPARK_Mode => Off
-is
-
- ------------------------------
- -- Access to Fields of Node --
- ------------------------------
-
- -- These subprograms provide functional notation for access to fields
- -- of a node, and procedural notation for modifiying these fields.
-
- function Color (Node : Node_Type) return Red_Black_Trees.Color_Type;
- pragma Inline (Color);
-
- function Left_Son (Node : Node_Type) return Count_Type;
- pragma Inline (Left_Son);
-
- function Parent (Node : Node_Type) return Count_Type;
- pragma Inline (Parent);
-
- function Right_Son (Node : Node_Type) return Count_Type;
- pragma Inline (Right_Son);
-
- procedure Set_Color
- (Node : in out Node_Type;
- Color : Red_Black_Trees.Color_Type);
- pragma Inline (Set_Color);
-
- procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
- pragma Inline (Set_Left);
-
- procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
- pragma Inline (Set_Right);
-
- procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
- pragma Inline (Set_Parent);
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- -- Comments needed???
-
- procedure Assign
- (Target : in out Tree_Types.Tree_Type;
- Source : Tree_Types.Tree_Type);
-
- generic
- with procedure Set_Element (Node : in out Node_Type);
- procedure Generic_Allocate
- (Tree : in out Tree_Types.Tree_Type'Class;
- Node : out Count_Type);
-
- procedure Free (Tree : in out Set; X : Count_Type);
-
- procedure Insert_Sans_Hint
- (Container : in out Tree_Types.Tree_Type;
- New_Item : Element_Type;
- Node : out Count_Type;
- Inserted : out Boolean);
-
- procedure Insert_With_Hint
- (Dst_Set : in out Tree_Types.Tree_Type;
- Dst_Hint : Count_Type;
- Src_Node : Node_Type;
- Dst_Node : out Count_Type);
-
- function Is_Greater_Element_Node
- (Left : Element_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Greater_Element_Node);
-
- function Is_Less_Element_Node
- (Left : Element_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Less_Element_Node);
-
- function Is_Less_Node_Node (L, R : Node_Type) return Boolean;
- pragma Inline (Is_Less_Node_Node);
-
- procedure Replace_Element
- (Tree : in out Set;
- Node : Count_Type;
- Item : Element_Type);
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package Tree_Operations is
- new Red_Black_Trees.Generic_Bounded_Operations
- (Tree_Types,
- Left => Left_Son,
- Right => Right_Son);
-
- use Tree_Operations;
-
- package Element_Keys is
- new Red_Black_Trees.Generic_Bounded_Keys
- (Tree_Operations => Tree_Operations,
- Key_Type => Element_Type,
- Is_Less_Key_Node => Is_Less_Element_Node,
- Is_Greater_Key_Node => Is_Greater_Element_Node);
-
- package Set_Ops is
- new Red_Black_Trees.Generic_Bounded_Set_Operations
- (Tree_Operations => Tree_Operations,
- Set_Type => Tree_Types.Tree_Type,
- Assign => Assign,
- Insert_With_Hint => Insert_With_Hint,
- Is_Less => Is_Less_Node_Node);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left, Right : Set) return Boolean is
- Lst : Count_Type;
- Node : Count_Type;
- ENode : Count_Type;
-
- begin
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- if Is_Empty (Left) then
- return True;
- end if;
-
- Lst := Next (Left.Content, Last (Left).Node);
-
- Node := First (Left).Node;
- while Node /= Lst loop
- ENode := Find (Right, Left.Content.Nodes (Node).Element).Node;
- if ENode = 0
- or else Left.Content.Nodes (Node).Element /=
- Right.Content.Nodes (ENode).Element
- then
- return False;
- end if;
-
- Node := Next (Left.Content, Node);
- end loop;
-
- return True;
- end "=";
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign
- (Target : in out Tree_Types.Tree_Type;
- Source : Tree_Types.Tree_Type)
- is
- procedure Append_Element (Source_Node : Count_Type);
-
- procedure Append_Elements is
- new Tree_Operations.Generic_Iteration (Append_Element);
-
- --------------------
- -- Append_Element --
- --------------------
-
- procedure Append_Element (Source_Node : Count_Type) is
- SN : Node_Type renames Source.Nodes (Source_Node);
-
- procedure Set_Element (Node : in out Node_Type);
- pragma Inline (Set_Element);
-
- function New_Node return Count_Type;
- pragma Inline (New_Node);
-
- procedure Insert_Post is
- new Element_Keys.Generic_Insert_Post (New_Node);
-
- procedure Unconditional_Insert_Sans_Hint is
- new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
-
- procedure Unconditional_Insert_Avec_Hint is
- new Element_Keys.Generic_Unconditional_Insert_With_Hint
- (Insert_Post,
- Unconditional_Insert_Sans_Hint);
-
- procedure Allocate is new Generic_Allocate (Set_Element);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Count_Type is
- Result : Count_Type;
- begin
- Allocate (Target, Result);
- return Result;
- end New_Node;
-
- -----------------
- -- Set_Element --
- -----------------
-
- procedure Set_Element (Node : in out Node_Type) is
- begin
- Node.Element := SN.Element;
- end Set_Element;
-
- -- Local variables
-
- Target_Node : Count_Type;
-
- -- Start of processing for Append_Element
-
- begin
- Unconditional_Insert_Avec_Hint
- (Tree => Target,
- Hint => 0,
- Key => SN.Element,
- Node => Target_Node);
- end Append_Element;
-
- -- Start of processing for Assign
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Source.Length then
- raise Constraint_Error
- with "Target capacity is less than Source length";
- end if;
-
- Tree_Operations.Clear_Tree (Target);
- Append_Elements (Source);
- end Assign;
-
- procedure Assign (Target : in out Set; Source : Set) is
- begin
- Assign (Target.Content, Source.Content);
- end Assign;
-
- -------------
- -- Ceiling --
- -------------
-
- function Ceiling (Container : Set; Item : Element_Type) return Cursor is
- Node : constant Count_Type :=
- Element_Keys.Ceiling (Container.Content, Item);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Ceiling;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Set) is
- begin
- Tree_Operations.Clear_Tree (Container.Content);
- end Clear;
-
- -----------
- -- Color --
- -----------
-
- function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is
- begin
- return Node.Color;
- end Color;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Set;
- Position : Cursor) return not null access constant Element_Type
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Element");
-
- return Container.Content.Nodes (Position.Node).Element'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Set;
- Item : Element_Type) return Boolean
- is
- begin
- return Find (Container, Item) /= No_Element;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
- Node : Count_Type;
- N : Count_Type;
- Target : Set (Count_Type'Max (Source.Capacity, Capacity));
-
- begin
- if 0 < Capacity and then Capacity < Source.Capacity then
- raise Capacity_Error;
- end if;
-
- if Length (Source) > 0 then
- Target.Content.Length := Source.Content.Length;
- Target.Content.Root := Source.Content.Root;
- Target.Content.First := Source.Content.First;
- Target.Content.Last := Source.Content.Last;
- Target.Content.Free := Source.Content.Free;
-
- Node := 1;
- while Node <= Source.Capacity loop
- Target.Content.Nodes (Node).Element :=
- Source.Content.Nodes (Node).Element;
- Target.Content.Nodes (Node).Parent :=
- Source.Content.Nodes (Node).Parent;
- Target.Content.Nodes (Node).Left :=
- Source.Content.Nodes (Node).Left;
- Target.Content.Nodes (Node).Right :=
- Source.Content.Nodes (Node).Right;
- Target.Content.Nodes (Node).Color :=
- Source.Content.Nodes (Node).Color;
- Target.Content.Nodes (Node).Has_Element :=
- Source.Content.Nodes (Node).Has_Element;
- Node := Node + 1;
- end loop;
-
- while Node <= Target.Capacity loop
- N := Node;
- Free (Tree => Target, X => N);
- Node := Node + 1;
- end loop;
- end if;
-
- return Target;
- end Copy;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Set; Position : in out Cursor) is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Delete");
-
- Tree_Operations.Delete_Node_Sans_Free (Container.Content,
- Position.Node);
- Free (Container, Position.Node);
- Position := No_Element;
- end Delete;
-
- procedure Delete (Container : in out Set; Item : Element_Type) is
- X : constant Count_Type := Element_Keys.Find (Container.Content, Item);
-
- begin
- if X = 0 then
- raise Constraint_Error with "attempt to delete element not in set";
- end if;
-
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out Set) is
- X : constant Count_Type := Container.Content.First;
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out Set) is
- X : constant Count_Type := Container.Content.Last;
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Delete_Last;
-
- ----------------
- -- Difference --
- ----------------
-
- procedure Difference (Target : in out Set; Source : Set) is
- begin
- Set_Ops.Set_Difference (Target.Content, Source.Content);
- end Difference;
-
- function Difference (Left, Right : Set) return Set is
- begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- if Length (Left) = 0 then
- return Empty_Set;
- end if;
-
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- return S : Set (Length (Left)) do
- Assign
- (S.Content, Set_Ops.Set_Difference (Left.Content, Right.Content));
- end return;
- end Difference;
-
- -------------
- -- Element --
- -------------
-
- function Element (Container : Set; Position : Cursor) return Element_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Element");
-
- return Container.Content.Nodes (Position.Node).Element;
- end Element;
-
- -------------------------
- -- Equivalent_Elements --
- -------------------------
-
- function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
- begin
- if Left < Right
- or else Right < Left
- then
- return False;
- else
- return True;
- end if;
- end Equivalent_Elements;
-
- ---------------------
- -- Equivalent_Sets --
- ---------------------
-
- function Equivalent_Sets (Left, Right : Set) return Boolean is
- function Is_Equivalent_Node_Node
- (L, R : Node_Type) return Boolean;
- pragma Inline (Is_Equivalent_Node_Node);
-
- function Is_Equivalent is
- new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
-
- -----------------------------
- -- Is_Equivalent_Node_Node --
- -----------------------------
-
- function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is
- begin
- if L.Element < R.Element then
- return False;
- elsif R.Element < L.Element then
- return False;
- else
- return True;
- end if;
- end Is_Equivalent_Node_Node;
-
- -- Start of processing for Equivalent_Sets
-
- begin
- return Is_Equivalent (Left.Content, Right.Content);
- end Equivalent_Sets;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Set; Item : Element_Type) is
- X : constant Count_Type := Element_Keys.Find (Container.Content, Item);
- begin
- if X /= 0 then
- Tree_Operations.Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find (Container : Set; Item : Element_Type) return Cursor is
- Node : constant Count_Type :=
- Element_Keys.Find (Container.Content, Item);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Find;
-
- -----------
- -- First --
- -----------
-
- function First (Container : Set) return Cursor is
- begin
- if Length (Container) = 0 then
- return No_Element;
- end if;
-
- return (Node => Container.Content.First);
- end First;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : Set) return Element_Type is
- Fst : constant Count_Type := First (Container).Node;
- begin
- if Fst = 0 then
- raise Constraint_Error with "set is empty";
- end if;
-
- declare
- N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
- begin
- return N (Fst).Element;
- end;
- end First_Element;
-
- -----------
- -- Floor --
- -----------
-
- function Floor (Container : Set; Item : Element_Type) return Cursor is
- begin
- declare
- Node : constant Count_Type :=
- Element_Keys.Floor (Container.Content, Item);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end;
- end Floor;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -------------------------
- -- E_Bigger_Than_Range --
- -------------------------
-
- function E_Bigger_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Item : Element_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (E.Get (Container, I) < Item) then
- return False;
- end if;
- end loop;
-
- return True;
- end E_Bigger_Than_Range;
-
- -------------------------
- -- E_Elements_Included --
- -------------------------
-
- function E_Elements_Included
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Left) loop
- if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- function E_Elements_Included
- (Left : E.Sequence;
- Model : M.Set;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Left) loop
- declare
- Item : constant Element_Type := E.Get (Left, I);
- begin
- if M.Contains (Model, Item) then
- if not E.Contains (Right, 1, E.Length (Right), Item) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- function E_Elements_Included
- (Container : E.Sequence;
- Model : M.Set;
- Left : E.Sequence;
- Right : E.Sequence) return Boolean
- is
- begin
- for I in 1 .. E.Length (Container) loop
- declare
- Item : constant Element_Type := E.Get (Container, I);
- begin
- if M.Contains (Model, Item) then
- if not E.Contains (Left, 1, E.Length (Left), Item) then
- return False;
- end if;
- else
- if not E.Contains (Right, 1, E.Length (Right), Item) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end E_Elements_Included;
-
- ---------------
- -- E_Is_Find --
- ---------------
-
- function E_Is_Find
- (Container : E.Sequence;
- Item : Element_Type;
- Position : Count_Type) return Boolean
- is
- begin
- for I in 1 .. Position - 1 loop
- if Item < E.Get (Container, I) then
- return False;
- end if;
- end loop;
-
- if Position < E.Length (Container) then
- for I in Position + 1 .. E.Length (Container) loop
- if E.Get (Container, I) < Item then
- return False;
- end if;
- end loop;
- end if;
-
- return True;
- end E_Is_Find;
-
- --------------------------
- -- E_Smaller_Than_Range --
- --------------------------
-
- function E_Smaller_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Item : Element_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (Item < E.Get (Container, I)) then
- return False;
- end if;
- end loop;
-
- return True;
- end E_Smaller_Than_Range;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : E.Sequence;
- Item : Element_Type) return Count_Type
- is
- begin
- for I in 1 .. E.Length (Container) loop
- if Equivalent_Elements (Item, E.Get (Container, I)) then
- return I;
- end if;
- end loop;
-
- return 0;
- end Find;
-
- --------------
- -- Elements --
- --------------
-
- function Elements (Container : Set) return E.Sequence is
- Position : Count_Type := Container.Content.First;
- R : E.Sequence;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := E.Add (R, Container.Content.Nodes (Position).Element);
- Position := Tree_Operations.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Elements;
-
- ----------------------------
- -- Lift_Abstraction_Level --
- ----------------------------
-
- procedure Lift_Abstraction_Level (Container : Set) is null;
-
- -----------------------
- -- Mapping_Preserved --
- -----------------------
-
- function Mapping_Preserved
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- is
- begin
- for C of P_Left loop
- if not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > E.Length (E_Left)
- or else P.Get (P_Right, C) > E.Length (E_Right)
- or else E.Get (E_Left, P.Get (P_Left, C)) /=
- E.Get (E_Right, P.Get (P_Right, C))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved;
-
- ------------------------------
- -- Mapping_Preserved_Except --
- ------------------------------
-
- function Mapping_Preserved_Except
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map;
- Position : Cursor) return Boolean
- is
- begin
- for C of P_Left loop
- if C /= Position
- and (not P.Has_Key (P_Right, C)
- or else P.Get (P_Left, C) > E.Length (E_Left)
- or else P.Get (P_Right, C) > E.Length (E_Right)
- or else E.Get (E_Left, P.Get (P_Left, C)) /=
- E.Get (E_Right, P.Get (P_Right, C)))
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Mapping_Preserved_Except;
-
- -------------------------
- -- P_Positions_Shifted --
- -------------------------
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- is
- begin
- for Cu of Small loop
- if not P.Has_Key (Big, Cu) then
- return False;
- end if;
- end loop;
-
- for Cu of Big loop
- declare
- Pos : constant Positive_Count_Type := P.Get (Big, Cu);
-
- begin
- if Pos < Cut then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu)
- then
- return False;
- end if;
-
- elsif Pos >= Cut + Count then
- if not P.Has_Key (Small, Cu)
- or else Pos /= P.Get (Small, Cu) + Count
- then
- return False;
- end if;
-
- else
- if P.Has_Key (Small, Cu) then
- return False;
- end if;
- end if;
- end;
- end loop;
-
- return True;
- end P_Positions_Shifted;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Set) return M.Set is
- Position : Count_Type := Container.Content.First;
- R : M.Set;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R :=
- M.Add
- (Container => R,
- Item => Container.Content.Nodes (Position).Element);
-
- Position := Tree_Operations.Next (Container.Content, Position);
- end loop;
-
- return R;
- end Model;
-
- ---------------
- -- Positions --
- ---------------
-
- function Positions (Container : Set) return P.Map is
- I : Count_Type := 1;
- Position : Count_Type := Container.Content.First;
- R : P.Map;
-
- begin
- -- Can't use First, Next or Element here, since they depend on models
- -- for their postconditions.
-
- while Position /= 0 loop
- R := P.Add (R, (Node => Position), I);
- pragma Assert (P.Length (R) = Big (I));
- Position := Tree_Operations.Next (Container.Content, Position);
- I := I + 1;
- end loop;
-
- return R;
- end Positions;
-
- end Formal_Model;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Tree : in out Set; X : Count_Type) is
- begin
- Tree.Content.Nodes (X).Has_Element := False;
- Tree_Operations.Free (Tree.Content, X);
- end Free;
-
- ----------------------
- -- Generic_Allocate --
- ----------------------
-
- procedure Generic_Allocate
- (Tree : in out Tree_Types.Tree_Type'Class;
- Node : out Count_Type)
- is
- procedure Allocate is
- new Tree_Operations.Generic_Allocate (Set_Element);
- begin
- Allocate (Tree, Node);
- Tree.Nodes (Node).Has_Element := True;
- end Generic_Allocate;
-
- ------------------
- -- Generic_Keys --
- ------------------
-
- package body Generic_Keys with SPARK_Mode => Off is
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function Is_Greater_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Greater_Key_Node);
-
- function Is_Less_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean;
- pragma Inline (Is_Less_Key_Node);
-
- --------------------------
- -- Local Instantiations --
- --------------------------
-
- package Key_Keys is
- new Red_Black_Trees.Generic_Bounded_Keys
- (Tree_Operations => Tree_Operations,
- Key_Type => Key_Type,
- Is_Less_Key_Node => Is_Less_Key_Node,
- Is_Greater_Key_Node => Is_Greater_Key_Node);
-
- -------------
- -- Ceiling --
- -------------
-
- function Ceiling (Container : Set; Key : Key_Type) return Cursor is
- Node : constant Count_Type :=
- Key_Keys.Ceiling (Container.Content, Key);
-
- begin
- if Node = 0 then
- return No_Element;
- end if;
-
- return (Node => Node);
- end Ceiling;
-
- --------------
- -- Contains --
- --------------
-
- function Contains (Container : Set; Key : Key_Type) return Boolean is
- begin
- return Find (Container, Key) /= No_Element;
- end Contains;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Set; Key : Key_Type) is
- X : constant Count_Type := Key_Keys.Find (Container.Content, Key);
-
- begin
- if X = 0 then
- raise Constraint_Error with "attempt to delete key not in set";
- end if;
-
- Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end Delete;
-
- -------------
- -- Element --
- -------------
-
- function Element (Container : Set; Key : Key_Type) return Element_Type is
- Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
-
- begin
- if Node = 0 then
- raise Constraint_Error with "key not in set";
- end if;
-
- declare
- N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
- begin
- return N (Node).Element;
- end;
- end Element;
-
- ---------------------
- -- Equivalent_Keys --
- ---------------------
-
- function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
- begin
- if Left < Right
- or else Right < Left
- then
- return False;
- else
- return True;
- end if;
- end Equivalent_Keys;
-
- -------------
- -- Exclude --
- -------------
-
- procedure Exclude (Container : in out Set; Key : Key_Type) is
- X : constant Count_Type := Key_Keys.Find (Container.Content, Key);
- begin
- if X /= 0 then
- Delete_Node_Sans_Free (Container.Content, X);
- Free (Container, X);
- end if;
- end Exclude;
-
- ----------
- -- Find --
- ----------
-
- function Find (Container : Set; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
- begin
- return (if Node = 0 then No_Element else (Node => Node));
- end Find;
-
- -----------
- -- Floor --
- -----------
-
- function Floor (Container : Set; Key : Key_Type) return Cursor is
- Node : constant Count_Type := Key_Keys.Floor (Container.Content, Key);
- begin
- return (if Node = 0 then No_Element else (Node => Node));
- end Floor;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -------------------------
- -- E_Bigger_Than_Range --
- -------------------------
-
- function E_Bigger_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (Generic_Keys.Key (E.Get (Container, I)) < Key) then
- return False;
- end if;
- end loop;
- return True;
- end E_Bigger_Than_Range;
-
- ---------------
- -- E_Is_Find --
- ---------------
-
- function E_Is_Find
- (Container : E.Sequence;
- Key : Key_Type;
- Position : Count_Type) return Boolean
- is
- begin
- for I in 1 .. Position - 1 loop
- if Key < Generic_Keys.Key (E.Get (Container, I)) then
- return False;
- end if;
- end loop;
-
- if Position < E.Length (Container) then
- for I in Position + 1 .. E.Length (Container) loop
- if Generic_Keys.Key (E.Get (Container, I)) < Key then
- return False;
- end if;
- end loop;
- end if;
- return True;
- end E_Is_Find;
-
- --------------------------
- -- E_Smaller_Than_Range --
- --------------------------
-
- function E_Smaller_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if not (Key < Generic_Keys.Key (E.Get (Container, I))) then
- return False;
- end if;
- end loop;
- return True;
- end E_Smaller_Than_Range;
-
- ----------
- -- Find --
- ----------
-
- function Find
- (Container : E.Sequence;
- Key : Key_Type) return Count_Type
- is
- begin
- for I in 1 .. E.Length (Container) loop
- if Equivalent_Keys
- (Key, Generic_Keys.Key (E.Get (Container, I)))
- then
- return I;
- end if;
- end loop;
- return 0;
- end Find;
-
- -----------------------
- -- M_Included_Except --
- -----------------------
-
- function M_Included_Except
- (Left : M.Set;
- Right : M.Set;
- Key : Key_Type) return Boolean
- is
- begin
- for E of Left loop
- if not Contains (Right, E)
- and not Equivalent_Keys (Generic_Keys.Key (E), Key)
- then
- return False;
- end if;
- end loop;
- return True;
- end M_Included_Except;
- end Formal_Model;
-
- -------------------------
- -- Is_Greater_Key_Node --
- -------------------------
-
- function Is_Greater_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean
- is
- begin
- return Key (Right.Element) < Left;
- end Is_Greater_Key_Node;
-
- ----------------------
- -- Is_Less_Key_Node --
- ----------------------
-
- function Is_Less_Key_Node
- (Left : Key_Type;
- Right : Node_Type) return Boolean
- is
- begin
- return Left < Key (Right.Element);
- end Is_Less_Key_Node;
-
- ---------
- -- Key --
- ---------
-
- function Key (Container : Set; Position : Cursor) return Key_Type is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Key");
-
- declare
- N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
- begin
- return Key (N (Position.Node).Element);
- end;
- end Key;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace
- (Container : in out Set;
- Key : Key_Type;
- New_Item : Element_Type)
- is
- Node : constant Count_Type := Key_Keys.Find (Container.Content, Key);
- begin
- if not Has_Element (Container, (Node => Node)) then
- raise Constraint_Error with
- "attempt to replace key not in set";
- else
- Replace_Element (Container, Node, New_Item);
- end if;
- end Replace;
-
- end Generic_Keys;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element (Container : Set; Position : Cursor) return Boolean is
- begin
- if Position.Node = 0 then
- return False;
- else
- return Container.Content.Nodes (Position.Node).Has_Element;
- end if;
- end Has_Element;
-
- -------------
- -- Include --
- -------------
-
- procedure Include (Container : in out Set; New_Item : Element_Type) is
- Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, New_Item, Position, Inserted);
-
- if not Inserted then
- declare
- N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
- begin
- N (Position.Node).Element := New_Item;
- end;
- end if;
- end Include;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- is
- begin
- Insert_Sans_Hint (Container.Content, New_Item, Position.Node, Inserted);
- end Insert;
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type)
- is
- Position : Cursor;
- Inserted : Boolean;
-
- begin
- Insert (Container, New_Item, Position, Inserted);
-
- if not Inserted then
- raise Constraint_Error with
- "attempt to insert element already in set";
- end if;
- end Insert;
-
- ----------------------
- -- Insert_Sans_Hint --
- ----------------------
-
- procedure Insert_Sans_Hint
- (Container : in out Tree_Types.Tree_Type;
- New_Item : Element_Type;
- Node : out Count_Type;
- Inserted : out Boolean)
- is
- procedure Set_Element (Node : in out Node_Type);
-
- function New_Node return Count_Type;
- pragma Inline (New_Node);
-
- procedure Insert_Post is
- new Element_Keys.Generic_Insert_Post (New_Node);
-
- procedure Conditional_Insert_Sans_Hint is
- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
-
- procedure Allocate is new Generic_Allocate (Set_Element);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Count_Type is
- Result : Count_Type;
- begin
- Allocate (Container, Result);
- return Result;
- end New_Node;
-
- -----------------
- -- Set_Element --
- -----------------
-
- procedure Set_Element (Node : in out Node_Type) is
- begin
- Node.Element := New_Item;
- end Set_Element;
-
- -- Start of processing for Insert_Sans_Hint
-
- begin
- Conditional_Insert_Sans_Hint
- (Container,
- New_Item,
- Node,
- Inserted);
- end Insert_Sans_Hint;
-
- ----------------------
- -- Insert_With_Hint --
- ----------------------
-
- procedure Insert_With_Hint
- (Dst_Set : in out Tree_Types.Tree_Type;
- Dst_Hint : Count_Type;
- Src_Node : Node_Type;
- Dst_Node : out Count_Type)
- is
- Success : Boolean;
-
- procedure Set_Element (Node : in out Node_Type);
-
- function New_Node return Count_Type;
- pragma Inline (New_Node);
-
- procedure Insert_Post is
- new Element_Keys.Generic_Insert_Post (New_Node);
-
- procedure Insert_Sans_Hint is
- new Element_Keys.Generic_Conditional_Insert (Insert_Post);
-
- procedure Local_Insert_With_Hint is
- new Element_Keys.Generic_Conditional_Insert_With_Hint
- (Insert_Post, Insert_Sans_Hint);
-
- procedure Allocate is new Generic_Allocate (Set_Element);
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Count_Type is
- Result : Count_Type;
- begin
- Allocate (Dst_Set, Result);
- return Result;
- end New_Node;
-
- -----------------
- -- Set_Element --
- -----------------
-
- procedure Set_Element (Node : in out Node_Type) is
- begin
- Node.Element := Src_Node.Element;
- end Set_Element;
-
- -- Start of processing for Insert_With_Hint
-
- begin
- Local_Insert_With_Hint
- (Dst_Set,
- Dst_Hint,
- Src_Node.Element,
- Dst_Node,
- Success);
- end Insert_With_Hint;
-
- ------------------
- -- Intersection --
- ------------------
-
- procedure Intersection (Target : in out Set; Source : Set) is
- begin
- Set_Ops.Set_Intersection (Target.Content, Source.Content);
- end Intersection;
-
- function Intersection (Left, Right : Set) return Set is
- begin
- if Left'Address = Right'Address then
- return Copy (Left);
- end if;
-
- return S : Set (Count_Type'Min (Length (Left), Length (Right))) do
- Assign (S.Content,
- Set_Ops.Set_Intersection (Left.Content, Right.Content));
- end return;
- end Intersection;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Set) return Boolean is
- begin
- return Length (Container) = 0;
- end Is_Empty;
-
- -----------------------------
- -- Is_Greater_Element_Node --
- -----------------------------
-
- function Is_Greater_Element_Node
- (Left : Element_Type;
- Right : Node_Type) return Boolean
- is
- begin
- -- Compute e > node same as node < e
-
- return Right.Element < Left;
- end Is_Greater_Element_Node;
-
- --------------------------
- -- Is_Less_Element_Node --
- --------------------------
-
- function Is_Less_Element_Node
- (Left : Element_Type;
- Right : Node_Type) return Boolean
- is
- begin
- return Left < Right.Element;
- end Is_Less_Element_Node;
-
- -----------------------
- -- Is_Less_Node_Node --
- -----------------------
-
- function Is_Less_Node_Node (L, R : Node_Type) return Boolean is
- begin
- return L.Element < R.Element;
- end Is_Less_Node_Node;
-
- ---------------
- -- Is_Subset --
- ---------------
-
- function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
- begin
- return Set_Ops.Set_Subset (Subset.Content, Of_Set => Of_Set.Content);
- end Is_Subset;
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : Set) return Cursor is
- begin
- return (if Length (Container) = 0
- then No_Element
- else (Node => Container.Content.Last));
- end Last;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : Set) return Element_Type is
- begin
- if Last (Container).Node = 0 then
- raise Constraint_Error with "set is empty";
- end if;
-
- declare
- N : Tree_Types.Nodes_Type renames Container.Content.Nodes;
- begin
- return N (Last (Container).Node).Element;
- end;
- end Last_Element;
-
- --------------
- -- Left_Son --
- --------------
-
- function Left_Son (Node : Node_Type) return Count_Type is
- begin
- return Node.Left;
- end Left_Son;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Set) return Count_Type is
- begin
- return Container.Content.Length;
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out Set; Source : in out Set) is
- N : Tree_Types.Nodes_Type renames Source.Content.Nodes;
- X : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < Length (Source) then
- raise Constraint_Error with -- ???
- "Source length exceeds Target capacity";
- end if;
-
- Clear (Target);
-
- loop
- X := Source.Content.First;
- exit when X = 0;
-
- Insert (Target, N (X).Element); -- optimize???
-
- Tree_Operations.Delete_Node_Sans_Free (Source.Content, X);
- Free (Source, X);
- end loop;
- end Move;
-
- ----------
- -- Next --
- ----------
-
- function Next (Container : Set; Position : Cursor) return Cursor is
- begin
- if Position = No_Element then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error;
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Next");
- return (Node => Tree_Operations.Next (Container.Content, Position.Node));
- end Next;
-
- procedure Next (Container : Set; Position : in out Cursor) is
- begin
- Position := Next (Container, Position);
- end Next;
-
- -------------
- -- Overlap --
- -------------
-
- function Overlap (Left, Right : Set) return Boolean is
- begin
- return Set_Ops.Set_Overlap (Left.Content, Right.Content);
- end Overlap;
-
- ------------
- -- Parent --
- ------------
-
- function Parent (Node : Node_Type) return Count_Type is
- begin
- return Node.Parent;
- end Parent;
-
- --------------
- -- Previous --
- --------------
-
- function Previous (Container : Set; Position : Cursor) return Cursor is
- begin
- if Position = No_Element then
- return No_Element;
- end if;
-
- if not Has_Element (Container, Position) then
- raise Constraint_Error;
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Previous");
-
- declare
- Node : constant Count_Type :=
- Tree_Operations.Previous (Container.Content, Position.Node);
- begin
- return (if Node = 0 then No_Element else (Node => Node));
- end;
- end Previous;
-
- procedure Previous (Container : Set; Position : in out Cursor) is
- begin
- Position := Previous (Container, Position);
- end Previous;
-
- -------------
- -- Replace --
- -------------
-
- procedure Replace (Container : in out Set; New_Item : Element_Type) is
- Node : constant Count_Type :=
- Element_Keys.Find (Container.Content, New_Item);
-
- begin
- if Node = 0 then
- raise Constraint_Error with
- "attempt to replace element not in set";
- end if;
-
- Container.Content.Nodes (Node).Element := New_Item;
- end Replace;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Tree : in out Set;
- Node : Count_Type;
- Item : Element_Type)
- is
- pragma Assert (Node /= 0);
-
- function New_Node return Count_Type;
- pragma Inline (New_Node);
-
- procedure Local_Insert_Post is
- new Element_Keys.Generic_Insert_Post (New_Node);
-
- procedure Local_Insert_Sans_Hint is
- new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
-
- procedure Local_Insert_With_Hint is
- new Element_Keys.Generic_Conditional_Insert_With_Hint
- (Local_Insert_Post,
- Local_Insert_Sans_Hint);
-
- NN : Tree_Types.Nodes_Type renames Tree.Content.Nodes;
-
- --------------
- -- New_Node --
- --------------
-
- function New_Node return Count_Type is
- N : Node_Type renames NN (Node);
- begin
- N.Element := Item;
- N.Color := Red;
- N.Parent := 0;
- N.Right := 0;
- N.Left := 0;
- return Node;
- end New_Node;
-
- Hint : Count_Type;
- Result : Count_Type;
- Inserted : Boolean;
-
- -- Start of processing for Insert
-
- begin
- if Item < NN (Node).Element
- or else NN (Node).Element < Item
- then
- null;
-
- else
- NN (Node).Element := Item;
- return;
- end if;
-
- Hint := Element_Keys.Ceiling (Tree.Content, Item);
-
- if Hint = 0 then
- null;
-
- elsif Item < NN (Hint).Element then
- if Hint = Node then
- NN (Node).Element := Item;
- return;
- end if;
-
- else
- pragma Assert (not (NN (Hint).Element < Item));
- raise Program_Error with "attempt to replace existing element";
- end if;
-
- Tree_Operations.Delete_Node_Sans_Free (Tree.Content, Node);
-
- Local_Insert_With_Hint
- (Tree => Tree.Content,
- Position => Hint,
- Key => Item,
- Node => Result,
- Inserted => Inserted);
-
- pragma Assert (Inserted);
- pragma Assert (Result = Node);
- end Replace_Element;
-
- procedure Replace_Element
- (Container : in out Set;
- Position : Cursor;
- New_Item : Element_Type)
- is
- begin
- if not Has_Element (Container, Position) then
- raise Constraint_Error with
- "Position cursor has no element";
- end if;
-
- pragma Assert (Vet (Container.Content, Position.Node),
- "bad cursor in Replace_Element");
-
- Replace_Element (Container, Position.Node, New_Item);
- end Replace_Element;
-
- ---------------
- -- Right_Son --
- ---------------
-
- function Right_Son (Node : Node_Type) return Count_Type is
- begin
- return Node.Right;
- end Right_Son;
-
- ---------------
- -- Set_Color --
- ---------------
-
- procedure Set_Color
- (Node : in out Node_Type;
- Color : Red_Black_Trees.Color_Type)
- is
- begin
- Node.Color := Color;
- end Set_Color;
-
- --------------
- -- Set_Left --
- --------------
-
- procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
- begin
- Node.Left := Left;
- end Set_Left;
-
- ----------------
- -- Set_Parent --
- ----------------
-
- procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
- begin
- Node.Parent := Parent;
- end Set_Parent;
-
- ---------------
- -- Set_Right --
- ---------------
-
- procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
- begin
- Node.Right := Right;
- end Set_Right;
-
- --------------------------
- -- Symmetric_Difference --
- --------------------------
-
- procedure Symmetric_Difference (Target : in out Set; Source : Set) is
- begin
- Set_Ops.Set_Symmetric_Difference (Target.Content, Source.Content);
- end Symmetric_Difference;
-
- function Symmetric_Difference (Left, Right : Set) return Set is
- begin
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
-
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- if Length (Left) = 0 then
- return Copy (Right);
- end if;
-
- return S : Set (Length (Left) + Length (Right)) do
- Assign
- (S.Content,
- Set_Ops.Set_Symmetric_Difference (Left.Content, Right.Content));
- end return;
- end Symmetric_Difference;
-
- ------------
- -- To_Set --
- ------------
-
- function To_Set (New_Item : Element_Type) return Set is
- Node : Count_Type;
- Inserted : Boolean;
-
- begin
- return S : Set (Capacity => 1) do
- Insert_Sans_Hint (S.Content, New_Item, Node, Inserted);
- pragma Assert (Inserted);
- end return;
- end To_Set;
-
- -----------
- -- Union --
- -----------
-
- procedure Union (Target : in out Set; Source : Set) is
- begin
- Set_Ops.Set_Union (Target.Content, Source.Content);
- end Union;
-
- function Union (Left, Right : Set) return Set is
- begin
- if Left'Address = Right'Address then
- return Copy (Left);
- end if;
-
- if Length (Left) = 0 then
- return Copy (Right);
- end if;
-
- if Length (Right) = 0 then
- return Copy (Left);
- end if;
-
- return S : Set (Length (Left) + Length (Right)) do
- Assign (S, Source => Left);
- Union (S, Right);
- end return;
- end Union;
-
-end Ada.Containers.Formal_Ordered_Sets;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- This spec is derived from package Ada.Containers.Bounded_Ordered_Sets in
--- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by
--- making it easier to express properties, and by making the specification of
--- this unit compatible with SPARK 2014. Note that the API of this unit may be
--- subject to incompatible changes as SPARK 2014 evolves.
-
--- The modifications are:
-
--- A parameter for the container is added to every function reading the
--- content of a container: Key, Element, Next, Query_Element, Previous,
--- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the
--- need to have cursors which are valid on different containers (typically
--- a container C and its previous version C'Old) for expressing properties,
--- which is not possible if cursors encapsulate an access to the underlying
--- container. The operators "<" and ">" that could not be modified that way
--- have been removed.
-
-with Ada.Containers.Functional_Maps;
-with Ada.Containers.Functional_Sets;
-with Ada.Containers.Functional_Vectors;
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-private with Ada.Containers.Red_Black_Trees;
-
generic
- type Element_Type is private;
-
- with function "<" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Ordered_Sets with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- -- Convert Count_Type to Big_Interger
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
-
- function Big (J : Count_Type) return Big_Integer renames
- Conversions.To_Big_Integer;
-
- function Equivalent_Elements (Left, Right : Element_Type) return Boolean
- with
- Global => null,
- Post =>
- Equivalent_Elements'Result =
- (not (Left < Right) and not (Right < Left));
- pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Elements);
-
- type Set (Capacity : Count_Type) is private with
- Iterable => (First => First,
- Next => Next,
- Has_Element => Has_Element,
- Element => Element),
- Default_Initial_Condition => Is_Empty (Set);
- pragma Preelaborable_Initialization (Set);
-
- type Cursor is record
- Node : Count_Type;
- end record;
-
- No_Element : constant Cursor := (Node => 0);
-
- function Length (Container : Set) return Count_Type with
- Global => null,
- Post => Length'Result <= Container.Capacity;
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package M is new Ada.Containers.Functional_Sets
- (Element_Type => Element_Type,
- Equivalent_Elements => Equivalent_Elements);
-
- function "="
- (Left : M.Set;
- Right : M.Set) return Boolean renames M."=";
-
- function "<="
- (Left : M.Set;
- Right : M.Set) return Boolean renames M."<=";
-
- package E is new Ada.Containers.Functional_Vectors
- (Element_Type => Element_Type,
- Index_Type => Positive_Count_Type);
-
- function "="
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."=";
-
- function "<"
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."<";
-
- function "<="
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean renames E."<=";
-
- function E_Bigger_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= E.Length (Container),
- Post =>
- E_Bigger_Than_Range'Result =
- (for all I in Fst .. Lst => E.Get (Container, I) < Item);
- pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range);
-
- function E_Smaller_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= E.Length (Container),
- Post =>
- E_Smaller_Than_Range'Result =
- (for all I in Fst .. Lst => Item < E.Get (Container, I));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range);
-
- function E_Is_Find
- (Container : E.Sequence;
- Item : Element_Type;
- Position : Count_Type) return Boolean
- with
- Global => null,
- Pre => Position - 1 <= E.Length (Container),
- Post =>
- E_Is_Find'Result =
-
- ((if Position > 0 then
- E_Bigger_Than_Range (Container, 1, Position - 1, Item))
-
- and (if Position < E.Length (Container) then
- E_Smaller_Than_Range
- (Container,
- Position + 1,
- E.Length (Container),
- Item)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find);
-
- function Find
- (Container : E.Sequence;
- Item : Element_Type) return Count_Type
- -- Search for Item in Container
-
- with
- Global => null,
- Post =>
- (if Find'Result > 0 then
- Find'Result <= E.Length (Container)
- and Equivalent_Elements (Item, E.Get (Container, Find'Result)));
-
- function E_Elements_Included
- (Left : E.Sequence;
- Right : E.Sequence) return Boolean
- -- The elements of Left are contained in Right
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Left) =>
- Find (Right, E.Get (Left, I)) > 0
- and then E.Get (Right, Find (Right, E.Get (Left, I))) =
- E.Get (Left, I));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- function E_Elements_Included
- (Left : E.Sequence;
- Model : M.Set;
- Right : E.Sequence) return Boolean
- -- The elements of Container contained in Model are in Right
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Left) =>
- (if M.Contains (Model, E.Get (Left, I)) then
- Find (Right, E.Get (Left, I)) > 0
- and then E.Get (Right, Find (Right, E.Get (Left, I))) =
- E.Get (Left, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- function E_Elements_Included
- (Container : E.Sequence;
- Model : M.Set;
- Left : E.Sequence;
- Right : E.Sequence) return Boolean
- -- The elements of Container contained in Model are in Left and others
- -- are in Right.
-
- with
- Global => null,
- Post =>
- E_Elements_Included'Result =
- (for all I in 1 .. E.Length (Container) =>
- (if M.Contains (Model, E.Get (Container, I)) then
- Find (Left, E.Get (Container, I)) > 0
- and then E.Get (Left, Find (Left, E.Get (Container, I))) =
- E.Get (Container, I)
- else
- Find (Right, E.Get (Container, I)) > 0
- and then E.Get (Right, Find (Right, E.Get (Container, I))) =
- E.Get (Container, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included);
-
- package P is new Ada.Containers.Functional_Maps
- (Key_Type => Cursor,
- Element_Type => Positive_Count_Type,
- Equivalent_Keys => "=",
- Enable_Handling_Of_Equivalence => False);
-
- function "="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."=";
-
- function "<="
- (Left : P.Map;
- Right : P.Map) return Boolean renames P."<=";
-
- function P_Positions_Shifted
- (Small : P.Map;
- Big : P.Map;
- Cut : Positive_Count_Type;
- Count : Count_Type := 1) return Boolean
- with
- Global => null,
- Post =>
- P_Positions_Shifted'Result =
-
- -- Big contains all cursors of Small
-
- (P.Keys_Included (Small, Big)
-
- -- Cursors located before Cut are not moved, cursors located
- -- after are shifted by Count.
-
- and (for all I of Small =>
- (if P.Get (Small, I) < Cut then
- P.Get (Big, I) = P.Get (Small, I)
- else
- P.Get (Big, I) - Count = P.Get (Small, I)))
-
- -- New cursors of Big (if any) are between Cut and Cut - 1 +
- -- Count.
-
- and (for all I of Big =>
- P.Has_Key (Small, I)
- or P.Get (Big, I) - Count in Cut - Count .. Cut - 1));
-
- function Mapping_Preserved
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved'Result then
-
- -- Right contains all the cursors of Left
-
- P.Keys_Included (P_Left, P_Right)
-
- -- Right contains all the elements of Left
-
- and E_Elements_Included (E_Left, E_Right)
-
- -- Mappings from cursors to elements induced by E_Left, P_Left
- -- and E_Right, P_Right are the same.
-
- and (for all C of P_Left =>
- E.Get (E_Left, P.Get (P_Left, C)) =
- E.Get (E_Right, P.Get (P_Right, C))));
-
- function Mapping_Preserved_Except
- (E_Left : E.Sequence;
- E_Right : E.Sequence;
- P_Left : P.Map;
- P_Right : P.Map;
- Position : Cursor) return Boolean
- with
- Ghost,
- Global => null,
- Post =>
- (if Mapping_Preserved_Except'Result then
-
- -- Right contains all the cursors of Left
-
- P.Keys_Included (P_Left, P_Right)
-
- -- Mappings from cursors to elements induced by E_Left, P_Left
- -- and E_Right, P_Right are the same except for Position.
-
- and (for all C of P_Left =>
- (if C /= Position then
- E.Get (E_Left, P.Get (P_Left, C)) =
- E.Get (E_Right, P.Get (P_Right, C)))));
-
- function Model (Container : Set) return M.Set with
- -- The high-level model of a set is a set of elements. Neither cursors
- -- nor order of elements are represented in this model. Elements are
- -- modeled up to equivalence.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Big (Length (Container));
-
- function Elements (Container : Set) return E.Sequence with
- -- The Elements sequence represents the underlying list structure of
- -- sets that is used for iteration. It stores the actual values of
- -- elements in the set. It does not model cursors.
-
- Ghost,
- Global => null,
- Post =>
- E.Length (Elements'Result) = Length (Container)
-
- -- It only contains keys contained in Model
-
- and (for all Item of Elements'Result =>
- M.Contains (Model (Container), Item))
-
- -- It contains all the elements contained in Model
-
- and (for all Item of Model (Container) =>
- (Find (Elements'Result, Item) > 0
- and then Equivalent_Elements
- (E.Get (Elements'Result, Find (Elements'Result, Item)),
- Item)))
-
- -- It is sorted in increasing order
-
- and (for all I in 1 .. Length (Container) =>
- Find (Elements'Result, E.Get (Elements'Result, I)) = I
- and
- E_Is_Find
- (Elements'Result, E.Get (Elements'Result, I), I));
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements);
-
- function Positions (Container : Set) return P.Map with
- -- The Positions map is used to model cursors. It only contains valid
- -- cursors and maps them to their position in the container.
-
- Ghost,
- Global => null,
- Post =>
- not P.Has_Key (Positions'Result, No_Element)
-
- -- Positions of cursors are smaller than the container's length
-
- and then
- (for all I of Positions'Result =>
- P.Get (Positions'Result, I) in 1 .. Length (Container)
-
- -- No two cursors have the same position. Note that we do not
- -- state that there is a cursor in the map for each position, as
- -- it is rarely needed.
-
- and then
- (for all J of Positions'Result =>
- (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J)
- then I = J)));
-
- procedure Lift_Abstraction_Level (Container : Set) with
- -- Lift_Abstraction_Level is a ghost procedure that does nothing but
- -- assume that we can access the same elements by iterating over
- -- positions or cursors.
- -- This information is not generally useful except when switching from
- -- a low-level, cursor-aware view of a container, to a high-level,
- -- position-based view.
-
- Ghost,
- Global => null,
- Post =>
- (for all Item of Elements (Container) =>
- (for some I of Positions (Container) =>
- E.Get (Elements (Container), P.Get (Positions (Container), I)) =
- Item));
-
- function Contains
- (C : M.Set;
- K : Element_Type) return Boolean renames M.Contains;
- -- To improve readability of contracts, we rename the function used to
- -- search for an element in the model to Contains.
-
- end Formal_Model;
- use Formal_Model;
-
- Empty_Set : constant Set;
-
- function "=" (Left, Right : Set) return Boolean with
- Global => null,
- Post =>
-
- -- If two sets are equal, they contain the same elements in the same
- -- order.
-
- (if "="'Result then Elements (Left) = Elements (Right)
-
- -- If they are different, then they do not contain the same elements
-
- else
- not E_Elements_Included (Elements (Left), Elements (Right))
- or not E_Elements_Included (Elements (Right), Elements (Left)));
-
- function Equivalent_Sets (Left, Right : Set) return Boolean with
- Global => null,
- Post => Equivalent_Sets'Result = (Model (Left) = Model (Right));
-
- function To_Set (New_Item : Element_Type) return Set with
- Global => null,
- Post =>
- M.Is_Singleton (Model (To_Set'Result), New_Item)
- and Length (To_Set'Result) = 1
- and E.Get (Elements (To_Set'Result), 1) = New_Item;
-
- function Is_Empty (Container : Set) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out Set) with
- Global => null,
- Post => Length (Container) = 0 and M.Is_Empty (Model (Container));
-
- procedure Assign (Target : in out Set; Source : Set) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)
- and Elements (Target) = Elements (Source)
- and Length (Target) = Length (Source);
-
- function Copy (Source : Set; Capacity : Count_Type := 0) return Set with
- Global => null,
- Pre => Capacity = 0 or else Capacity >= Source.Capacity,
- Post =>
- Model (Copy'Result) = Model (Source)
- and Elements (Copy'Result) = Elements (Source)
- and Positions (Copy'Result) = Positions (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Source.Capacity
- else
- Copy'Result.Capacity = Capacity);
-
- function Element
- (Container : Set;
- Position : Cursor) return Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Element'Result =
- E.Get (Elements (Container), P.Get (Positions (Container), Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Set;
- Position : Cursor;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Position now maps to New_Item
-
- and Element (Container, Position) = New_Item
-
- -- New_Item is contained in Container
-
- and Contains (Model (Container), New_Item)
-
- -- Other elements are preserved
-
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Element (Container, Position)'Old)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- Mapping from cursors to elements is preserved
-
- and Mapping_Preserved_Except
- (E_Left => Elements (Container)'Old,
- E_Right => Elements (Container),
- P_Left => Positions (Container)'Old,
- P_Right => Positions (Container),
- Position => Position)
- and Positions (Container) = Positions (Container)'Old;
-
- function Constant_Reference
- (Container : aliased Set;
- Position : Cursor) return not null access constant Element_Type
- with
- Global => null,
- Pre => Has_Element (Container, Position),
- Post =>
- Constant_Reference'Result.all =
- E.Get (Elements (Container), P.Get (Positions (Container), Position));
-
- procedure Move (Target : in out Set; Source : in out Set) with
- Global => null,
- Pre => Target.Capacity >= Length (Source),
- Post =>
- Model (Target) = Model (Source)'Old
- and Elements (Target) = Elements (Source)'Old
- and Length (Source)'Old = Length (Target)
- and Length (Source) = 0;
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type;
- Position : out Cursor;
- Inserted : out Boolean)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- or Contains (Container, New_Item),
- Post =>
- Contains (Container, New_Item)
- and Has_Element (Container, Position)
- and Equivalent_Elements (Element (Container, Position), New_Item)
- and E_Is_Find
- (Elements (Container),
- New_Item,
- P.Get (Positions (Container), Position)),
- Contract_Cases =>
-
- -- If New_Item is already in Container, it is not modified and Inserted
- -- is set to False.
-
- (Contains (Container, New_Item) =>
- not Inserted
- and Model (Container) = Model (Container)'Old
- and Elements (Container) = Elements (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, New_Item is inserted in Container and Inserted is set to
- -- True
-
- others =>
- Inserted
- and Length (Container) = Length (Container)'Old + 1
-
- -- Position now maps to New_Item
-
- and Element (Container, Position) = New_Item
-
- -- Other elements are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- The elements of Container located before Position are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container), Position) - 1)
-
- -- Other elements are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => P.Get (Positions (Container), Position),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted at position Position in
- -- Container.
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => P.Get (Positions (Container), Position)));
-
- procedure Insert
- (Container : in out Set;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- and then (not Contains (Container, New_Item)),
- Post =>
- Length (Container) = Length (Container)'Old + 1
- and Contains (Container, New_Item)
-
- -- New_Item is inserted in the set
-
- and E.Get (Elements (Container),
- Find (Elements (Container), New_Item)) = New_Item
-
- -- Other mappings are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- The elements of Container located before New_Item are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Find (Elements (Container), New_Item) - 1)
-
- -- Other elements are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => Find (Elements (Container), New_Item),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Find (Elements (Container), New_Item));
-
- procedure Include
- (Container : in out Set;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Container.Capacity
- or Contains (Container, New_Item),
- Post => Contains (Container, New_Item),
- Contract_Cases =>
-
- -- If New_Item is already in Container
-
- (Contains (Container, New_Item) =>
-
- -- Elements are preserved
-
- Model (Container)'Old = Model (Container)
-
- -- Cursors are preserved
-
- and Positions (Container) = Positions (Container)'Old
-
- -- The element equivalent to New_Item in Container is replaced by
- -- New_Item.
-
- and E.Get (Elements (Container),
- Find (Elements (Container), New_Item)) = New_Item
-
- and E.Equal_Except
- (Elements (Container)'Old,
- Elements (Container),
- Find (Elements (Container), New_Item)),
-
- -- Otherwise, New_Item is inserted in Container
-
- others =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Other elements are preserved
-
- and Model (Container)'Old <= Model (Container)
- and M.Included_Except
- (Model (Container),
- Model (Container)'Old,
- New_Item)
-
- -- New_Item is inserted in Container
-
- and E.Get (Elements (Container),
- Find (Elements (Container), New_Item)) = New_Item
-
- -- The Elements of Container located before New_Item are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Find (Elements (Container), New_Item) - 1)
-
- -- Other Elements are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => Find (Elements (Container), New_Item),
- Lst => Length (Container)'Old,
- Offset => 1)
-
- -- A new cursor has been inserted in Container
-
- and P_Positions_Shifted
- (Positions (Container)'Old,
- Positions (Container),
- Cut => Find (Elements (Container), New_Item)));
-
- procedure Replace
- (Container : in out Set;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, New_Item),
- Post =>
-
- -- Elements are preserved
-
- Model (Container)'Old = Model (Container)
-
- -- Cursors are preserved
-
- and Positions (Container) = Positions (Container)'Old
-
- -- The element equivalent to New_Item in Container is replaced by
- -- New_Item.
-
- and E.Get (Elements (Container),
- Find (Elements (Container), New_Item)) = New_Item
- and E.Equal_Except
- (Elements (Container)'Old,
- Elements (Container),
- Find (Elements (Container), New_Item));
-
- procedure Exclude
- (Container : in out Set;
- Item : Element_Type)
- with
- Global => null,
- Post => not Contains (Container, Item),
- Contract_Cases =>
-
- -- If Item is not in Container, nothing is changed
-
- (not Contains (Container, Item) =>
- Model (Container) = Model (Container)'Old
- and Elements (Container) = Elements (Container)'Old
- and Positions (Container) = Positions (Container)'Old,
-
- -- Otherwise, Item is removed from Container
-
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Item)
-
- -- The elements of Container located before Item are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Find (Elements (Container), Item)'Old - 1)
-
- -- The elements located after Item are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container),
- Right => Elements (Container)'Old,
- Fst => Find (Elements (Container), Item)'Old,
- Lst => Length (Container),
- Offset => 1)
-
- -- A cursor has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Find (Elements (Container), Item)'Old));
-
- procedure Delete
- (Container : in out Set;
- Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, Item),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Item is no longer in Container
-
- and not Contains (Container, Item)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Item)
-
- -- The elements of Container located before Item are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Find (Elements (Container), Item)'Old - 1)
-
- -- The elements located after Item are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container),
- Right => Elements (Container)'Old,
- Fst => Find (Elements (Container), Item)'Old,
- Lst => Length (Container),
- Offset => 1)
-
- -- A cursor has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => Find (Elements (Container), Item)'Old);
-
- procedure Delete
- (Container : in out Set;
- Position : in out Cursor)
- with
- Global => null,
- Depends => (Container =>+ Position, Position => null),
- Pre => Has_Element (Container, Position),
- Post =>
- Position = No_Element
- and Length (Container) = Length (Container)'Old - 1
-
- -- The element at position Position is no longer in Container
-
- and not Contains (Container, Element (Container, Position)'Old)
- and not P.Has_Key (Positions (Container), Position'Old)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Element (Container, Position)'Old)
-
- -- The elements of Container located before Position are preserved.
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => P.Get (Positions (Container)'Old, Position'Old) - 1)
-
- -- The elements located after Position are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container),
- Right => Elements (Container)'Old,
- Fst => P.Get (Positions (Container)'Old, Position'Old),
- Lst => Length (Container),
- Offset => 1)
-
- -- Position has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => P.Get (Positions (Container)'Old, Position'Old));
-
- procedure Delete_First (Container : in out Set) with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 => Length (Container) = 0,
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The first element has been removed from Container
-
- and not Contains (Container, First_Element (Container)'Old)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- First_Element (Container)'Old)
-
- -- Other elements are shifted by 1
-
- and E.Range_Shifted
- (Left => Elements (Container),
- Right => Elements (Container)'Old,
- Fst => 1,
- Lst => Length (Container),
- Offset => 1)
-
- -- First has been removed from Container
-
- and P_Positions_Shifted
- (Positions (Container),
- Positions (Container)'Old,
- Cut => 1));
-
- procedure Delete_Last (Container : in out Set) with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 => Length (Container) = 0,
- others =>
- Length (Container) = Length (Container)'Old - 1
-
- -- The last element has been removed from Container
-
- and not Contains (Container, Last_Element (Container)'Old)
-
- -- Other elements are preserved
-
- and Model (Container) <= Model (Container)'Old
- and M.Included_Except
- (Model (Container)'Old,
- Model (Container),
- Last_Element (Container)'Old)
-
- -- Others elements of Container are preserved
-
- and E.Range_Equal
- (Left => Elements (Container)'Old,
- Right => Elements (Container),
- Fst => 1,
- Lst => Length (Container))
-
- -- Last cursor has been removed from Container
-
- and Positions (Container) <= Positions (Container)'Old);
-
- procedure Union (Target : in out Set; Source : Set) with
- Global => null,
- Pre =>
- Length (Source) - Length (Target and Source) <=
- Target.Capacity - Length (Target),
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old)
- - M.Num_Overlaps (Model (Target)'Old, Model (Source))
- + Big (Length (Source))
-
- -- Elements already in Target are still in Target
-
- and Model (Target)'Old <= Model (Target)
-
- -- Elements of Source are included in Target
-
- and Model (Source) <= Model (Target)
-
- -- Elements of Target come from either Source or Target
-
- and
- M.Included_In_Union
- (Model (Target), Model (Source), Model (Target)'Old)
-
- -- Actual value of elements come from either Left or Right
-
- and
- E_Elements_Included
- (Elements (Target),
- Model (Target)'Old,
- Elements (Target)'Old,
- Elements (Source))
- and
- E_Elements_Included
- (Elements (Target)'Old, Model (Target)'Old, Elements (Target))
- and
- E_Elements_Included
- (Elements (Source),
- Model (Target)'Old,
- Elements (Source),
- Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target)'Old,
- E_Right => Elements (Target),
- P_Left => Positions (Target)'Old,
- P_Right => Positions (Target));
-
- function Union (Left, Right : Set) return Set with
- Global => null,
- Pre => Length (Left) <= Count_Type'Last - Length (Right),
- Post =>
- Big (Length (Union'Result)) = Big (Length (Left))
- - M.Num_Overlaps (Model (Left), Model (Right))
- + Big (Length (Right))
-
- -- Elements of Left and Right are in the result of Union
-
- and Model (Left) <= Model (Union'Result)
- and Model (Right) <= Model (Union'Result)
-
- -- Elements of the result of union come from either Left or Right
-
- and
- M.Included_In_Union
- (Model (Union'Result), Model (Left), Model (Right))
-
- -- Actual value of elements come from either Left or Right
-
- and
- E_Elements_Included
- (Elements (Union'Result),
- Model (Left),
- Elements (Left),
- Elements (Right))
- and
- E_Elements_Included
- (Elements (Left), Model (Left), Elements (Union'Result))
- and
- E_Elements_Included
- (Elements (Right),
- Model (Left),
- Elements (Right),
- Elements (Union'Result));
-
- function "or" (Left, Right : Set) return Set renames Union;
-
- procedure Intersection (Target : in out Set; Source : Set) with
- Global => null,
- Post =>
- Big (Length (Target)) =
- M.Num_Overlaps (Model (Target)'Old, Model (Source))
-
- -- Elements of Target were already in Target
-
- and Model (Target) <= Model (Target)'Old
-
- -- Elements of Target are in Source
-
- and Model (Target) <= Model (Source)
-
- -- Elements both in Source and Target are in the intersection
-
- and
- M.Includes_Intersection
- (Model (Target), Model (Source), Model (Target)'Old)
-
- -- Actual value of elements of Target is preserved
-
- and E_Elements_Included (Elements (Target), Elements (Target)'Old)
- and
- E_Elements_Included
- (Elements (Target)'Old, Model (Source), Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target),
- E_Right => Elements (Target)'Old,
- P_Left => Positions (Target),
- P_Right => Positions (Target)'Old);
-
- function Intersection (Left, Right : Set) return Set with
- Global => null,
- Post =>
- Big (Length (Intersection'Result)) =
- M.Num_Overlaps (Model (Left), Model (Right))
-
- -- Elements in the result of Intersection are in Left and Right
-
- and Model (Intersection'Result) <= Model (Left)
- and Model (Intersection'Result) <= Model (Right)
-
- -- Elements both in Left and Right are in the result of Intersection
-
- and
- M.Includes_Intersection
- (Model (Intersection'Result), Model (Left), Model (Right))
-
- -- Actual value of elements come from Left
-
- and
- E_Elements_Included
- (Elements (Intersection'Result), Elements (Left))
- and
- E_Elements_Included
- (Elements (Left), Model (Right), Elements (Intersection'Result));
-
- function "and" (Left, Right : Set) return Set renames Intersection;
-
- procedure Difference (Target : in out Set; Source : Set) with
- Global => null,
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old) -
- M.Num_Overlaps (Model (Target)'Old, Model (Source))
-
- -- Elements of Target were already in Target
-
- and Model (Target) <= Model (Target)'Old
-
- -- Elements of Target are not in Source
-
- and M.No_Overlap (Model (Target), Model (Source))
-
- -- Elements in Target but not in Source are in the difference
-
- and
- M.Included_In_Union
- (Model (Target)'Old, Model (Target), Model (Source))
-
- -- Actual value of elements of Target is preserved
-
- and E_Elements_Included (Elements (Target), Elements (Target)'Old)
- and
- E_Elements_Included
- (Elements (Target)'Old, Model (Target), Elements (Target))
-
- -- Mapping from cursors of Target to elements is preserved
-
- and Mapping_Preserved
- (E_Left => Elements (Target),
- E_Right => Elements (Target)'Old,
- P_Left => Positions (Target),
- P_Right => Positions (Target)'Old);
-
- function Difference (Left, Right : Set) return Set with
- Global => null,
- Post =>
- Big (Length (Difference'Result)) = Big (Length (Left)) -
- M.Num_Overlaps (Model (Left), Model (Right))
-
- -- Elements of the result of Difference are in Left
-
- and Model (Difference'Result) <= Model (Left)
-
- -- Elements of the result of Difference are in Right
-
- and M.No_Overlap (Model (Difference'Result), Model (Right))
-
- -- Elements in Left but not in Right are in the difference
-
- and
- M.Included_In_Union
- (Model (Left), Model (Difference'Result), Model (Right))
-
- -- Actual value of elements come from Left
-
- and
- E_Elements_Included (Elements (Difference'Result), Elements (Left))
- and
- E_Elements_Included
- (Elements (Left),
- Model (Difference'Result),
- Elements (Difference'Result));
-
- function "-" (Left, Right : Set) return Set renames Difference;
-
- procedure Symmetric_Difference (Target : in out Set; Source : Set) with
- Global => null,
- Pre =>
- Length (Source) - Length (Target and Source) <=
- Target.Capacity - Length (Target) + Length (Target and Source),
- Post =>
- Big (Length (Target)) = Big (Length (Target)'Old) -
- 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) +
- Big (Length (Source))
-
- -- Elements of the difference were not both in Source and in Target
-
- and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source))
-
- -- Elements in Target but not in Source are in the difference
-
- and
- M.Included_In_Union
- (Model (Target)'Old, Model (Target), Model (Source))
-
- -- Elements in Source but not in Target are in the difference
-
- and
- M.Included_In_Union
- (Model (Source), Model (Target), Model (Target)'Old)
-
- -- Actual value of elements come from either Left or Right
-
- and
- E_Elements_Included
- (Elements (Target),
- Model (Target)'Old,
- Elements (Target)'Old,
- Elements (Source))
- and
- E_Elements_Included
- (Elements (Target)'Old, Model (Target), Elements (Target))
- and
- E_Elements_Included
- (Elements (Source), Model (Target), Elements (Target));
-
- function Symmetric_Difference (Left, Right : Set) return Set with
- Global => null,
- Pre => Length (Left) <= Count_Type'Last - Length (Right),
- Post =>
- Big (Length (Symmetric_Difference'Result)) = Big (Length (Left)) -
- 2 * M.Num_Overlaps (Model (Left), Model (Right)) +
- Big (Length (Right))
-
- -- Elements of the difference were not both in Left and Right
-
- and
- M.Not_In_Both
- (Model (Symmetric_Difference'Result), Model (Left), Model (Right))
-
- -- Elements in Left but not in Right are in the difference
-
- and
- M.Included_In_Union
- (Model (Left), Model (Symmetric_Difference'Result), Model (Right))
-
- -- Elements in Right but not in Left are in the difference
-
- and
- M.Included_In_Union
- (Model (Right), Model (Symmetric_Difference'Result), Model (Left))
-
- -- Actual value of elements come from either Left or Right
-
- and
- E_Elements_Included
- (Elements (Symmetric_Difference'Result),
- Model (Left),
- Elements (Left),
- Elements (Right))
- and
- E_Elements_Included
- (Elements (Left),
- Model (Symmetric_Difference'Result),
- Elements (Symmetric_Difference'Result))
- and
- E_Elements_Included
- (Elements (Right),
- Model (Symmetric_Difference'Result),
- Elements (Symmetric_Difference'Result));
-
- function "xor" (Left, Right : Set) return Set
- renames Symmetric_Difference;
-
- function Overlap (Left, Right : Set) return Boolean with
- Global => null,
- Post =>
- Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right)));
-
- function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with
- Global => null,
- Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set));
-
- function First (Container : Set) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- First'Result = No_Element,
-
- others =>
- Has_Element (Container, First'Result)
- and P.Get (Positions (Container), First'Result) = 1);
-
- function First_Element (Container : Set) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- First_Element'Result = E.Get (Elements (Container), 1)
- and E_Smaller_Than_Range
- (Elements (Container),
- 2,
- Length (Container),
- First_Element'Result);
-
- function Last (Container : Set) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 =>
- Last'Result = No_Element,
-
- others =>
- Has_Element (Container, Last'Result)
- and P.Get (Positions (Container), Last'Result) =
- Length (Container));
-
- function Last_Element (Container : Set) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result = E.Get (Elements (Container), Length (Container))
- and E_Bigger_Than_Range
- (Elements (Container),
- 1,
- Length (Container) - 1,
- Last_Element'Result);
-
- function Next (Container : Set; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Next'Result = No_Element,
-
- others =>
- Has_Element (Container, Next'Result)
- and then P.Get (Positions (Container), Next'Result) =
- P.Get (Positions (Container), Position) + 1);
-
- procedure Next (Container : Set; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = Length (Container)
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) + 1);
-
- function Previous (Container : Set; Position : Cursor) return Cursor with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Previous'Result = No_Element,
-
- others =>
- Has_Element (Container, Previous'Result)
- and then P.Get (Positions (Container), Previous'Result) =
- P.Get (Positions (Container), Position) - 1);
-
- procedure Previous (Container : Set; Position : in out Cursor) with
- Global => null,
- Pre =>
- Has_Element (Container, Position) or else Position = No_Element,
- Contract_Cases =>
- (Position = No_Element
- or else P.Get (Positions (Container), Position) = 1
- =>
- Position = No_Element,
-
- others =>
- Has_Element (Container, Position)
- and then P.Get (Positions (Container), Position) =
- P.Get (Positions (Container), Position'Old) - 1);
-
- function Find (Container : Set; Item : Element_Type) return Cursor with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container, Find returns No_Element
-
- (not Contains (Model (Container), Item) =>
- not P.Has_Key (Positions (Container), Find'Result)
- and Find'Result = No_Element,
-
- -- Otherwise, Find returns a valid cursor in Container
-
- others =>
- P.Has_Key (Positions (Container), Find'Result)
- and P.Get (Positions (Container), Find'Result) =
- Find (Elements (Container), Item)
-
- -- The element designated by the result of Find is Item
-
- and Equivalent_Elements
- (Element (Container, Find'Result), Item));
-
- function Floor (Container : Set; Item : Element_Type) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 or else Item < First_Element (Container) =>
- Floor'Result = No_Element,
- others =>
- Has_Element (Container, Floor'Result)
- and
- not (Item < E.Get (Elements (Container),
- P.Get (Positions (Container), Floor'Result)))
- and E_Is_Find
- (Elements (Container),
- Item,
- P.Get (Positions (Container), Floor'Result)));
-
- function Ceiling (Container : Set; Item : Element_Type) return Cursor with
- Global => null,
- Contract_Cases =>
- (Length (Container) = 0 or else Last_Element (Container) < Item =>
- Ceiling'Result = No_Element,
- others =>
- Has_Element (Container, Ceiling'Result)
- and
- not (E.Get (Elements (Container),
- P.Get (Positions (Container), Ceiling'Result)) <
- Item)
- and E_Is_Find
- (Elements (Container),
- Item,
- P.Get (Positions (Container), Ceiling'Result)));
-
- function Contains (Container : Set; Item : Element_Type) return Boolean with
- Global => null,
- Post => Contains'Result = Contains (Model (Container), Item);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Has_Element (Container : Set; Position : Cursor) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result = P.Has_Key (Positions (Container), Position);
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- generic
- type Key_Type (<>) is private;
-
- with function Key (Element : Element_Type) return Key_Type;
-
- with function "<" (Left, Right : Key_Type) return Boolean is <>;
-
- package Generic_Keys with SPARK_Mode is
-
- function Equivalent_Keys (Left, Right : Key_Type) return Boolean with
- Global => null,
- Post =>
- Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left));
- pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys);
-
- package Formal_Model with Ghost is
- function E_Bigger_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= E.Length (Container),
- Post =>
- E_Bigger_Than_Range'Result =
- (for all I in Fst .. Lst =>
- Generic_Keys.Key (E.Get (Container, I)) < Key);
- pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range);
-
- function E_Smaller_Than_Range
- (Container : E.Sequence;
- Fst : Positive_Count_Type;
- Lst : Count_Type;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Pre => Lst <= E.Length (Container),
- Post =>
- E_Smaller_Than_Range'Result =
- (for all I in Fst .. Lst =>
- Key < Generic_Keys.Key (E.Get (Container, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range);
-
- function E_Is_Find
- (Container : E.Sequence;
- Key : Key_Type;
- Position : Count_Type) return Boolean
- with
- Global => null,
- Pre => Position - 1 <= E.Length (Container),
- Post =>
- E_Is_Find'Result =
-
- ((if Position > 0 then
- E_Bigger_Than_Range (Container, 1, Position - 1, Key))
-
- and (if Position < E.Length (Container) then
- E_Smaller_Than_Range
- (Container,
- Position + 1,
- E.Length (Container),
- Key)));
- pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find);
-
- function Find
- (Container : E.Sequence;
- Key : Key_Type) return Count_Type
- -- Search for Key in Container
-
- with
- Global => null,
- Post =>
- (if Find'Result > 0 then
- Find'Result <= E.Length (Container)
- and Equivalent_Keys
- (Key, Generic_Keys.Key (E.Get (Container, Find'Result)))
- and E_Is_Find (Container, Key, Find'Result));
-
- function M_Included_Except
- (Left : M.Set;
- Right : M.Set;
- Key : Key_Type) return Boolean
- with
- Global => null,
- Post =>
- M_Included_Except'Result =
- (for all E of Left =>
- Contains (Right, E)
- or Equivalent_Keys (Generic_Keys.Key (E), Key));
- end Formal_Model;
- use Formal_Model;
-
- function Key (Container : Set; Position : Cursor) return Key_Type with
- Global => null,
- Post => Key'Result = Key (Element (Container, Position));
- pragma Annotate (GNATprove, Inline_For_Proof, Key);
-
- function Element (Container : Set; Key : Key_Type) return Element_Type
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Element'Result = Element (Container, Find (Container, Key));
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace
- (Container : in out Set;
- Key : Key_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Contains (Container, Key),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Key now maps to New_Item
-
- and Element (Container, 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;
+package Ada.Containers.Formal_Ordered_Sets with SPARK_Mode is
- Empty_Set : constant Set := (Capacity => 0, others => <>);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Ordered_Sets;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2010-2022, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Generic_Array_Sort;
-
-with System; use type System.Address;
-
-package body Ada.Containers.Formal_Vectors with
- SPARK_Mode => Off
-is
-
- subtype Int is Long_Long_Integer;
-
- function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base;
-
- procedure Insert_Space
- (Container : in out Vector;
- Before : Extended_Index;
- Count : Count_Type := 1);
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Vector; Right : Vector) return Boolean is
- begin
- if Left'Address = Right'Address then
- return True;
- end if;
-
- if Length (Left) /= Length (Right) then
- return False;
- end if;
-
- for J in 1 .. Length (Left) loop
- if Left.Elements (J) /= Right.Elements (J) then
- return False;
- end if;
- end loop;
-
- return True;
- end "=";
-
- ------------
- -- Append --
- ------------
-
- procedure Append (Container : in out Vector; New_Item : Vector) is
- begin
- if Is_Empty (New_Item) then
- return;
- end if;
-
- if Container.Last >= Index_Type'Last then
- raise Constraint_Error with "vector is already at its maximum length";
- end if;
-
- Insert (Container, Container.Last + 1, New_Item);
- end Append;
-
- procedure Append (Container : in out Vector; New_Item : Element_Type) is
- begin
- Append (Container, New_Item, 1);
- end Append;
-
- procedure Append
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- if Count = 0 then
- return;
- end if;
-
- if Container.Last >= Index_Type'Last then
- raise Constraint_Error with "vector is already at its maximum length";
- end if;
-
- Insert (Container, Container.Last + 1, New_Item, Count);
- end Append;
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out Vector; Source : Vector) is
- LS : constant Capacity_Range := Length (Source);
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < LS then
- raise Constraint_Error;
- end if;
-
- Clear (Target);
- Append (Target, Source);
- end Assign;
-
- --------------
- -- Capacity --
- --------------
-
- function Capacity (Container : Vector) return Capacity_Range is
- begin
- return Container.Capacity;
- end Capacity;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Vector) is
- begin
- Container.Last := No_Index;
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Vector;
- Index : Index_Type) return not null access constant Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- return Container.Elements (To_Array_Index (Index))'Access;
- end Constant_Reference;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Vector;
- Item : Element_Type) return Boolean
- is
- begin
- return Find_Index (Container, Item) /= No_Index;
- end Contains;
-
- ----------
- -- Copy --
- ----------
-
- function Copy
- (Source : Vector;
- Capacity : Capacity_Range := 0) return Vector
- is
- LS : constant Capacity_Range := Length (Source);
- C : Capacity_Range;
-
- begin
- if Capacity = 0 then
- C := LS;
- elsif Capacity >= LS then
- C := Capacity;
- else
- raise Capacity_Error with "Capacity too small";
- end if;
-
- return Target : Vector (C) do
- Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
- Target.Last := Source.Last;
- end return;
- end Copy;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (Container : in out Vector; Index : Extended_Index) is
- begin
- Delete (Container, Index, 1);
- end Delete;
-
- procedure Delete
- (Container : in out Vector;
- Index : Extended_Index;
- Count : Count_Type)
- is
- Old_Last : constant Index_Type'Base := Container.Last;
- Old_Len : constant Count_Type := Length (Container);
- New_Last : Index_Type'Base;
- Count2 : Count_Type'Base; -- count of items from Index to Old_Last
- Off : Count_Type'Base; -- Index expressed as offset from IT'First
-
- begin
- -- Delete removes items from the vector, the number of which is the
- -- minimum of the specified Count and the items (if any) that exist from
- -- Index to Container.Last. There are no constraints on the specified
- -- value of Count (it can be larger than what's available at this
- -- position in the vector, for example), but there are constraints on
- -- the allowed values of the Index.
-
- -- As a precondition on the generic actual Index_Type, the base type
- -- must include Index_Type'Pred (Index_Type'First); this is the value
- -- that Container.Last assumes when the vector is empty. However, we do
- -- not allow that as the value for Index when specifying which items
- -- should be deleted, so we must manually check. (That the user is
- -- allowed to specify the value at all here is a consequence of the
- -- declaration of the Extended_Index subtype, which includes the values
- -- in the base range that immediately precede and immediately follow the
- -- values in the Index_Type.)
-
- if Index < Index_Type'First then
- raise Constraint_Error with "Index is out of range (too small)";
- end if;
-
- -- We do allow a value greater than Container.Last to be specified as
- -- the Index, but only if it's immediately greater. This allows the
- -- corner case of deleting no items from the back end of the vector to
- -- be treated as a no-op. (It is assumed that specifying an index value
- -- greater than Last + 1 indicates some deeper flaw in the caller's
- -- algorithm, so that case is treated as a proper error.)
-
- if Index > Old_Last then
- if Index > Old_Last + 1 then
- raise Constraint_Error with "Index is out of range (too large)";
- end if;
-
- return;
- end if;
-
- if Count = 0 then
- return;
- end if;
-
- -- We first calculate what's available for deletion starting at
- -- Index. Here and elsewhere we use the wider of Index_Type'Base and
- -- Count_Type'Base as the type for intermediate values. (See function
- -- Length for more information.)
-
- if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
- Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
- else
- Count2 := Count_Type'Base (Old_Last - Index + 1);
- end if;
-
- -- If more elements are requested (Count) for deletion than are
- -- available (Count2) for deletion beginning at Index, then everything
- -- from Index is deleted. There are no elements to slide down, and so
- -- all we need to do is set the value of Container.Last.
-
- if Count >= Count2 then
- Container.Last := Index - 1;
- return;
- end if;
-
- -- There are some elements aren't being deleted (the requested count was
- -- less than the available count), so we must slide them down to Index.
- -- We first calculate the index values of the respective array slices,
- -- using the wider of Index_Type'Base and Count_Type'Base as the type
- -- for intermediate calculations.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Off := Count_Type'Base (Index - Index_Type'First);
- New_Last := Old_Last - Index_Type'Base (Count);
- else
- Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
- New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
- end if;
-
- -- The array index values for each slice have already been determined,
- -- so we just slide down to Index the elements that weren't deleted.
-
- declare
- EA : Elements_Array renames Container.Elements;
- Idx : constant Count_Type := EA'First + Off;
- begin
- EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
- Container.Last := New_Last;
- end;
- end Delete;
-
- ------------------
- -- Delete_First --
- ------------------
-
- procedure Delete_First (Container : in out Vector) is
- begin
- Delete_First (Container, 1);
- end Delete_First;
-
- procedure Delete_First (Container : in out Vector; Count : Count_Type) is
- begin
- if Count = 0 then
- return;
-
- elsif Count >= Length (Container) then
- Clear (Container);
- return;
-
- else
- Delete (Container, Index_Type'First, Count);
- end if;
- end Delete_First;
-
- -----------------
- -- Delete_Last --
- -----------------
-
- procedure Delete_Last (Container : in out Vector) is
- begin
- Delete_Last (Container, 1);
- end Delete_Last;
-
- procedure Delete_Last (Container : in out Vector; Count : Count_Type) is
- begin
- if Count = 0 then
- return;
- end if;
-
- -- There is no restriction on how large Count can be when deleting
- -- items. If it is equal or greater than the current length, then this
- -- is equivalent to clearing the vector. (In particular, there's no need
- -- for us to actually calculate the new value for Last.)
-
- -- If the requested count is less than the current length, then we must
- -- calculate the new value for Last. For the type we use the widest of
- -- Index_Type'Base and Count_Type'Base for the intermediate values of
- -- our calculation. (See the comments in Length for more information.)
-
- if Count >= Length (Container) then
- Container.Last := No_Index;
-
- elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Container.Last := Container.Last - Index_Type'Base (Count);
-
- else
- Container.Last :=
- Index_Type'Base (Count_Type'Base (Container.Last) - Count);
- end if;
- end Delete_Last;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Container : Vector;
- Index : Extended_Index) return Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
- begin
- return Container.Elements (I);
- end;
- end Element;
-
- ----------------
- -- Find_Index --
- ----------------
-
- function Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'First) return Extended_Index
- is
- K : Count_Type;
- Last : constant Extended_Index := Last_Index (Container);
-
- begin
- K := Capacity_Range (Int (Index) - Int (No_Index));
- for Indx in Index .. Last loop
- if Container.Elements (K) = Item then
- return Indx;
- end if;
-
- K := K + 1;
- end loop;
-
- return No_Index;
- end Find_Index;
-
- -------------------
- -- First_Element --
- -------------------
-
- function First_Element (Container : Vector) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "Container is empty";
- else
- return Container.Elements (1);
- end if;
- end First_Element;
-
- -----------------
- -- First_Index --
- -----------------
-
- function First_Index (Container : Vector) return Index_Type is
- pragma Unreferenced (Container);
- begin
- return Index_Type'First;
- end First_Index;
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -------------------------
- -- M_Elements_In_Union --
- -------------------------
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- Elem : Element_Type;
-
- begin
- for Index in Index_Type'First .. M.Last (Container) loop
- Elem := Element (Container, Index);
-
- if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem)
- and then
- not M.Contains (Right, Index_Type'First, M.Last (Right), Elem)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_In_Union;
-
- -------------------------
- -- M_Elements_Included --
- -------------------------
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Index_Type := Index_Type'First;
- L_Lst : Extended_Index;
- Right : M.Sequence;
- R_Fst : Index_Type := Index_Type'First;
- R_Lst : Extended_Index) return Boolean
- is
- begin
- for I in L_Fst .. L_Lst loop
- declare
- Found : Boolean := False;
- J : Extended_Index := R_Fst - 1;
-
- begin
- while not Found and J < R_Lst loop
- J := J + 1;
- if Element (Left, I) = Element (Right, J) then
- Found := True;
- end if;
- end loop;
-
- if not Found then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end M_Elements_Included;
-
- -------------------------
- -- M_Elements_Reversed --
- -------------------------
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- is
- L : constant Index_Type := M.Last (Left);
-
- begin
- if L /= M.Last (Right) then
- return False;
- end if;
-
- for I in Index_Type'First .. L loop
- if Element (Left, I) /= Element (Right, L - I + 1)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Reversed;
-
- ------------------------
- -- M_Elements_Swapped --
- ------------------------
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- is
- begin
- if M.Length (Left) /= M.Length (Right)
- or else Element (Left, X) /= Element (Right, Y)
- or else Element (Left, Y) /= Element (Right, X)
- then
- return False;
- end if;
-
- for I in Index_Type'First .. M.Last (Left) loop
- if I /= X and then I /= Y
- and then Element (Left, I) /= Element (Right, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end M_Elements_Swapped;
-
- -----------
- -- Model --
- -----------
-
- function Model (Container : Vector) return M.Sequence is
- R : M.Sequence;
-
- begin
- for Position in 1 .. Length (Container) loop
- R := M.Add (R, Container.Elements (Position));
- end loop;
-
- return R;
- end Model;
-
- end Formal_Model;
-
- ---------------------
- -- Generic_Sorting --
- ---------------------
-
- package body Generic_Sorting with SPARK_Mode => Off is
-
- ------------------
- -- Formal_Model --
- ------------------
-
- package body Formal_Model is
-
- -----------------------
- -- M_Elements_Sorted --
- -----------------------
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean is
- begin
- if M.Length (Container) = 0 then
- return True;
- end if;
-
- declare
- E1 : Element_Type := Element (Container, Index_Type'First);
-
- begin
- for I in Index_Type'First + 1 .. M.Last (Container) loop
- declare
- E2 : constant Element_Type := Element (Container, I);
-
- begin
- if E2 < E1 then
- return False;
- end if;
-
- E1 := E2;
- end;
- end loop;
- end;
-
- return True;
- end M_Elements_Sorted;
-
- end Formal_Model;
-
- ---------------
- -- Is_Sorted --
- ---------------
-
- function Is_Sorted (Container : Vector) return Boolean is
- L : constant Capacity_Range := Length (Container);
-
- begin
- for J in 1 .. L - 1 loop
- if Container.Elements (J + 1) <
- Container.Elements (J)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Is_Sorted;
-
- ----------
- -- Sort --
- ----------
-
- procedure Sort (Container : in out Vector) is
- procedure Sort is
- new Generic_Array_Sort
- (Index_Type => Array_Index,
- Element_Type => Element_Type,
- Array_Type => Elements_Array,
- "<" => "<");
-
- Len : constant Capacity_Range := Length (Container);
-
- begin
- if Container.Last <= Index_Type'First then
- return;
- else
- Sort (Container.Elements (1 .. Len));
- end if;
- end Sort;
-
- -----------
- -- Merge --
- -----------
-
- procedure Merge (Target : in out Vector; Source : in out Vector) is
- I : Count_Type;
- J : Count_Type;
-
- begin
- if Target'Address = Source'Address then
- raise Program_Error with "Target and Source denote same container";
- end if;
-
- if Length (Source) = 0 then
- return;
- end if;
-
- if Length (Target) = 0 then
- Move (Target => Target, Source => Source);
- return;
- end if;
-
- I := Length (Target);
-
- declare
- New_Length : constant Count_Type := I + Length (Source);
-
- begin
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Target.Last := No_Index + Index_Type'Base (New_Length);
-
- else
- Target.Last :=
- Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
- end if;
- end;
-
- declare
- TA : Elements_Array renames Target.Elements;
- SA : Elements_Array renames Source.Elements;
-
- begin
- J := Length (Target);
- while Length (Source) /= 0 loop
- if I = 0 then
- TA (1 .. J) := SA (1 .. Length (Source));
- Source.Last := No_Index;
- exit;
- end if;
-
- if SA (Length (Source)) < TA (I) then
- TA (J) := TA (I);
- I := I - 1;
-
- else
- TA (J) := SA (Length (Source));
- Source.Last := Source.Last - 1;
- end if;
-
- J := J - 1;
- end loop;
- end;
- end Merge;
-
- end Generic_Sorting;
-
- -----------------
- -- Has_Element --
- -----------------
-
- function Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- is
- begin
- return Position in First_Index (Container) .. Last_Index (Container);
- end Has_Element;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type)
- is
- begin
- Insert (Container, Before, New_Item, 1);
- end Insert;
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- J : Count_Type'Base; -- scratch
-
- begin
- -- Use Insert_Space to create the "hole" (the destination slice)
-
- Insert_Space (Container, Before, Count);
-
- J := To_Array_Index (Before);
-
- Container.Elements (J .. J - 1 + Count) := [others => New_Item];
- end Insert;
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Vector)
- is
- N : constant Count_Type := Length (New_Item);
- B : Count_Type; -- index Before converted to Count_Type
-
- begin
- if Container'Address = New_Item'Address then
- raise Program_Error with
- "Container and New_Item denote same container";
- end if;
-
- -- Use Insert_Space to create the "hole" (the destination slice) into
- -- which we copy the source items.
-
- Insert_Space (Container, Before, Count => N);
-
- if N = 0 then
-
- -- There's nothing else to do here (vetting of parameters was
- -- performed already in Insert_Space), so we simply return.
-
- return;
- end if;
-
- B := To_Array_Index (Before);
-
- Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N);
- end Insert;
-
- ------------------
- -- Insert_Space --
- ------------------
-
- procedure Insert_Space
- (Container : in out Vector;
- Before : Extended_Index;
- Count : Count_Type := 1)
- is
- Old_Length : constant Count_Type := Length (Container);
-
- Max_Length : Count_Type'Base; -- determined from range of Index_Type
- New_Length : Count_Type'Base; -- sum of current length and Count
-
- Index : Index_Type'Base; -- scratch for intermediate values
- J : Count_Type'Base; -- scratch
-
- begin
- -- As a precondition on the generic actual Index_Type, the base type
- -- must include Index_Type'Pred (Index_Type'First); this is the value
- -- that Container.Last assumes when the vector is empty. However, we do
- -- not allow that as the value for Index when specifying where the new
- -- items should be inserted, so we must manually check. (That the user
- -- is allowed to specify the value at all here is a consequence of the
- -- declaration of the Extended_Index subtype, which includes the values
- -- in the base range that immediately precede and immediately follow the
- -- values in the Index_Type.)
-
- if Before < Index_Type'First then
- raise Constraint_Error with
- "Before index is out of range (too small)";
- end if;
-
- -- We do allow a value greater than Container.Last to be specified as
- -- the Index, but only if it's immediately greater. This allows for the
- -- case of appending items to the back end of the vector. (It is assumed
- -- that specifying an index value greater than Last + 1 indicates some
- -- deeper flaw in the caller's algorithm, so that case is treated as a
- -- proper error.)
-
- if Before > Container.Last
- and then Before - 1 > Container.Last
- then
- raise Constraint_Error with
- "Before index is out of range (too large)";
- end if;
-
- -- We treat inserting 0 items into the container as a no-op, so we
- -- simply return.
-
- if Count = 0 then
- return;
- end if;
-
- -- There are two constraints we need to satisfy. The first constraint is
- -- that a container cannot have more than Count_Type'Last elements, so
- -- we must check the sum of the current length and the insertion count.
- -- Note that the value cannot be simply added because the result may
- -- overflow.
-
- if Old_Length > Count_Type'Last - Count then
- raise Constraint_Error with "Count is out of range";
- end if;
-
- -- It is now safe compute the length of the new vector, without fear of
- -- overflow.
-
- New_Length := Old_Length + Count;
-
- -- The second constraint is that the new Last index value cannot exceed
- -- Index_Type'Last. In each branch below, we calculate the maximum
- -- length (computed from the range of values in Index_Type), and then
- -- compare the new length to the maximum length. If the new length is
- -- acceptable, then we compute the new last index from that.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-
- -- We have to handle the case when there might be more values in the
- -- range of Index_Type than in the range of Count_Type.
-
- if Index_Type'First <= 0 then
-
- -- We know that No_Index (the same as Index_Type'First - 1) is
- -- less than 0, so it is safe to compute the following sum without
- -- fear of overflow.
-
- Index := No_Index + Index_Type'Base (Count_Type'Last);
-
- if Index <= Index_Type'Last then
-
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the
- -- maximum number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than in Count_Type,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
- end if;
-
- else
- -- No_Index is equal or greater than 0, so we can safely compute
- -- the difference without fear of overflow (which we would have to
- -- worry about if No_Index were less than 0, but that case is
- -- handled above).
-
- if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last)
- then
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the
- -- maximum number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than in Count_Type,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
- end if;
- end if;
-
- elsif Index_Type'First <= 0 then
-
- -- We know that No_Index (the same as Index_Type'First - 1) is less
- -- than 0, so it is safe to compute the following sum without fear of
- -- overflow.
-
- J := Count_Type'Base (No_Index) + Count_Type'Last;
-
- if J <= Count_Type'Base (Index_Type'Last) then
-
- -- We have determined that range of Index_Type has at least as
- -- many values as in Count_Type, so Count_Type'Last is the maximum
- -- number of items that are allowed.
-
- Max_Length := Count_Type'Last;
-
- else
- -- The range of Index_Type has fewer values than Count_Type does,
- -- so the maximum number of items is computed from the range of
- -- the Index_Type.
-
- Max_Length :=
- Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
- end if;
-
- else
- -- No_Index is equal or greater than 0, so we can safely compute the
- -- difference without fear of overflow (which we would have to worry
- -- about if No_Index were less than 0, but that case is handled
- -- above).
-
- Max_Length :=
- Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
- end if;
-
- -- We have just computed the maximum length (number of items). We must
- -- now compare the requested length to the maximum length, as we do not
- -- allow a vector expand beyond the maximum (because that would create
- -- an internal array with a last index value greater than
- -- Index_Type'Last, with no way to index those elements).
-
- if New_Length > Max_Length then
- raise Constraint_Error with "Count is out of range";
-
- -- Raise Capacity_Error if the new length exceeds the container's
- -- capacity.
-
- elsif New_Length > Container.Capacity then
- raise Capacity_Error with "New length is larger than capacity";
- end if;
-
- J := To_Array_Index (Before);
-
- declare
- EA : Elements_Array renames Container.Elements;
-
- begin
- if Before <= Container.Last then
-
- -- The new items are being inserted before some existing
- -- elements, so we must slide the existing elements up to their
- -- new home.
-
- EA (J + Count .. New_Length) := EA (J .. Old_Length);
- end if;
- end;
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Container.Last := No_Index + Index_Type'Base (New_Length);
-
- else
- Container.Last :=
- Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
- end if;
- end Insert_Space;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Vector) return Boolean is
- begin
- return Last_Index (Container) < Index_Type'First;
- end Is_Empty;
-
- ------------------
- -- Last_Element --
- ------------------
-
- function Last_Element (Container : Vector) return Element_Type is
- begin
- if Is_Empty (Container) then
- raise Constraint_Error with "Container is empty";
- else
- return Container.Elements (Length (Container));
- end if;
- end Last_Element;
-
- ----------------
- -- Last_Index --
- ----------------
-
- function Last_Index (Container : Vector) return Extended_Index is
- begin
- return Container.Last;
- end Last_Index;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Vector) return Capacity_Range is
- L : constant Int := Int (Container.Last);
- F : constant Int := Int (Index_Type'First);
- N : constant Int'Base := L - F + 1;
-
- begin
- return Capacity_Range (N);
- end Length;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out Vector; Source : in out Vector) is
- LS : constant Capacity_Range := Length (Source);
-
- begin
- if Target'Address = Source'Address then
- return;
- end if;
-
- if Target.Capacity < LS then
- raise Constraint_Error;
- end if;
-
- Clear (Target);
- Append (Target, Source);
- Clear (Source);
- end Move;
-
- ------------
- -- Prepend --
- ------------
-
- procedure Prepend (Container : in out Vector; New_Item : Vector) is
- begin
- Insert (Container, Index_Type'First, New_Item);
- end Prepend;
-
- procedure Prepend (Container : in out Vector; New_Item : Element_Type) is
- begin
- Prepend (Container, New_Item, 1);
- end Prepend;
-
- procedure Prepend
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- is
- begin
- Insert (Container, Index_Type'First, New_Item, Count);
- end Prepend;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out Vector;
- Index : Index_Type;
- New_Item : Element_Type)
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- declare
- II : constant Int'Base := Int (Index) - Int (No_Index);
- I : constant Capacity_Range := Capacity_Range (II);
-
- begin
- Container.Elements (I) := New_Item;
- end;
- end Replace_Element;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference
- (Container : not null access Vector;
- Index : Index_Type) return not null access Element_Type
- is
- begin
- if Index > Container.Last then
- raise Constraint_Error with "Index is out of range";
- end if;
-
- return Container.Elements (To_Array_Index (Index))'Access;
- end Reference;
-
- ----------------------
- -- Reserve_Capacity --
- ----------------------
-
- procedure Reserve_Capacity
- (Container : in out Vector;
- Capacity : Capacity_Range)
- is
- begin
- if Capacity > Container.Capacity then
- raise Capacity_Error with "Capacity is out of range";
- end if;
- end Reserve_Capacity;
-
- ----------------------
- -- Reverse_Elements --
- ----------------------
-
- procedure Reverse_Elements (Container : in out Vector) is
- begin
- if Length (Container) <= 1 then
- return;
- end if;
-
- declare
- I, J : Capacity_Range;
- E : Elements_Array renames
- Container.Elements (1 .. Length (Container));
-
- begin
- I := 1;
- J := Length (Container);
- while I < J loop
- declare
- EI : constant Element_Type := E (I);
-
- begin
- E (I) := E (J);
- E (J) := EI;
- end;
-
- I := I + 1;
- J := J - 1;
- end loop;
- end;
- end Reverse_Elements;
-
- ------------------------
- -- Reverse_Find_Index --
- ------------------------
-
- function Reverse_Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'Last) return Extended_Index
- is
- Last : Index_Type'Base;
- K : Count_Type'Base;
-
- begin
- if Index > Last_Index (Container) then
- Last := Last_Index (Container);
- else
- Last := Index;
- end if;
-
- K := Capacity_Range (Int (Last) - Int (No_Index));
- for Indx in reverse Index_Type'First .. Last loop
- if Container.Elements (K) = Item then
- return Indx;
- end if;
-
- K := K - 1;
- end loop;
-
- return No_Index;
- end Reverse_Find_Index;
-
- ----------
- -- Swap --
- ----------
-
- procedure Swap
- (Container : in out Vector;
- I : Index_Type;
- J : Index_Type)
- is
- begin
- if I > Container.Last then
- raise Constraint_Error with "I index is out of range";
- end if;
-
- if J > Container.Last then
- raise Constraint_Error with "J index is out of range";
- end if;
-
- if I = J then
- return;
- end if;
-
- declare
- II : constant Int'Base := Int (I) - Int (No_Index);
- JJ : constant Int'Base := Int (J) - Int (No_Index);
-
- EI : Element_Type renames Container.Elements (Capacity_Range (II));
- EJ : Element_Type renames Container.Elements (Capacity_Range (JJ));
-
- EI_Copy : constant Element_Type := EI;
-
- begin
- EI := EJ;
- EJ := EI_Copy;
- end;
- end Swap;
-
- --------------------
- -- To_Array_Index --
- --------------------
-
- function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is
- Offset : Count_Type'Base;
-
- begin
- -- We know that
- -- Index >= Index_Type'First
- -- hence we also know that
- -- Index - Index_Type'First >= 0
-
- -- The issue is that even though 0 is guaranteed to be a value in
- -- the type Index_Type'Base, there's no guarantee that the difference
- -- is a value in that type. To prevent overflow we use the wider
- -- of Count_Type'Base and Index_Type'Base to perform intermediate
- -- calculations.
-
- if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
- Offset := Count_Type'Base (Index - Index_Type'First);
-
- else
- Offset :=
- Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
- end if;
-
- -- The array index subtype for all container element arrays always
- -- starts with 1.
-
- return 1 + Offset;
- end To_Array_Index;
-
- ---------------
- -- To_Vector --
- ---------------
-
- function To_Vector
- (New_Item : Element_Type;
- Length : Capacity_Range) return Vector
- is
- begin
- if Length = 0 then
- return Empty_Vector;
- end if;
-
- declare
- First : constant Int := Int (Index_Type'First);
- Last_As_Int : constant Int'Base := First + Int (Length) - 1;
- Last : Index_Type;
-
- begin
- if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
- raise Constraint_Error with "Length is out of range"; -- ???
- end if;
-
- Last := Index_Type (Last_As_Int);
-
- return
- (Capacity => Length,
- Last => Last,
- Elements => [others => New_Item]);
- end;
- end To_Vector;
-
-end Ada.Containers.Formal_Vectors;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- This spec is derived from package Ada.Containers.Bounded_Vectors in the Ada
--- 2012 RM. The modifications are meant to facilitate formal proofs by making
--- it easier to express properties, and by making the specification of this
--- unit compatible with SPARK 2014. Note that the API of this unit may be
--- subject to incompatible changes as SPARK 2014 evolves.
-
-with Ada.Containers.Functional_Vectors;
-
generic
- type Index_Type is range <>;
- type Element_Type is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Formal_Vectors with
- SPARK_Mode
-is
- pragma Annotate (GNATprove, Always_Return, Formal_Vectors);
-
- -- Contracts in this unit are meant for analysis only, not for run-time
- -- checking.
-
- pragma Assertion_Policy (Pre => Ignore);
- pragma Assertion_Policy (Post => Ignore);
- pragma Assertion_Policy (Contract_Cases => Ignore);
- pragma Annotate (CodePeer, Skip_Analysis);
-
- subtype Extended_Index is Index_Type'Base
- range Index_Type'First - 1 ..
- Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
-
- No_Index : constant Extended_Index := Extended_Index'First;
-
- Last_Count : constant Count_Type :=
- (if Index_Type'Last < Index_Type'First then
- 0
- elsif Index_Type'Last < -1
- or else Index_Type'Pos (Index_Type'First) >
- Index_Type'Pos (Index_Type'Last) - Count_Type'Last
- then
- Index_Type'Pos (Index_Type'Last) -
- Index_Type'Pos (Index_Type'First) + 1
- else
- Count_Type'Last);
- -- Maximal capacity of any vector. It is the minimum of the size of the
- -- index range and the last possible Count_Type.
-
- subtype Capacity_Range is Count_Type range 0 .. Last_Count;
-
- type Vector (Capacity : Capacity_Range) is private with
- Default_Initial_Condition => Is_Empty (Vector),
- Iterable => (First => Iter_First,
- Has_Element => Iter_Has_Element,
- Next => Iter_Next,
- Element => Element);
-
- function Length (Container : Vector) return Capacity_Range with
- Global => null,
- Post => Length'Result <= Capacity (Container);
-
- pragma Unevaluated_Use_Of_Old (Allow);
-
- package Formal_Model with Ghost is
-
- package M is new Ada.Containers.Functional_Vectors
- (Index_Type => Index_Type,
- Element_Type => Element_Type);
-
- function "="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."=";
-
- function "<"
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<";
-
- function "<="
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean renames M."<=";
-
- function M_Elements_In_Union
- (Container : M.Sequence;
- Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- The elements of Container are contained in either Left or Right
- with
- Global => null,
- Post =>
- M_Elements_In_Union'Result =
- (for all I in Index_Type'First .. M.Last (Container) =>
- (for some J in Index_Type'First .. M.Last (Left) =>
- Element (Container, I) = Element (Left, J))
- or (for some J in Index_Type'First .. M.Last (Right) =>
- Element (Container, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union);
-
- function M_Elements_Included
- (Left : M.Sequence;
- L_Fst : Index_Type := Index_Type'First;
- L_Lst : Extended_Index;
- Right : M.Sequence;
- R_Fst : Index_Type := Index_Type'First;
- R_Lst : Extended_Index) return Boolean
- -- The elements of the slice from L_Fst to L_Lst in Left are contained
- -- in the slide from R_Fst to R_Lst in Right.
- with
- Global => null,
- Pre => L_Lst <= M.Last (Left) and R_Lst <= M.Last (Right),
- Post =>
- M_Elements_Included'Result =
- (for all I in L_Fst .. L_Lst =>
- (for some J in R_Fst .. R_Lst =>
- Element (Left, I) = Element (Right, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included);
-
- function M_Elements_Reversed
- (Left : M.Sequence;
- Right : M.Sequence) return Boolean
- -- Right is Left in reverse order
- with
- Global => null,
- Post =>
- M_Elements_Reversed'Result =
- (M.Length (Left) = M.Length (Right)
- and (for all I in Index_Type'First .. M.Last (Left) =>
- Element (Left, I) =
- Element (Right, M.Last (Left) - I + 1))
- and (for all I in Index_Type'First .. M.Last (Right) =>
- Element (Right, I) =
- Element (Left, M.Last (Left) - I + 1)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed);
-
- function M_Elements_Swapped
- (Left : M.Sequence;
- Right : M.Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- -- Elements stored at X and Y are reversed in Left and Right
- with
- Global => null,
- Pre => X <= M.Last (Left) and Y <= M.Last (Left),
- Post =>
- M_Elements_Swapped'Result =
- (M.Length (Left) = M.Length (Right)
- and Element (Left, X) = Element (Right, Y)
- and Element (Left, Y) = Element (Right, X)
- and M.Equal_Except (Left, Right, X, Y));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped);
-
- function Model (Container : Vector) return M.Sequence with
- -- The high-level model of a vector is a sequence of elements. The
- -- sequence really is similar to the vector itself. However, it is not
- -- limited which allows usage of 'Old and 'Loop_Entry attributes.
-
- Ghost,
- Global => null,
- Post => M.Length (Model'Result) = Length (Container);
- pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model);
-
- function Element
- (S : M.Sequence;
- I : Index_Type) return Element_Type renames M.Get;
- -- To improve readability of contracts, we rename the function used to
- -- access an element in the model to Element.
-
- end Formal_Model;
- use Formal_Model;
-
- function Empty_Vector return Vector with
- Global => null,
- Post => Length (Empty_Vector'Result) = 0;
-
- function "=" (Left, Right : Vector) return Boolean with
- Global => null,
- Post => "="'Result = (Model (Left) = Model (Right));
-
- function To_Vector
- (New_Item : Element_Type;
- Length : Capacity_Range) return Vector
- with
- Global => null,
- Post =>
- Formal_Vectors.Length (To_Vector'Result) = Length
- and M.Constant_Range
- (Container => Model (To_Vector'Result),
- Fst => Index_Type'First,
- Lst => Last_Index (To_Vector'Result),
- Item => New_Item);
-
- function Capacity (Container : Vector) return Capacity_Range with
- Global => null,
- Post =>
- Capacity'Result = Container.Capacity;
- pragma Annotate (GNATprove, Inline_For_Proof, Capacity);
-
- procedure Reserve_Capacity
- (Container : in out Vector;
- Capacity : Capacity_Range)
- with
- Global => null,
- Pre => Capacity <= Container.Capacity,
- Post => Model (Container) = Model (Container)'Old;
-
- function Is_Empty (Container : Vector) return Boolean with
- Global => null,
- Post => Is_Empty'Result = (Length (Container) = 0);
-
- procedure Clear (Container : in out Vector) with
- Global => null,
- Post => Length (Container) = 0;
-
- procedure Assign (Target : in out Vector; Source : Vector) with
- Global => null,
- Pre => Length (Source) <= Target.Capacity,
- Post => Model (Target) = Model (Source);
-
- function Copy
- (Source : Vector;
- Capacity : Capacity_Range := 0) return Vector
- with
- Global => null,
- Pre => (Capacity = 0 or Length (Source) <= Capacity),
- Post =>
- Model (Copy'Result) = Model (Source)
- and (if Capacity = 0 then
- Copy'Result.Capacity = Length (Source)
- else
- Copy'Result.Capacity = Capacity);
-
- procedure Move (Target : in out Vector; Source : in out Vector)
- with
- Global => null,
- Pre => Length (Source) <= Capacity (Target),
- Post => Model (Target) = Model (Source)'Old and Length (Source) = 0;
-
- function Element
- (Container : Vector;
- Index : Extended_Index) return Element_Type
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post => Element'Result = Element (Model (Container), Index);
- pragma Annotate (GNATprove, Inline_For_Proof, Element);
-
- procedure Replace_Element
- (Container : in out Vector;
- Index : Index_Type;
- New_Item : Element_Type)
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) = Length (Container)'Old
-
- -- Container now has New_Item at index Index
-
- and Element (Model (Container), Index) = New_Item
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Position => Index);
-
- function At_End (E : access constant Vector) return access constant Vector
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function At_End
- (E : access constant Element_Type) return access constant Element_Type
- is (E)
- with Ghost,
- Annotate => (GNATprove, At_End_Borrow);
-
- function Constant_Reference
- (Container : aliased Vector;
- Index : Index_Type) return not null access constant Element_Type
- with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Constant_Reference'Result.all = Element (Model (Container), Index);
-
- function Reference
- (Container : not null access Vector;
- Index : Index_Type) return not null access Element_Type
- with
- Global => null,
- Pre =>
- Index in First_Index (Container.all) .. Last_Index (Container.all),
- Post =>
- Length (Container.all) = Length (At_End (Container).all)
-
- -- Container will have Result.all at index Index
-
- and At_End (Reference'Result).all =
- Element (Model (At_End (Container).all), Index)
-
- -- All other elements are preserved
-
- and M.Equal_Except
- (Left => Model (Container.all),
- Right => Model (At_End (Container).all),
- Position => Index);
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Vector)
- with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Length (New_Item)
- and (Before in Index_Type'First .. Last_Index (Container)
- or (Before /= No_Index
- and then Before - 1 = Last_Index (Container))),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- Elements of New_Item are inserted at position Before
-
- and (if Length (New_Item) > 0 then
- M.Range_Shifted
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item),
- Offset => Count_Type (Before - Index_Type'First)))
-
- -- Elements located after Before in Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => Length (New_Item));
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type)
- with
- Global => null,
- Pre =>
- Length (Container) < Capacity (Container)
- and then (Before in Index_Type'First .. Last_Index (Container) + 1),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- Container now has New_Item at index Before
-
- and Element (Model (Container), Before) = New_Item
-
- -- Elements located after Before in Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => 1);
-
- procedure Insert
- (Container : in out Vector;
- Before : Extended_Index;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Count
- and (Before in Index_Type'First .. Last_Index (Container)
- or (Before /= No_Index
- and then Before - 1 = Last_Index (Container))),
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements located before Before in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Before - 1)
-
- -- New_Item is inserted Count times at position Before
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Before,
- Lst => Before + Index_Type'Base (Count - 1),
- Item => New_Item))
-
- -- Elements located after Before in Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Before,
- Lst => Last_Index (Container)'Old,
- Offset => Count);
-
- procedure Prepend (Container : in out Vector; New_Item : Vector) with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Length (New_Item),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- Elements of New_Item are inserted at the beginning of Container
-
- and M.Range_Equal
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item))
-
- -- Elements of Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => Length (New_Item));
-
- procedure Prepend (Container : in out Vector; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Capacity (Container),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Container now has New_Item at Index_Type'First
-
- and Element (Model (Container), Index_Type'First) = New_Item
-
- -- Elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => 1);
-
- procedure Prepend
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- New_Item is inserted Count times at the beginning of Container
-
- and M.Constant_Range
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => Index_Type'First + Index_Type'Base (Count - 1),
- Item => New_Item)
-
- -- Elements of Container are shifted
-
- and M.Range_Shifted
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container)'Old,
- Offset => Count);
-
- procedure Append (Container : in out Vector; New_Item : Vector) with
- Global => null,
- Pre =>
- Length (Container) <= Capacity (Container) - Length (New_Item),
- Post =>
- Length (Container) = Length (Container)'Old + Length (New_Item)
-
- -- The elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- Elements of New_Item are inserted at the end of Container
-
- and (if Length (New_Item) > 0 then
- M.Range_Shifted
- (Left => Model (New_Item),
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (New_Item),
- Offset =>
- Count_Type
- (Last_Index (Container)'Old - Index_Type'First + 1)));
-
- procedure Append (Container : in out Vector; New_Item : Element_Type) with
- Global => null,
- Pre => Length (Container) < Capacity (Container),
- Post =>
- Length (Container) = Length (Container)'Old + 1
-
- -- Elements of Container are preserved
-
- and Model (Container)'Old < Model (Container)
-
- -- Container now has New_Item at the end of Container
-
- and Element
- (Model (Container), Last_Index (Container)'Old + 1) = New_Item;
-
- procedure Append
- (Container : in out Vector;
- New_Item : Element_Type;
- Count : Count_Type)
- with
- Global => null,
- Pre => Length (Container) <= Capacity (Container) - Count,
- Post =>
- Length (Container) = Length (Container)'Old + Count
-
- -- Elements of Container are preserved
-
- and Model (Container)'Old <= Model (Container)
-
- -- New_Item is inserted Count times at the end of Container
-
- and (if Count > 0 then
- M.Constant_Range
- (Container => Model (Container),
- Fst => Last_Index (Container)'Old + 1,
- Lst =>
- Last_Index (Container)'Old + Index_Type'Base (Count),
- Item => New_Item));
-
- procedure Delete (Container : in out Vector; Index : Extended_Index) with
- Global => null,
- Pre => Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements located before Index in Container are preserved
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Index - 1)
-
- -- Elements located after Index in Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index,
- Lst => Last_Index (Container),
- Offset => 1);
-
- procedure Delete
- (Container : in out Vector;
- Index : Extended_Index;
- Count : Count_Type)
- with
- Global => null,
- Pre =>
- Index in First_Index (Container) .. Last_Index (Container),
- Post =>
- Length (Container) in
- Length (Container)'Old - Count .. Length (Container)'Old
-
- -- The elements of Container located before Index are preserved.
-
- and M.Range_Equal
- (Left => Model (Container)'Old,
- Right => Model (Container),
- Fst => Index_Type'First,
- Lst => Index - 1),
-
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) - Count <= Count_Type (Index - Index_Type'First) =>
- Length (Container) = Count_Type (Index - Index_Type'First),
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Other elements are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index,
- Lst => Last_Index (Container),
- Offset => Count));
-
- procedure Delete_First (Container : in out Vector) with
- Global => null,
- Pre => Length (Container) > 0,
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements of Container are shifted by 1
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Offset => 1);
-
- procedure Delete_First (Container : in out Vector; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements of Container have been erased
-
- (Length (Container) <= Count => Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- Elements of Container are shifted by Count
-
- and M.Range_Shifted
- (Left => Model (Container),
- Right => Model (Container)'Old,
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Offset => Count));
-
- procedure Delete_Last (Container : in out Vector) with
- Global => null,
- Pre => Length (Container) > 0,
- Post =>
- Length (Container) = Length (Container)'Old - 1
-
- -- Elements of Container are preserved
-
- and Model (Container) < Model (Container)'Old;
-
- procedure Delete_Last (Container : in out Vector; Count : Count_Type) with
- Global => null,
- Contract_Cases =>
-
- -- All the elements after Position have been erased
-
- (Length (Container) <= Count => Length (Container) = 0,
-
- others =>
- Length (Container) = Length (Container)'Old - Count
-
- -- The elements of Container are preserved
-
- and Model (Container) <= Model (Container)'Old);
-
- procedure Reverse_Elements (Container : in out Vector) with
- Global => null,
- Post => M_Elements_Reversed (Model (Container)'Old, Model (Container));
-
- procedure Swap
- (Container : in out Vector;
- I : Index_Type;
- J : Index_Type)
- with
- Global => null,
- Pre =>
- I in First_Index (Container) .. Last_Index (Container)
- and then J in First_Index (Container) .. Last_Index (Container),
- Post =>
- M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J);
-
- function First_Index (Container : Vector) return Index_Type with
- Global => null,
- Post => First_Index'Result = Index_Type'First;
- pragma Annotate (GNATprove, Inline_For_Proof, First_Index);
-
- function First_Element (Container : Vector) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- First_Element'Result = Element (Model (Container), Index_Type'First);
- pragma Annotate (GNATprove, Inline_For_Proof, First_Element);
-
- function Last_Index (Container : Vector) return Extended_Index with
- Global => null,
- Post => Last_Index'Result = M.Last (Model (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Last_Index);
-
- function Last_Element (Container : Vector) return Element_Type with
- Global => null,
- Pre => not Is_Empty (Container),
- Post =>
- Last_Element'Result =
- Element (Model (Container), Last_Index (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Last_Element);
-
- function Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'First) return Extended_Index
- with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container after Index, Find_Index
- -- returns No_Index.
-
- (Index > Last_Index (Container)
- or else not M.Contains
- (Container => Model (Container),
- Fst => Index,
- Lst => Last_Index (Container),
- Item => Item)
- =>
- Find_Index'Result = No_Index,
-
- -- Otherwise, Find_Index returns a valid index greater than Index
-
- others =>
- Find_Index'Result in Index .. Last_Index (Container)
-
- -- The element at this index in Container is Item
-
- and Element (Model (Container), Find_Index'Result) = Item
-
- -- It is the first occurrence of Item after Index in Container
-
- and not M.Contains
- (Container => Model (Container),
- Fst => Index,
- Lst => Find_Index'Result - 1,
- Item => Item));
-
- function Reverse_Find_Index
- (Container : Vector;
- Item : Element_Type;
- Index : Index_Type := Index_Type'Last) return Extended_Index
- with
- Global => null,
- Contract_Cases =>
-
- -- If Item is not contained in Container before Index,
- -- Reverse_Find_Index returns No_Index.
-
- (not M.Contains
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => (if Index <= Last_Index (Container) then Index
- else Last_Index (Container)),
- Item => Item)
- =>
- Reverse_Find_Index'Result = No_Index,
-
- -- Otherwise, Reverse_Find_Index returns a valid index smaller than
- -- Index
-
- others =>
- Reverse_Find_Index'Result in Index_Type'First .. Index
- and Reverse_Find_Index'Result <= Last_Index (Container)
-
- -- The element at this index in Container is Item
-
- and Element (Model (Container), Reverse_Find_Index'Result) = Item
-
- -- It is the last occurrence of Item before Index in Container
-
- and not M.Contains
- (Container => Model (Container),
- Fst => Reverse_Find_Index'Result + 1,
- Lst =>
- (if Index <= Last_Index (Container) then
- Index
- else
- Last_Index (Container)),
- Item => Item));
-
- function Contains
- (Container : Vector;
- Item : Element_Type) return Boolean
- with
- Global => null,
- Post =>
- Contains'Result =
- M.Contains
- (Container => Model (Container),
- Fst => Index_Type'First,
- Lst => Last_Index (Container),
- Item => Item);
-
- function Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- with
- Global => null,
- Post =>
- Has_Element'Result =
- (Position in Index_Type'First .. Last_Index (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Has_Element);
-
- generic
- with function "<" (Left, Right : Element_Type) return Boolean is <>;
- package Generic_Sorting with SPARK_Mode is
-
- package Formal_Model with Ghost is
-
- function M_Elements_Sorted (Container : M.Sequence) return Boolean
- with
- Global => null,
- Post =>
- M_Elements_Sorted'Result =
- (for all I in Index_Type'First .. M.Last (Container) =>
- (for all J in I .. M.Last (Container) =>
- Element (Container, I) = Element (Container, J)
- or Element (Container, I) < Element (Container, J)));
- pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted);
-
- end Formal_Model;
- use Formal_Model;
-
- function Is_Sorted (Container : Vector) return Boolean with
- Global => null,
- Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container));
-
- procedure Sort (Container : in out Vector) with
- Global => null,
- Post =>
- Length (Container) = Length (Container)'Old
- and M_Elements_Sorted (Model (Container))
- and M_Elements_Included
- (Left => Model (Container)'Old,
- L_Lst => Last_Index (Container),
- Right => Model (Container),
- R_Lst => Last_Index (Container))
- and M_Elements_Included
- (Left => Model (Container),
- L_Lst => Last_Index (Container),
- Right => Model (Container)'Old,
- R_Lst => Last_Index (Container));
-
- procedure Merge (Target : in out Vector; Source : in out Vector) with
- -- Target and Source should not be aliased
- Global => null,
- Pre => Length (Source) <= Capacity (Target) - Length (Target),
- Post =>
- Length (Target) = Length (Target)'Old + Length (Source)'Old
- and Length (Source) = 0
- and (if M_Elements_Sorted (Model (Target)'Old)
- and M_Elements_Sorted (Model (Source)'Old)
- then
- M_Elements_Sorted (Model (Target)))
- and M_Elements_Included
- (Left => Model (Target)'Old,
- L_Lst => Last_Index (Target)'Old,
- Right => Model (Target),
- R_Lst => Last_Index (Target))
- and M_Elements_Included
- (Left => Model (Source)'Old,
- L_Lst => Last_Index (Source)'Old,
- Right => Model (Target),
- R_Lst => Last_Index (Target))
- and M_Elements_In_Union
- (Model (Target),
- Model (Source)'Old,
- Model (Target)'Old);
- end Generic_Sorting;
-
- ---------------------------
- -- Iteration Primitives --
- ---------------------------
-
- function Iter_First (Container : Vector) return Extended_Index with
- Global => null;
-
- function Iter_Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- with
- Global => null,
- Post =>
- Iter_Has_Element'Result =
- (Position in Index_Type'First .. Last_Index (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element);
-
- function Iter_Next
- (Container : Vector;
- Position : Extended_Index) return Extended_Index
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Position);
-
-private
- pragma SPARK_Mode (Off);
-
- pragma Inline (First_Index);
- pragma Inline (Last_Index);
- pragma Inline (Element);
- pragma Inline (First_Element);
- pragma Inline (Last_Element);
- pragma Inline (Replace_Element);
- pragma Inline (Contains);
-
- subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last;
- type Elements_Array is array (Array_Index range <>) of aliased Element_Type;
- function "=" (L, R : Elements_Array) return Boolean is abstract;
-
- type Vector (Capacity : Capacity_Range) is record
- Last : Extended_Index := No_Index;
- Elements : Elements_Array (1 .. Capacity);
- end record;
-
- function Empty_Vector return Vector is
- ((Capacity => 0, others => <>));
-
- function Iter_First (Container : Vector) return Extended_Index is
- (Index_Type'First);
-
- function Iter_Next
- (Container : Vector;
- Position : Extended_Index) return Extended_Index
- is
- (if Position = Extended_Index'Last then
- Extended_Index'First
- else
- Extended_Index'Succ (Position));
+package Ada.Containers.Formal_Vectors with SPARK_Mode is
- function Iter_Has_Element
- (Container : Vector;
- Position : Extended_Index) return Boolean
- is
- (Position in Index_Type'First .. Container.Last);
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Formal_Vectors;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_BASE --
--- --
--- B o d y --
--- --
--- Copyright (C) 2016-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-pragma Ada_2012;
-with Ada.Unchecked_Deallocation;
-
-package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
-
- function To_Count (Idx : Extended_Index) return Count_Type is
- (Count_Type
- (Extended_Index'Pos (Idx) -
- Extended_Index'Pos (Extended_Index'First)));
-
- function To_Index (Position : Count_Type) return Extended_Index is
- (Extended_Index'Val
- (Position + Extended_Index'Pos (Extended_Index'First)));
- -- Conversion functions between Index_Type and Count_Type
-
- function Find (C : Container; E : access Element_Type) return Count_Type;
- -- Search a container C for an element equal to E.all, returning the
- -- position in the underlying array.
-
- procedure Resize (Base : Array_Base_Access);
- -- Resize the underlying array if needed so that it can contain one more
- -- element.
-
- function Elements (C : Container) return Element_Array_Access is
- (C.Controlled_Base.Base.Elements)
- with
- Global => null,
- Pre =>
- C.Controlled_Base.Base /= null
- and then C.Controlled_Base.Base.Elements /= null;
-
- function Get
- (C_E : Element_Array_Access;
- I : Count_Type)
- return Element_Access
- is
- (C_E (I).Ref.E_Access)
- with
- Global => null,
- Pre => C_E /= null and then C_E (I).Ref /= null;
-
- ---------
- -- "=" --
- ---------
-
- function "=" (C1 : Container; C2 : Container) return Boolean is
- begin
- if C1.Length /= C2.Length then
- return False;
- end if;
- for I in 1 .. C1.Length loop
- if Get (Elements (C1), I).all /= Get (Elements (C2), I).all then
- return False;
- end if;
- end loop;
-
- return True;
- end "=";
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (C1 : Container; C2 : Container) return Boolean is
- begin
- for I in 1 .. C1.Length loop
- if Find (C2, Get (Elements (C1), I)) = 0 then
- return False;
- end if;
- end loop;
-
- return True;
- end "<=";
-
- ---------
- -- Add --
- ---------
-
- function Add
- (C : Container;
- I : Index_Type;
- E : Element_Type) return Container
- is
- C_B : Array_Base_Access renames C.Controlled_Base.Base;
- begin
- if To_Count (I) = C.Length + 1 and then C.Length = C_B.Max_Length then
- Resize (C_B);
- C_B.Max_Length := C_B.Max_Length + 1;
- C_B.Elements (C_B.Max_Length) := Element_Init (E);
-
- return Container'(Length => C_B.Max_Length,
- Controlled_Base => C.Controlled_Base);
- else
- declare
- A : constant Array_Base_Controlled_Access :=
- Content_Init (C.Length);
- P : Count_Type := 0;
- begin
- A.Base.Max_Length := C.Length + 1;
- for J in 1 .. C.Length + 1 loop
- if J /= To_Count (I) then
- P := P + 1;
- A.Base.Elements (J) := C_B.Elements (P);
- else
- A.Base.Elements (J) := Element_Init (E);
- end if;
- end loop;
-
- return Container'(Length => A.Base.Max_Length,
- Controlled_Base => A);
- end;
- end if;
- end Add;
-
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Controlled_Base : in out Array_Base_Controlled_Access) is
- C_B : Array_Base_Access renames Controlled_Base.Base;
- begin
- if C_B /= null then
- C_B.Reference_Count := C_B.Reference_Count + 1;
- end if;
- end Adjust;
-
- procedure Adjust (Ctrl_E : in out Controlled_Element_Access) is
- begin
- if Ctrl_E.Ref /= null then
- Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count + 1;
- end if;
- end Adjust;
-
- ------------------
- -- Content_Init --
- ------------------
-
- function Content_Init
- (L : Count_Type := 0) return Array_Base_Controlled_Access
- is
- Max_Init : constant Count_Type := 100;
- Size : constant Count_Type :=
- (if L < Count_Type'Last - Max_Init then L + Max_Init
- else Count_Type'Last);
-
- -- The Access in the array will be initialized to null
-
- Elements : constant Element_Array_Access :=
- new Element_Array'(1 .. Size => <>);
- B : constant Array_Base_Access :=
- new Array_Base'(Reference_Count => 1,
- Max_Length => 0,
- Elements => Elements);
- begin
- return (Ada.Finalization.Controlled with Base => B);
- end Content_Init;
-
- ------------------
- -- Element_Init --
- ------------------
-
- function Element_Init (E : Element_Type) return Controlled_Element_Access
- is
- Refcounted_E : constant Refcounted_Element_Access :=
- new Refcounted_Element'(Reference_Count => 1,
- E_Access => new Element_Type'(E));
- begin
- return (Ada.Finalization.Controlled with Ref => Refcounted_E);
- end Element_Init;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Controlled_Base : in out Array_Base_Controlled_Access)
- is
- procedure Unchecked_Free_Base is new Ada.Unchecked_Deallocation
- (Object => Array_Base,
- Name => Array_Base_Access);
- procedure Unchecked_Free_Array is new Ada.Unchecked_Deallocation
- (Object => Element_Array,
- Name => Element_Array_Access);
-
- C_B : Array_Base_Access renames Controlled_Base.Base;
- begin
- if C_B /= null then
- C_B.Reference_Count := C_B.Reference_Count - 1;
- if C_B.Reference_Count = 0 then
- Unchecked_Free_Array (Controlled_Base.Base.Elements);
- Unchecked_Free_Base (Controlled_Base.Base);
- end if;
- C_B := null;
- end if;
- end Finalize;
-
- procedure Finalize (Ctrl_E : in out Controlled_Element_Access) is
- procedure Unchecked_Free_Ref is new Ada.Unchecked_Deallocation
- (Object => Refcounted_Element,
- Name => Refcounted_Element_Access);
-
- procedure Unchecked_Free_Element is new Ada.Unchecked_Deallocation
- (Object => Element_Type,
- Name => Element_Access);
-
- begin
- if Ctrl_E.Ref /= null then
- Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count - 1;
- if Ctrl_E.Ref.Reference_Count = 0 then
- Unchecked_Free_Element (Ctrl_E.Ref.E_Access);
- Unchecked_Free_Ref (Ctrl_E.Ref);
- end if;
- Ctrl_E.Ref := null;
- end if;
- end Finalize;
-
- ----------
- -- Find --
- ----------
-
- function Find (C : Container; E : access Element_Type) return Count_Type is
- begin
- for I in 1 .. C.Length loop
- if Get (Elements (C), I).all = E.all then
- return I;
- end if;
- end loop;
-
- return 0;
- end Find;
-
- function Find (C : Container; E : Element_Type) return Extended_Index is
- (To_Index (Find (C, E'Unrestricted_Access)));
-
- ---------
- -- Get --
- ---------
-
- function Get (C : Container; I : Index_Type) return Element_Type is
- (Get (Elements (C), To_Count (I)).all);
-
- ------------------
- -- Intersection --
- ------------------
-
- function Intersection (C1 : Container; C2 : Container) return Container is
- L : constant Count_Type := Num_Overlaps (C1, C2);
- A : constant Array_Base_Controlled_Access := Content_Init (L);
- P : Count_Type := 0;
-
- begin
- A.Base.Max_Length := L;
- for I in 1 .. C1.Length loop
- if Find (C2, Get (Elements (C1), I)) > 0 then
- P := P + 1;
- A.Base.Elements (P) := Elements (C1) (I);
- end if;
- end loop;
-
- return Container'(Length => P, Controlled_Base => A);
- end Intersection;
-
- ------------
- -- Length --
- ------------
-
- function Length (C : Container) return Count_Type is (C.Length);
- ---------------------
- -- Num_Overlaps --
- ---------------------
-
- function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type is
- P : Count_Type := 0;
-
- begin
- for I in 1 .. C1.Length loop
- if Find (C2, Get (Elements (C1), I)) > 0 then
- P := P + 1;
- end if;
- end loop;
-
- return P;
- end Num_Overlaps;
-
- ------------
- -- Remove --
- ------------
-
- function Remove (C : Container; I : Index_Type) return Container is
- begin
- if To_Count (I) = C.Length then
- return Container'(Length => C.Length - 1,
- Controlled_Base => C.Controlled_Base);
- else
- declare
- A : constant Array_Base_Controlled_Access
- := Content_Init (C.Length - 1);
- P : Count_Type := 0;
- begin
- A.Base.Max_Length := C.Length - 1;
- for J in 1 .. C.Length loop
- if J /= To_Count (I) then
- P := P + 1;
- A.Base.Elements (P) := Elements (C) (J);
- end if;
- end loop;
-
- return Container'(Length => C.Length - 1, Controlled_Base => A);
- end;
- end if;
- end Remove;
-
- ------------
- -- Resize --
- ------------
-
- procedure Resize (Base : Array_Base_Access) is
- begin
- if Base.Max_Length < Base.Elements'Length then
- return;
- end if;
-
- pragma Assert (Base.Max_Length = Base.Elements'Length);
-
- if Base.Max_Length = Count_Type'Last then
- raise Constraint_Error;
- end if;
-
- declare
- procedure Finalize is new Ada.Unchecked_Deallocation
- (Object => Element_Array,
- Name => Element_Array_Access_Base);
-
- New_Length : constant Positive_Count_Type :=
- (if Base.Max_Length > Count_Type'Last / 2 then Count_Type'Last
- else 2 * Base.Max_Length);
- Elements : constant Element_Array_Access :=
- new Element_Array (1 .. New_Length);
- Old_Elmts : Element_Array_Access_Base := Base.Elements;
- begin
- Elements (1 .. Base.Max_Length) := Base.Elements.all;
- Base.Elements := Elements;
- Finalize (Old_Elmts);
- end;
- end Resize;
-
- ---------
- -- Set --
- ---------
-
- function Set
- (C : Container;
- I : Index_Type;
- E : Element_Type) return Container
- is
- Result : constant Container :=
- Container'(Length => C.Length,
- Controlled_Base => Content_Init (C.Length));
- R_Base : Array_Base_Access renames Result.Controlled_Base.Base;
-
- begin
- R_Base.Max_Length := C.Length;
- R_Base.Elements (1 .. C.Length) := Elements (C) (1 .. C.Length);
- R_Base.Elements (To_Count (I)) := Element_Init (E);
- return Result;
- end Set;
-
- -----------
- -- Union --
- -----------
-
- function Union (C1 : Container; C2 : Container) return Container is
- N : constant Count_Type := Num_Overlaps (C1, C2);
-
- begin
- -- if C2 is completely included in C1 then return C1
-
- if N = Length (C2) then
- return C1;
- end if;
-
- -- else loop through C2 to find the remaining elements
-
- declare
- L : constant Count_Type := Length (C1) - N + Length (C2);
- A : constant Array_Base_Controlled_Access := Content_Init (L);
- P : Count_Type := Length (C1);
- begin
- A.Base.Max_Length := L;
- A.Base.Elements (1 .. C1.Length) := Elements (C1) (1 .. C1.Length);
- for I in 1 .. C2.Length loop
- if Find (C1, Get (Elements (C2), I)) = 0 then
- P := P + 1;
- A.Base.Elements (P) := Elements (C2) (I);
- end if;
- end loop;
-
- return Container'(Length => L, Controlled_Base => A);
- end;
- end Union;
-
-end Ada.Containers.Functional_Base;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_BASE --
--- --
--- S p e c --
--- --
--- Copyright (C) 2016-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
--- Functional containers are neither controlled nor limited. This is safe, as
--- no primitives are provided to modify them.
--- Memory allocated inside functional containers is never reclaimed.
-
-pragma Ada_2012;
-
--- To allow reference counting on the base container
-
-private with Ada.Finalization;
-
-private generic
- type Index_Type is (<>);
- -- To avoid Constraint_Error being raised at run time, Index_Type'Base
- -- should have at least one more element at the low end than Index_Type.
-
- type Element_Type (<>) is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Functional_Base with SPARK_Mode => Off is
-
- subtype Extended_Index is Index_Type'Base range
- Index_Type'Pred (Index_Type'First) .. Index_Type'Last;
-
- type Container is private;
-
- function "=" (C1 : Container; C2 : Container) return Boolean;
- -- Return True if C1 and C2 contain the same elements at the same position
-
- function Length (C : Container) return Count_Type;
- -- Number of elements stored in C
-
- function Get (C : Container; I : Index_Type) return Element_Type;
- -- Access to the element at index I in C
-
- function Set
- (C : Container;
- I : Index_Type;
- E : Element_Type) return Container;
- -- Return a new container which is equal to C except for the element at
- -- index I, which is set to E.
-
- function Add
- (C : Container;
- I : Index_Type;
- E : Element_Type) return Container;
- -- Return a new container that is C with E inserted at index I
-
- function Remove (C : Container; I : Index_Type) return Container;
- -- Return a new container that is C without the element at index I
-
- function Find (C : Container; E : Element_Type) return Extended_Index;
- -- Return the first index for which the element stored in C is I. If there
- -- are no such indexes, return Extended_Index'First.
-
- --------------------
- -- Set Operations --
- --------------------
-
- function "<=" (C1 : Container; C2 : Container) return Boolean;
- -- Return True if every element of C1 is in C2
-
- function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type;
- -- Return the number of elements that are in both C1 and C2
-
- function Union (C1 : Container; C2 : Container) return Container;
- -- Return a container which is C1 plus all the elements of C2 that are not
- -- in C1.
-
- function Intersection (C1 : Container; C2 : Container) return Container;
- -- Return a container which is C1 minus all the elements that are also in
- -- C2.
-
-private
-
- -- Theoretically, each operation on a functional container implies the
- -- creation of a new container i.e. the copy of the array itself and all
- -- the elements in it. In the implementation, most of these copies are
- -- avoided by sharing between the containers.
- --
- -- A container stores its last used index. So, when adding an
- -- element at the end of the container, the exact same array can be reused.
- -- As a functionnal container cannot be modifed once created, there is no
- -- risk of unwanted modifications.
- --
- -- _1_2_3_
- -- S : end => [1, 2, 3]
- -- |
- -- |1|2|3|4|.|.|
- -- |
- -- Add (S, 4, 4) : end => [1, 2, 3, 4]
- --
- -- The elements are also shared between containers as much as possible. For
- -- example, when something is added in the middle, the array is changed but
- -- the elementes are reused.
- --
- -- _1_2_3_4_
- -- S : |1|2|3|4| => [1, 2, 3, 4]
- -- | \ \ \
- -- Add (S, 2, 5) : |1|5|2|3|4| => [1, 5, 2, 3, 4]
- --
- -- To make this sharing possible, both the elements and the arrays are
- -- stored inside dynamically allocated access types which shall be
- -- deallocated when they are no longer used. The memory is managed using
- -- reference counting both at the array and at the element level.
-
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- type Reference_Count_Type is new Natural;
-
- type Element_Access is access all Element_Type;
-
- type Refcounted_Element is record
- Reference_Count : Reference_Count_Type;
- E_Access : Element_Access;
- end record;
-
- type Refcounted_Element_Access is access Refcounted_Element;
-
- type Controlled_Element_Access is new Ada.Finalization.Controlled
- with record
- Ref : Refcounted_Element_Access := null;
- end record;
-
- function Element_Init (E : Element_Type) return Controlled_Element_Access;
- -- Use to initialize a refcounted element
-
- type Element_Array is
- array (Positive_Count_Type range <>) of Controlled_Element_Access;
-
- type Element_Array_Access_Base is access Element_Array;
-
- subtype Element_Array_Access is Element_Array_Access_Base;
-
- type Array_Base is record
- Reference_Count : Reference_Count_Type;
- Max_Length : Count_Type;
- Elements : Element_Array_Access;
- end record;
-
- type Array_Base_Access is access Array_Base;
-
- type Array_Base_Controlled_Access is new Ada.Finalization.Controlled
- with record
- Base : Array_Base_Access;
- end record;
-
- overriding procedure Adjust
- (Controlled_Base : in out Array_Base_Controlled_Access);
-
- overriding procedure Finalize
- (Controlled_Base : in out Array_Base_Controlled_Access);
-
- overriding procedure Adjust
- (Ctrl_E : in out Controlled_Element_Access);
-
- overriding procedure Finalize
- (Ctrl_E : in out Controlled_Element_Access);
-
- function Content_Init (L : Count_Type := 0)
- return Array_Base_Controlled_Access;
- -- Used to initialize the content of an array base with length L
-
- type Container is record
- Length : Count_Type := 0;
- Controlled_Base : Array_Base_Controlled_Access := Content_Init;
- end record;
-
-end Ada.Containers.Functional_Base;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_MAPS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2016-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-pragma Ada_2012;
-package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is
- use Key_Containers;
- use Element_Containers;
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
- use Conversions;
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Map; Right : Map) return Boolean is
- (Left.Keys <= Right.Keys and Right <= Left);
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (Left : Map; Right : Map) return Boolean is
- I2 : Count_Type;
-
- begin
- for I1 in 1 .. Length (Left.Keys) loop
- I2 := Find (Right.Keys, Get (Left.Keys, I1));
- if I2 = 0
- or else Get (Right.Elements, I2) /= Get (Left.Elements, I1)
- then
- return False;
- end if;
- end loop;
- return True;
- end "<=";
-
- ---------
- -- Add --
- ---------
-
- function Add
- (Container : Map;
- New_Key : Key_Type;
- New_Item : Element_Type) return Map
- is
- begin
- return
- (Keys =>
- Add (Container.Keys, Length (Container.Keys) + 1, New_Key),
- Elements =>
- Add
- (Container.Elements, Length (Container.Elements) + 1, New_Item));
- end Add;
-
- ---------------------------
- -- Elements_Equal_Except --
- ---------------------------
-
- function Elements_Equal_Except
- (Left : Map;
- Right : Map;
- New_Key : Key_Type) return Boolean
- is
- begin
- for J in 1 .. Length (Left.Keys) loop
- declare
- K : constant Key_Type := Get (Left.Keys, J);
- begin
- if not Equivalent_Keys (K, New_Key)
- and then
- (Find (Right.Keys, K) = 0
- or else Get (Right.Elements, Find (Right.Keys, K)) /=
- Get (Left.Elements, J))
- then
- return False;
- end if;
- end;
- end loop;
- return True;
- end Elements_Equal_Except;
-
- function Elements_Equal_Except
- (Left : Map;
- Right : Map;
- X : Key_Type;
- Y : Key_Type) return Boolean
- is
- begin
- for J in 1 .. Length (Left.Keys) loop
- declare
- K : constant Key_Type := Get (Left.Keys, J);
- begin
- if not Equivalent_Keys (K, X)
- and then not Equivalent_Keys (K, Y)
- and then
- (Find (Right.Keys, K) = 0
- or else Get (Right.Elements, Find (Right.Keys, K)) /=
- Get (Left.Elements, J))
- then
- return False;
- end if;
- end;
- end loop;
- return True;
- end Elements_Equal_Except;
-
- ---------------
- -- Empty_Map --
- ---------------
-
- function Empty_Map return Map is
- ((others => <>));
-
- ---------
- -- Get --
- ---------
-
- function Get (Container : Map; Key : Key_Type) return Element_Type is
- begin
- return Get (Container.Elements, Find (Container.Keys, Key));
- end Get;
-
- -------------
- -- Has_Key --
- -------------
-
- function Has_Key (Container : Map; Key : Key_Type) return Boolean is
- begin
- return Find (Container.Keys, Key) > 0;
- end Has_Key;
-
- -----------------
- -- Has_Witness --
- -----------------
-
- function Has_Witness
- (Container : Map;
- Witness : Count_Type) return Boolean
- is
- (Witness in 1 .. Length (Container.Keys));
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Map) return Boolean is
- begin
- return Length (Container.Keys) = 0;
- end Is_Empty;
-
- -------------------
- -- Keys_Included --
- -------------------
-
- function Keys_Included (Left : Map; Right : Map) return Boolean is
- begin
- for J in 1 .. Length (Left.Keys) loop
- declare
- K : constant Key_Type := Get (Left.Keys, J);
- begin
- if Find (Right.Keys, K) = 0 then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end Keys_Included;
-
- --------------------------
- -- Keys_Included_Except --
- --------------------------
-
- function Keys_Included_Except
- (Left : Map;
- Right : Map;
- New_Key : Key_Type) return Boolean
- is
- begin
- for J in 1 .. Length (Left.Keys) loop
- declare
- K : constant Key_Type := Get (Left.Keys, J);
- begin
- if not Equivalent_Keys (K, New_Key)
- and then Find (Right.Keys, K) = 0
- then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end Keys_Included_Except;
-
- function Keys_Included_Except
- (Left : Map;
- Right : Map;
- X : Key_Type;
- Y : Key_Type) return Boolean
- is
- begin
- for J in 1 .. Length (Left.Keys) loop
- declare
- K : constant Key_Type := Get (Left.Keys, J);
- begin
- if not Equivalent_Keys (K, X)
- and then not Equivalent_Keys (K, Y)
- and then Find (Right.Keys, K) = 0
- then
- return False;
- end if;
- end;
- end loop;
-
- return True;
- end Keys_Included_Except;
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Map) return Big_Natural is
- begin
- return To_Big_Integer (Length (Container.Elements));
- end Length;
-
- ------------
- -- Remove --
- ------------
-
- function Remove (Container : Map; Key : Key_Type) return Map is
- J : constant Extended_Index := Find (Container.Keys, Key);
- begin
- return
- (Keys => Remove (Container.Keys, J),
- Elements => Remove (Container.Elements, J));
- end Remove;
-
- ---------------
- -- Same_Keys --
- ---------------
-
- function Same_Keys (Left : Map; Right : Map) return Boolean is
- (Keys_Included (Left, Right)
- and Keys_Included (Left => Right, Right => Left));
-
- ---------
- -- Set --
- ---------
-
- function Set
- (Container : Map;
- Key : Key_Type;
- New_Item : Element_Type) return Map
- is
- (Keys => Container.Keys,
- Elements =>
- Set (Container.Elements, Find (Container.Keys, Key), New_Item));
-
- -----------
- -- W_Get --
- -----------
-
- function W_Get
- (Container : Map;
- Witness : Count_Type) return Element_Type
- is
- (Get (Container.Elements, Witness));
-
- -------------
- -- Witness --
- -------------
-
- function Witness (Container : Map; Key : Key_Type) return Count_Type is
- (Find (Container.Keys, Key));
-
-end Ada.Containers.Functional_Maps;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-pragma Ada_2012;
-private with Ada.Containers.Functional_Base;
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
generic
- type Key_Type (<>) is private;
- type Element_Type (<>) is private;
-
- with function Equivalent_Keys
- (Left : Key_Type;
- Right : Key_Type) return Boolean is "=";
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
- Enable_Handling_Of_Equivalence : Boolean := True;
- -- This constant should only be set to False when no particular handling
- -- of equivalence over keys is needed, that is, Equivalent_Keys defines a
- -- key uniquely.
-
-package Ada.Containers.Functional_Maps with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- type Map is private with
- Default_Initial_Condition => Is_Empty (Map) and Length (Map) = 0,
- Iterable => (First => Iter_First,
- Next => Iter_Next,
- Has_Element => Iter_Has_Element,
- Element => Iter_Element);
- -- Maps are empty when default initialized.
- -- "For in" quantification over maps should not be used.
- -- "For of" quantification over maps iterates over keys.
- -- Note that, for proof, "for of" quantification is understood modulo
- -- equivalence (the range of quantification comprises all the keys that are
- -- equivalent to any key of the map).
-
- -----------------------
- -- Basic operations --
- -----------------------
-
- -- Maps are axiomatized using Has_Key and Get, encoding respectively the
- -- presence of a key in a map and an accessor to elements associated with
- -- its keys. The length of a map is also added to protect Add against
- -- overflows but it is not actually modeled.
-
- function Has_Key (Container : Map; Key : Key_Type) return Boolean with
- -- Return True if Key is present in Container
-
- Global => null,
- Post =>
- (if Enable_Handling_Of_Equivalence then
-
- -- Has_Key returns the same result on all equivalent keys
-
- (if (for some K of Container => Equivalent_Keys (K, Key)) then
- Has_Key'Result));
-
- function Get (Container : Map; Key : Key_Type) return Element_Type with
- -- Return the element associated with Key in Container
-
- Global => null,
- Pre => Has_Key (Container, Key),
- Post =>
- (if Enable_Handling_Of_Equivalence then
-
- -- Get returns the same result on all equivalent keys
-
- Get'Result = W_Get (Container, Witness (Container, Key))
- and (for all K of Container =>
- (Equivalent_Keys (K, Key) =
- (Witness (Container, Key) = Witness (Container, K)))));
-
- function Length (Container : Map) return Big_Natural with
- Global => null;
- -- Return the number of mappings in Container
-
- ------------------------
- -- Property Functions --
- ------------------------
-
- function "<=" (Left : Map; Right : Map) return Boolean with
- -- Map inclusion
-
- Global => null,
- Post =>
- "<="'Result =
- (for all Key of Left =>
- Has_Key (Right, Key) and then Get (Right, Key) = Get (Left, Key));
-
- function "=" (Left : Map; Right : Map) return Boolean with
- -- Extensional equality over maps
-
- Global => null,
- Post =>
- "="'Result =
- ((for all Key of Left =>
- Has_Key (Right, Key)
- and then Get (Right, Key) = Get (Left, Key))
- and (for all Key of Right => Has_Key (Left, Key)));
-
- pragma Warnings (Off, "unused variable ""Key""");
- function Is_Empty (Container : Map) return Boolean with
- -- A map is empty if it contains no key
-
- Global => null,
- Post => Is_Empty'Result = (for all Key of Container => False);
- pragma Warnings (On, "unused variable ""Key""");
-
- function Keys_Included (Left : Map; Right : Map) return Boolean
- -- Returns True if every Key of Left is in Right
-
- with
- Global => null,
- Post =>
- Keys_Included'Result = (for all Key of Left => Has_Key (Right, Key));
-
- function Same_Keys (Left : Map; Right : Map) return Boolean
- -- Returns True if Left and Right have the same keys
-
- with
- Global => null,
- Post =>
- Same_Keys'Result =
- (Keys_Included (Left, Right)
- and Keys_Included (Left => Right, Right => Left));
- pragma Annotate (GNATprove, Inline_For_Proof, Same_Keys);
-
- function Keys_Included_Except
- (Left : Map;
- Right : Map;
- New_Key : Key_Type) return Boolean
- -- Returns True if Left contains only keys of Right and possibly New_Key
-
- with
- Global => null,
- Post =>
- Keys_Included_Except'Result =
- (for all Key of Left =>
- (if not Equivalent_Keys (Key, New_Key) then
- Has_Key (Right, Key)));
-
- function Keys_Included_Except
- (Left : Map;
- Right : Map;
- X : Key_Type;
- Y : Key_Type) return Boolean
- -- Returns True if Left contains only keys of Right and possibly X and Y
-
- with
- Global => null,
- Post =>
- Keys_Included_Except'Result =
- (for all Key of Left =>
- (if not Equivalent_Keys (Key, X)
- and not Equivalent_Keys (Key, Y)
- then
- Has_Key (Right, Key)));
-
- function Elements_Equal_Except
- (Left : Map;
- Right : Map;
- New_Key : Key_Type) return Boolean
- -- Returns True if all the keys of Left are mapped to the same elements in
- -- Left and Right except New_Key.
-
- with
- Global => null,
- Post =>
- Elements_Equal_Except'Result =
- (for all Key of Left =>
- (if not Equivalent_Keys (Key, New_Key) then
- Has_Key (Right, Key)
- and then Get (Left, Key) = Get (Right, Key)));
-
- function Elements_Equal_Except
- (Left : Map;
- Right : Map;
- X : Key_Type;
- Y : Key_Type) return Boolean
- -- Returns True if all the keys of Left are mapped to the same elements in
- -- Left and Right except X and Y.
-
- with
- Global => null,
- Post =>
- Elements_Equal_Except'Result =
- (for all Key of Left =>
- (if not Equivalent_Keys (Key, X)
- and not Equivalent_Keys (Key, Y)
- then
- Has_Key (Right, Key)
- and then Get (Left, Key) = Get (Right, Key)));
-
- ----------------------------
- -- Construction Functions --
- ----------------------------
-
- -- For better efficiency of both proofs and execution, avoid using
- -- construction functions in annotations and rather use property functions.
-
- function Add
- (Container : Map;
- New_Key : Key_Type;
- New_Item : Element_Type) return Map
- -- Returns Container augmented with the mapping Key -> New_Item
-
- with
- Global => null,
- Pre => not Has_Key (Container, New_Key),
- Post =>
- Length (Container) + 1 = Length (Add'Result)
- and Has_Key (Add'Result, New_Key)
- and Get (Add'Result, New_Key) = New_Item
- and Container <= Add'Result
- and Keys_Included_Except (Add'Result, Container, New_Key);
-
- function Empty_Map return Map with
- -- Return an empty Map
-
- Global => null,
- Post =>
- Length (Empty_Map'Result) = 0
- and Is_Empty (Empty_Map'Result);
-
- function Remove
- (Container : Map;
- Key : Key_Type) return Map
- -- Returns Container without any mapping for Key
-
- with
- Global => null,
- Pre => Has_Key (Container, Key),
- Post =>
- Length (Container) = Length (Remove'Result) + 1
- and not Has_Key (Remove'Result, Key)
- and Remove'Result <= Container
- and Keys_Included_Except (Container, Remove'Result, Key);
-
- function Set
- (Container : Map;
- Key : Key_Type;
- New_Item : Element_Type) return Map
- -- Returns Container, where the element associated with Key has been
- -- replaced by New_Item.
-
- with
- Global => null,
- Pre => Has_Key (Container, Key),
- Post =>
- Length (Container) = Length (Set'Result)
- and Get (Set'Result, Key) = New_Item
- and Same_Keys (Container, Set'Result)
- and Elements_Equal_Except (Container, Set'Result, Key);
-
- ------------------------------
- -- Handling of Equivalence --
- ------------------------------
-
- -- These functions are used to specify that Get returns the same value on
- -- equivalent keys. They should not be used directly in user code.
-
- function Has_Witness (Container : Map; Witness : Count_Type) return Boolean
- with
- Ghost,
- Global => null;
- -- Returns True if there is a key with witness Witness in Container
-
- function Witness (Container : Map; Key : Key_Type) return Count_Type with
- -- Returns the witness of Key in Container
-
- Ghost,
- Global => null,
- Pre => Has_Key (Container, Key),
- Post => Has_Witness (Container, Witness'Result);
-
- function W_Get (Container : Map; Witness : Count_Type) return Element_Type
- with
- -- Returns the element associated with a witness in Container
-
- Ghost,
- Global => null,
- Pre => Has_Witness (Container, Witness);
-
- function Copy_Key (Key : Key_Type) return Key_Type is (Key);
- function Copy_Element (Item : Element_Type) return Element_Type is (Item);
- -- Elements and Keys of maps are copied by numerous primitives in this
- -- package. This function causes GNATprove to verify that such a copy is
- -- valid (in particular, it does not break the ownership policy of SPARK,
- -- i.e. it does not contain pointers that could be used to alias mutable
- -- data).
-
- ---------------------------
- -- Iteration Primitives --
- ---------------------------
-
- type Private_Key is private;
-
- function Iter_First (Container : Map) return Private_Key with
- Global => null;
-
- function Iter_Has_Element
- (Container : Map;
- Key : Private_Key) return Boolean
- with
- Global => null;
-
- function Iter_Next (Container : Map; Key : Private_Key) return Private_Key
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Key);
-
- function Iter_Element (Container : Map; Key : Private_Key) return Key_Type
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Key);
- pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Has_Key);
-
-private
-
- pragma SPARK_Mode (Off);
-
- function "="
- (Left : Key_Type;
- Right : Key_Type) return Boolean renames Equivalent_Keys;
-
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- package Element_Containers is new Ada.Containers.Functional_Base
- (Element_Type => Element_Type,
- Index_Type => Positive_Count_Type);
-
- package Key_Containers is new Ada.Containers.Functional_Base
- (Element_Type => Key_Type,
- Index_Type => Positive_Count_Type);
-
- type Map is record
- Keys : Key_Containers.Container;
- Elements : Element_Containers.Container;
- end record;
-
- type Private_Key is new Count_Type;
-
- function Iter_First (Container : Map) return Private_Key is (1);
-
- function Iter_Has_Element
- (Container : Map;
- Key : Private_Key) return Boolean
- is
- (Count_Type (Key) in 1 .. Key_Containers.Length (Container.Keys));
-
- function Iter_Next
- (Container : Map;
- Key : Private_Key) return Private_Key
- is
- (if Key = Private_Key'Last then 0 else Key + 1);
+package Ada.Containers.Functional_Maps with SPARK_Mode is
- function Iter_Element
- (Container : Map;
- Key : Private_Key) return Key_Type
- is
- (Key_Containers.Get (Container.Keys, Count_Type (Key)));
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Functional_Maps;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_SETS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2016-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-pragma Ada_2012;
-
-package body Ada.Containers.Functional_Sets with SPARK_Mode => Off is
- use Containers;
-
- package Conversions is new Signed_Conversions (Int => Count_Type);
- use Conversions;
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Set; Right : Set) return Boolean is
- (Left.Content <= Right.Content and Right.Content <= Left.Content);
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (Left : Set; Right : Set) return Boolean is
- (Left.Content <= Right.Content);
-
- ---------
- -- Add --
- ---------
-
- function Add (Container : Set; Item : Element_Type) return Set is
- (Content =>
- Add (Container.Content, Length (Container.Content) + 1, Item));
-
- --------------
- -- Contains --
- --------------
-
- function Contains (Container : Set; Item : Element_Type) return Boolean is
- (Find (Container.Content, Item) > 0);
-
- ---------------
- -- Empty_Set --
- ---------------
-
- function Empty_Set return Set is
- ((others => <>));
-
- ---------------------
- -- Included_Except --
- ---------------------
-
- function Included_Except
- (Left : Set;
- Right : Set;
- Item : Element_Type) return Boolean
- is
- (for all E of Left =>
- Equivalent_Elements (E, Item) or Contains (Right, E));
-
- -----------------------
- -- Included_In_Union --
- -----------------------
-
- function Included_In_Union
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- is
- (for all Item of Container =>
- Contains (Left, Item) or Contains (Right, Item));
-
- ---------------------------
- -- Includes_Intersection --
- ---------------------------
-
- function Includes_Intersection
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- is
- (for all Item of Left =>
- (if Contains (Right, Item) then Contains (Container, Item)));
-
- ------------------
- -- Intersection --
- ------------------
-
- function Intersection (Left : Set; Right : Set) return Set is
- (Content => Intersection (Left.Content, Right.Content));
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Set) return Boolean is
- (Length (Container.Content) = 0);
-
- ------------------
- -- Is_Singleton --
- ------------------
-
- function Is_Singleton
- (Container : Set;
- New_Item : Element_Type) return Boolean
- is
- (Length (Container.Content) = 1
- and New_Item = Get (Container.Content, 1));
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Set) return Big_Natural is
- (To_Big_Integer (Length (Container.Content)));
-
- -----------------
- -- Not_In_Both --
- -----------------
-
- function Not_In_Both
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- is
- (for all Item of Container =>
- not Contains (Right, Item) or not Contains (Left, Item));
-
- ----------------
- -- No_Overlap --
- ----------------
-
- function No_Overlap (Left : Set; Right : Set) return Boolean is
- (Num_Overlaps (Left.Content, Right.Content) = 0);
-
- ------------------
- -- Num_Overlaps --
- ------------------
-
- function Num_Overlaps (Left : Set; Right : Set) return Big_Natural is
- (To_Big_Integer (Num_Overlaps (Left.Content, Right.Content)));
-
- ------------
- -- Remove --
- ------------
-
- function Remove (Container : Set; Item : Element_Type) return Set is
- (Content => Remove (Container.Content, Find (Container.Content, Item)));
-
- -----------
- -- Union --
- -----------
-
- function Union (Left : Set; Right : Set) return Set is
- (Content => Union (Left.Content, Right.Content));
-
-end Ada.Containers.Functional_Sets;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-pragma Ada_2012;
-private with Ada.Containers.Functional_Base;
-
-with Ada.Numerics.Big_Numbers.Big_Integers;
-use Ada.Numerics.Big_Numbers.Big_Integers;
-
generic
- type Element_Type (<>) is private;
-
- with function Equivalent_Elements
- (Left : Element_Type;
- Right : Element_Type) return Boolean is "=";
-
- Enable_Handling_Of_Equivalence : Boolean := True;
- -- This constant should only be set to False when no particular handling
- -- of equivalence over elements is needed, that is, Equivalent_Elements
- -- defines an element uniquely.
-
-package Ada.Containers.Functional_Sets with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- type Set is private with
- Default_Initial_Condition => Is_Empty (Set),
- Iterable => (First => Iter_First,
- Next => Iter_Next,
- Has_Element => Iter_Has_Element,
- Element => Iter_Element);
- -- Sets are empty when default initialized.
- -- "For in" quantification over sets should not be used.
- -- "For of" quantification over sets iterates over elements.
- -- Note that, for proof, "for of" quantification is understood modulo
- -- equivalence (the range of quantification comprises all the elements that
- -- are equivalent to any element of the set).
-
- -----------------------
- -- Basic operations --
- -----------------------
-
- -- Sets are axiomatized using Contains, which encodes whether an element is
- -- contained in a set. The length of a set is also added to protect Add
- -- against overflows but it is not actually modeled.
-
- function Contains (Container : Set; Item : Element_Type) return Boolean with
- -- Return True if Item is contained in Container
-
- Global => null,
- Post =>
- (if Enable_Handling_Of_Equivalence then
-
- -- Contains returns the same result on all equivalent elements
-
- (if (for some E of Container => Equivalent_Elements (E, Item)) then
- Contains'Result));
-
- function Length (Container : Set) return Big_Natural with
- Global => null;
- -- Return the number of elements in Container
-
- ------------------------
- -- Property Functions --
- ------------------------
-
- function "<=" (Left : Set; Right : Set) return Boolean with
- -- Set inclusion
-
- Global => null,
- Post => "<="'Result = (for all Item of Left => Contains (Right, Item));
-
- function "=" (Left : Set; Right : Set) return Boolean with
- -- Extensional equality over sets
-
- Global => null,
- Post => "="'Result = (Left <= Right and Right <= Left);
-
- pragma Warnings (Off, "unused variable ""Item""");
- function Is_Empty (Container : Set) return Boolean with
- -- A set is empty if it contains no element
-
- Global => null,
- Post =>
- Is_Empty'Result = (for all Item of Container => False)
- and Is_Empty'Result = (Length (Container) = 0);
- pragma Warnings (On, "unused variable ""Item""");
-
- function Included_Except
- (Left : Set;
- Right : Set;
- Item : Element_Type) return Boolean
- -- Return True if Left contains only elements of Right except possibly
- -- Item.
-
- with
- Global => null,
- Post =>
- Included_Except'Result =
- (for all E of Left =>
- Contains (Right, E) or Equivalent_Elements (E, Item));
-
- function Includes_Intersection
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- with
- -- Return True if every element of the intersection of Left and Right is
- -- in Container.
-
- Global => null,
- Post =>
- Includes_Intersection'Result =
- (for all Item of Left =>
- (if Contains (Right, Item) then Contains (Container, Item)));
-
- function Included_In_Union
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- with
- -- Return True if every element of Container is the union of Left and Right
-
- Global => null,
- Post =>
- Included_In_Union'Result =
- (for all Item of Container =>
- Contains (Left, Item) or Contains (Right, Item));
-
- function Is_Singleton
- (Container : Set;
- New_Item : Element_Type) return Boolean
- with
- -- Return True Container only contains New_Item
-
- Global => null,
- Post =>
- Is_Singleton'Result =
- (for all Item of Container => Equivalent_Elements (Item, New_Item));
-
- function Not_In_Both
- (Container : Set;
- Left : Set;
- Right : Set) return Boolean
- -- Return True if there are no elements in Container that are in Left and
- -- Right.
-
- with
- Global => null,
- Post =>
- Not_In_Both'Result =
- (for all Item of Container =>
- not Contains (Left, Item) or not Contains (Right, Item));
-
- function No_Overlap (Left : Set; Right : Set) return Boolean with
- -- Return True if there are no equivalent elements in Left and Right
-
- Global => null,
- Post =>
- No_Overlap'Result =
- (for all Item of Left => not Contains (Right, Item));
-
- function Num_Overlaps (Left : Set; Right : Set) return Big_Natural with
- -- Number of elements that are both in Left and Right
-
- Global => null,
- Post =>
- Num_Overlaps'Result = Length (Intersection (Left, Right))
- and (if Left <= Right then Num_Overlaps'Result = Length (Left)
- else Num_Overlaps'Result < Length (Left))
- and (if Right <= Left then Num_Overlaps'Result = Length (Right)
- else Num_Overlaps'Result < Length (Right))
- and (Num_Overlaps'Result = 0) = No_Overlap (Left, Right);
-
- ----------------------------
- -- Construction Functions --
- ----------------------------
-
- -- For better efficiency of both proofs and execution, avoid using
- -- construction functions in annotations and rather use property functions.
-
- function Add (Container : Set; Item : Element_Type) return Set with
- -- Return a new set containing all the elements of Container plus E
-
- Global => null,
- Pre => not Contains (Container, Item),
- Post =>
- Length (Add'Result) = Length (Container) + 1
- and Contains (Add'Result, Item)
- and Container <= Add'Result
- and Included_Except (Add'Result, Container, Item);
-
- function Empty_Set return Set with
- -- Return a new empty set
-
- Global => null,
- Post => Is_Empty (Empty_Set'Result);
-
- function Remove (Container : Set; Item : Element_Type) return Set with
- -- Return a new set containing all the elements of Container except E
-
- Global => null,
- Pre => Contains (Container, Item),
- Post =>
- Length (Remove'Result) = Length (Container) - 1
- and not Contains (Remove'Result, Item)
- and Remove'Result <= Container
- and Included_Except (Container, Remove'Result, Item);
-
- function Intersection (Left : Set; Right : Set) return Set with
- -- Returns the intersection of Left and Right
-
- Global => null,
- Post =>
- Intersection'Result <= Left
- and Intersection'Result <= Right
- and Includes_Intersection (Intersection'Result, Left, Right);
-
- function Union (Left : Set; Right : Set) return Set with
- -- Returns the union of Left and Right
-
- Global => null,
- Post =>
- Length (Union'Result) =
- Length (Left) - Num_Overlaps (Left, Right) + Length (Right)
- and Left <= Union'Result
- and Right <= Union'Result
- and Included_In_Union (Union'Result, Left, Right);
-
- function Copy_Element (Item : Element_Type) return Element_Type is (Item);
- -- Elements of containers are copied by numerous primitives in this
- -- package. This function causes GNATprove to verify that such a copy is
- -- valid (in particular, it does not break the ownership policy of SPARK,
- -- i.e. it does not contain pointers that could be used to alias mutable
- -- data).
-
- ---------------------------
- -- Iteration Primitives --
- ---------------------------
-
- type Private_Key is private;
-
- function Iter_First (Container : Set) return Private_Key with
- Global => null;
-
- function Iter_Has_Element
- (Container : Set;
- Key : Private_Key) return Boolean
- with
- Global => null;
-
- function Iter_Next
- (Container : Set;
- Key : Private_Key) return Private_Key
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Key);
-
- function Iter_Element
- (Container : Set;
- Key : Private_Key) return Element_Type
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Key);
- pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Contains);
-
-private
-
- pragma SPARK_Mode (Off);
-
- subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
-
- function "="
- (Left : Element_Type;
- Right : Element_Type) return Boolean renames Equivalent_Elements;
-
- package Containers is new Ada.Containers.Functional_Base
- (Element_Type => Element_Type,
- Index_Type => Positive_Count_Type);
-
- type Set is record
- Content : Containers.Container;
- end record;
-
- type Private_Key is new Count_Type;
-
- function Iter_First (Container : Set) return Private_Key is (1);
-
- function Iter_Has_Element
- (Container : Set;
- Key : Private_Key) return Boolean
- is
- (Count_Type (Key) in 1 .. Containers.Length (Container.Content));
-
- function Iter_Next
- (Container : Set;
- Key : Private_Key) return Private_Key
- is
- (if Key = Private_Key'Last then 0 else Key + 1);
+package Ada.Containers.Functional_Sets with SPARK_Mode is
- function Iter_Element
- (Container : Set;
- Key : Private_Key) return Element_Type
- is
- (Containers.Get (Container.Content, Count_Type (Key)));
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Functional_Sets;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- ADA.CONTAINERS.FUNCTIONAL_VECTORS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2016-2022, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
-------------------------------------------------------------------------------
-
-pragma Ada_2012;
-package body Ada.Containers.Functional_Vectors with SPARK_Mode => Off is
- use Containers;
-
- ---------
- -- "<" --
- ---------
-
- function "<" (Left : Sequence; Right : Sequence) return Boolean is
- (Length (Left.Content) < Length (Right.Content)
- and then (for all I in Index_Type'First .. Last (Left) =>
- Get (Left.Content, I) = Get (Right.Content, I)));
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (Left : Sequence; Right : Sequence) return Boolean is
- (Length (Left.Content) <= Length (Right.Content)
- and then (for all I in Index_Type'First .. Last (Left) =>
- Get (Left.Content, I) = Get (Right.Content, I)));
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left : Sequence; Right : Sequence) return Boolean is
- (Left.Content = Right.Content);
-
- ---------
- -- Add --
- ---------
-
- function Add
- (Container : Sequence;
- New_Item : Element_Type) return Sequence
- is
- (Content =>
- Add (Container.Content,
- Index_Type'Val (Index_Type'Pos (Index_Type'First) +
- Length (Container.Content)),
- New_Item));
-
- function Add
- (Container : Sequence;
- Position : Index_Type;
- New_Item : Element_Type) return Sequence
- is
- (Content => Add (Container.Content, Position, New_Item));
-
- --------------------
- -- Constant_Range --
- --------------------
-
- function Constant_Range
- (Container : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Item : Element_Type) return Boolean is
- begin
- for I in Fst .. Lst loop
- if Get (Container.Content, I) /= Item then
- return False;
- end if;
- end loop;
-
- return True;
- end Constant_Range;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (Container : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Item : Element_Type) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if Get (Container.Content, I) = Item then
- return True;
- end if;
- end loop;
-
- return False;
- end Contains;
-
- --------------------
- -- Empty_Sequence --
- --------------------
-
- function Empty_Sequence return Sequence is
- ((others => <>));
-
- ------------------
- -- Equal_Except --
- ------------------
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- Position : Index_Type) return Boolean
- is
- begin
- if Length (Left.Content) /= Length (Right.Content) then
- return False;
- end if;
-
- for I in Index_Type'First .. Last (Left) loop
- if I /= Position
- and then Get (Left.Content, I) /= Get (Right.Content, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Equal_Except;
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- is
- begin
- if Length (Left.Content) /= Length (Right.Content) then
- return False;
- end if;
-
- for I in Index_Type'First .. Last (Left) loop
- if I /= X and then I /= Y
- and then Get (Left.Content, I) /= Get (Right.Content, I)
- then
- return False;
- end if;
- end loop;
-
- return True;
- end Equal_Except;
-
- ---------
- -- Get --
- ---------
-
- function Get (Container : Sequence;
- Position : Extended_Index) return Element_Type
- is
- (Get (Container.Content, Position));
-
- ----------
- -- Last --
- ----------
-
- function Last (Container : Sequence) return Extended_Index is
- (Index_Type'Val
- ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container)));
-
- ------------
- -- Length --
- ------------
-
- function Length (Container : Sequence) return Count_Type is
- (Length (Container.Content));
-
- -----------------
- -- Range_Equal --
- -----------------
-
- function Range_Equal
- (Left : Sequence;
- Right : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if Get (Left, I) /= Get (Right, I) then
- return False;
- end if;
- end loop;
-
- return True;
- end Range_Equal;
-
- -------------------
- -- Range_Shifted --
- -------------------
-
- function Range_Shifted
- (Left : Sequence;
- Right : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Offset : Count_Type'Base) return Boolean
- is
- begin
- for I in Fst .. Lst loop
- if Get (Left, I) /=
- Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset))
- then
- return False;
- end if;
- end loop;
- return True;
- end Range_Shifted;
-
- ------------
- -- Remove --
- ------------
-
- function Remove
- (Container : Sequence;
- Position : Index_Type) return Sequence
- is
- (Content => Remove (Container.Content, Position));
-
- ---------
- -- Set --
- ---------
-
- function Set
- (Container : Sequence;
- Position : Index_Type;
- New_Item : Element_Type) return Sequence
- is
- (Content => Set (Container.Content, Position, New_Item));
-
-end Ada.Containers.Functional_Vectors;
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-pragma Ada_2012;
-private with Ada.Containers.Functional_Base;
-
generic
- type Index_Type is (<>);
- -- To avoid Constraint_Error being raised at run time, Index_Type'Base
- -- should have at least one more element at the low end than Index_Type.
-
- type Element_Type (<>) is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Functional_Vectors with
- SPARK_Mode,
- Annotate => (GNATprove, Always_Return)
-is
-
- subtype Extended_Index is Index_Type'Base range
- Index_Type'Pred (Index_Type'First) .. Index_Type'Last;
- -- Index_Type with one more element at the low end of the range.
- -- This type is never used but it forces GNATprove to check that there is
- -- room for one more element at the low end of Index_Type.
-
- type Sequence is private
- with Default_Initial_Condition => Length (Sequence) = 0,
- Iterable => (First => Iter_First,
- Has_Element => Iter_Has_Element,
- Next => Iter_Next,
- Element => Get);
- -- Sequences are empty when default initialized.
- -- Quantification over sequences can be done using the regular
- -- quantification over its range or directly on its elements with "for of".
-
- -----------------------
- -- Basic operations --
- -----------------------
-
- -- Sequences are axiomatized using Length and Get, providing respectively
- -- the length of a sequence and an accessor to its Nth element:
-
- function Length (Container : Sequence) return Count_Type with
- -- Length of a sequence
-
- Global => null,
- Post =>
- (Index_Type'Pos (Index_Type'First) - 1) + Length'Result <=
- Index_Type'Pos (Index_Type'Last);
-
- function Get
- (Container : Sequence;
- Position : Extended_Index) return Element_Type
- -- Access the Element at position Position in Container
-
- with
- Global => null,
- Pre => Position in Index_Type'First .. Last (Container);
-
- function Last (Container : Sequence) return Extended_Index with
- -- Last index of a sequence
-
- Global => null,
- Post =>
- Last'Result =
- Index_Type'Val ((Index_Type'Pos (Index_Type'First) - 1) +
- Length (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Last);
-
- function First return Extended_Index is (Index_Type'First) with
- Global => null;
- -- First index of a sequence
-
- ------------------------
- -- Property Functions --
- ------------------------
-
- function "=" (Left : Sequence; Right : Sequence) return Boolean with
- -- Extensional equality over sequences
-
- Global => null,
- Post =>
- "="'Result =
- (Length (Left) = Length (Right)
- and then (for all N in Index_Type'First .. Last (Left) =>
- Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "=");
-
- function "<" (Left : Sequence; Right : Sequence) return Boolean with
- -- Left is a strict subsequence of Right
-
- Global => null,
- Post =>
- "<"'Result =
- (Length (Left) < Length (Right)
- and then (for all N in Index_Type'First .. Last (Left) =>
- Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "<");
-
- function "<=" (Left : Sequence; Right : Sequence) return Boolean with
- -- Left is a subsequence of Right
-
- Global => null,
- Post =>
- "<="'Result =
- (Length (Left) <= Length (Right)
- and then (for all N in Index_Type'First .. Last (Left) =>
- Get (Left, N) = Get (Right, N)));
- pragma Annotate (GNATprove, Inline_For_Proof, "<=");
-
- function Contains
- (Container : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Item : Element_Type) return Boolean
- -- Returns True if Item occurs in the range from Fst to Lst of Container
-
- with
- Global => null,
- Pre => Lst <= Last (Container),
- Post =>
- Contains'Result =
- (for some I in Fst .. Lst => Get (Container, I) = Item);
- pragma Annotate (GNATprove, Inline_For_Proof, Contains);
-
- function Constant_Range
- (Container : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Item : Element_Type) return Boolean
- -- Returns True if every element of the range from Fst to Lst of Container
- -- is equal to Item.
-
- with
- Global => null,
- Pre => Lst <= Last (Container),
- Post =>
- Constant_Range'Result =
- (for all I in Fst .. Lst => Get (Container, I) = Item);
- pragma Annotate (GNATprove, Inline_For_Proof, Constant_Range);
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- Position : Index_Type) return Boolean
- -- Returns True is Left and Right are the same except at position Position
-
- with
- Global => null,
- Pre => Position <= Last (Left),
- Post =>
- Equal_Except'Result =
- (Length (Left) = Length (Right)
- and then (for all I in Index_Type'First .. Last (Left) =>
- (if I /= Position then Get (Left, I) = Get (Right, I))));
- pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except);
-
- function Equal_Except
- (Left : Sequence;
- Right : Sequence;
- X : Index_Type;
- Y : Index_Type) return Boolean
- -- Returns True is Left and Right are the same except at positions X and Y
-
- with
- Global => null,
- Pre => X <= Last (Left) and Y <= Last (Left),
- Post =>
- Equal_Except'Result =
- (Length (Left) = Length (Right)
- and then (for all I in Index_Type'First .. Last (Left) =>
- (if I /= X and I /= Y then
- Get (Left, I) = Get (Right, I))));
- pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except);
-
- function Range_Equal
- (Left : Sequence;
- Right : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index) return Boolean
- -- Returns True if the ranges from Fst to Lst contain the same elements in
- -- Left and Right.
-
- with
- Global => null,
- Pre => Lst <= Last (Left) and Lst <= Last (Right),
- Post =>
- Range_Equal'Result =
- (for all I in Fst .. Lst => Get (Left, I) = Get (Right, I));
- pragma Annotate (GNATprove, Inline_For_Proof, Range_Equal);
-
- function Range_Shifted
- (Left : Sequence;
- Right : Sequence;
- Fst : Index_Type;
- Lst : Extended_Index;
- Offset : Count_Type'Base) return Boolean
- -- Returns True if the range from Fst to Lst in Left contains the same
- -- elements as the range from Fst + Offset to Lst + Offset in Right.
-
- with
- Global => null,
- Pre =>
- Lst <= Last (Left)
- and then
- (if Offset < 0 then
- Index_Type'Pos (Index_Type'Base'First) - Offset <=
- Index_Type'Pos (Index_Type'First))
- and then
- (if Fst <= Lst then
- Offset in
- Index_Type'Pos (Index_Type'First) - Index_Type'Pos (Fst) ..
- (Index_Type'Pos (Index_Type'First) - 1) + Length (Right) -
- Index_Type'Pos (Lst)),
- Post =>
- Range_Shifted'Result =
- ((for all I in Fst .. Lst =>
- Get (Left, I) =
- Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset)))
- and
- (for all I in Index_Type'Val (Index_Type'Pos (Fst) + Offset) ..
- Index_Type'Val (Index_Type'Pos (Lst) + Offset)
- =>
- Get (Left, Index_Type'Val (Index_Type'Pos (I) - Offset)) =
- Get (Right, I)));
- pragma Annotate (GNATprove, Inline_For_Proof, Range_Shifted);
-
- ----------------------------
- -- Construction Functions --
- ----------------------------
-
- -- For better efficiency of both proofs and execution, avoid using
- -- construction functions in annotations and rather use property functions.
-
- function Set
- (Container : Sequence;
- Position : Index_Type;
- New_Item : Element_Type) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- except for the one at position Position which is replaced by New_Item.
-
- with
- Global => null,
- Pre => Position in Index_Type'First .. Last (Container),
- Post =>
- Get (Set'Result, Position) = New_Item
- and then Equal_Except (Container, Set'Result, Position);
-
- function Add (Container : Sequence; New_Item : Element_Type) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- plus New_Item at the end.
-
- with
- Global => null,
- Pre =>
- Length (Container) < Count_Type'Last
- and then Last (Container) < Index_Type'Last,
- Post =>
- Length (Add'Result) = Length (Container) + 1
- and then Get (Add'Result, Last (Add'Result)) = New_Item
- and then Container <= Add'Result;
-
- function Add
- (Container : Sequence;
- Position : Index_Type;
- New_Item : Element_Type) return Sequence
- with
- -- Returns a new sequence which contains the same elements as Container
- -- except that New_Item has been inserted at position Position.
-
- Global => null,
- Pre =>
- Length (Container) < Count_Type'Last
- and then Last (Container) < Index_Type'Last
- and then Position <= Extended_Index'Succ (Last (Container)),
- Post =>
- Length (Add'Result) = Length (Container) + 1
- and then Get (Add'Result, Position) = New_Item
- and then Range_Equal
- (Left => Container,
- Right => Add'Result,
- Fst => Index_Type'First,
- Lst => Index_Type'Pred (Position))
- and then Range_Shifted
- (Left => Container,
- Right => Add'Result,
- Fst => Position,
- Lst => Last (Container),
- Offset => 1);
-
- function Remove
- (Container : Sequence;
- Position : Index_Type) return Sequence
- -- Returns a new sequence which contains the same elements as Container
- -- except that the element at position Position has been removed.
-
- with
- Global => null,
- Pre => Position in Index_Type'First .. Last (Container),
- Post =>
- Length (Remove'Result) = Length (Container) - 1
- and then Range_Equal
- (Left => Container,
- Right => Remove'Result,
- Fst => Index_Type'First,
- Lst => Index_Type'Pred (Position))
- and then Range_Shifted
- (Left => Remove'Result,
- Right => Container,
- Fst => Position,
- Lst => Last (Remove'Result),
- Offset => 1);
-
- function Copy_Element (Item : Element_Type) return Element_Type is (Item);
- -- Elements of containers are copied by numerous primitives in this
- -- package. This function causes GNATprove to verify that such a copy is
- -- valid (in particular, it does not break the ownership policy of SPARK,
- -- i.e. it does not contain pointers that could be used to alias mutable
- -- data).
-
- function Empty_Sequence return Sequence with
- -- Return an empty Sequence
-
- Global => null,
- Post => Length (Empty_Sequence'Result) = 0;
-
- ---------------------------
- -- Iteration Primitives --
- ---------------------------
-
- function Iter_First (Container : Sequence) return Extended_Index with
- Global => null;
-
- function Iter_Has_Element
- (Container : Sequence;
- Position : Extended_Index) return Boolean
- with
- Global => null,
- Post =>
- Iter_Has_Element'Result =
- (Position in Index_Type'First .. Last (Container));
- pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element);
-
- function Iter_Next
- (Container : Sequence;
- Position : Extended_Index) return Extended_Index
- with
- Global => null,
- Pre => Iter_Has_Element (Container, Position);
-
-private
-
- pragma SPARK_Mode (Off);
-
- package Containers is new Ada.Containers.Functional_Base
- (Index_Type => Index_Type,
- Element_Type => Element_Type);
-
- type Sequence is record
- Content : Containers.Container;
- end record;
-
- function Iter_First (Container : Sequence) return Extended_Index is
- (Index_Type'First);
-
- function Iter_Next
- (Container : Sequence;
- Position : Extended_Index) return Extended_Index
- is
- (if Position = Extended_Index'Last then
- Extended_Index'First
- else
- Extended_Index'Succ (Position));
+package Ada.Containers.Functional_Vectors with SPARK_Mode is
- function Iter_Has_Element
- (Container : Sequence;
- Position : Extended_Index) return Boolean
- is
- (Position in Index_Type'First ..
- (Index_Type'Val
- ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container))));
+ pragma Compile_Time_Error
+ (True,
+ "This package has been moved to the SPARK library shipped with any"
+ & " SPARK release starting with version 23.");
end Ada.Containers.Functional_Vectors;
+++ /dev/null
--- { dg-do compile }
-
-package body Aspect2 is
- procedure Foo is null;
-end Aspect2;
+++ /dev/null
-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;
+++ /dev/null
--- { 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;
+++ /dev/null
-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;
+++ /dev/null
--- { dg-do compile }
--- { dg-options "-gnata" }
-
-package body Equal8 is
- procedure Foo is null;
-end Equal8;
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
--- { 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;
+++ /dev/null
--- { 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;
+++ /dev/null
-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;
projects / platform / upstream / gcc.git / commitdiff