-2011-08-02 Vincent Celier <celier@adacore.com>
+2011-08-02 Yannick Moy <moy@adacore.com>
+
+ * errout.adb, errout.ads (Check_Formal_Restriction): move procedure
+ from here...
+ * restrict.adb, restrict.ads (Check_Formal_Restriction): ...to here
+ * sem_aggr.adb, sem_ch5.adb, sem_util.adb:
+ Add with/use clauses to make Check_Formal_Restriction visible
+
+2011-08-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Check_Generic_Actuals): handle properly actual
+ in-parameters when type of the generic formal is private in the generic
+ spec and non-private in the body.
+
+2011-08-02 Claire Dross <dross@adacore.com>
- * prj-nmsc.adb (Check_Library_Attributes): For virtual library project,
- inherit library kind.
+ * a-cfdlli.adb, a-cfdlli.ads, a-cfhase.adb, a-cfhase.ads, a-cfhama.adb,
+ a-cfhama.ads, a-cforse.adb, a-cforse.ads, a-cforma.adb, a-cforma.ads,
+ a-cofove.adb, a-cofove.ads: New files implementing formal containers.
+ * impunit.adb, Makefile.rtl: Take new files into account.
2011-08-02 Robert Dewar <dewar@adacore.com>
a-cbdlli$(objext) \
a-cborma$(objext) \
a-cdlili$(objext) \
+ a-cfhama$(objext) \
+ a-cfhase$(objext) \
+ a-cforse$(objext) \
+ a-cfdlli$(objext) \
+ a-cforma$(objext) \
a-cgaaso$(objext) \
a-cgarso$(objext) \
a-cgcaso$(objext) \
a-contai$(objext) \
a-convec$(objext) \
a-cobove$(objext) \
+ a-cofove$(objext) \
a-coorma$(objext) \
a-coormu$(objext) \
a-coorse$(objext) \
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2010, 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 System; use type System.Address;
+
+package body Ada.Containers.Formal_Doubly_Linked_Lists is
+
+ -----------------------
+ -- 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);
+
+ function Copy
+ (Source : Plain_List;
+ Capacity : Count_Type := 0) return PList_Access;
+
+ function Find_Between
+ (Container : Plain_List;
+ Item : Element_Type;
+ From : Count_Type;
+ To : Count_Type;
+ Bg : Count_Type) return Cursor;
+
+ function Element_Unchecked
+ (Container : List;
+ Position : Count_Type) return Element_Type;
+
+ procedure Free
+ (Container : in out Plain_List;
+ X : Count_Type);
+
+ function Has_Element_Base
+ (Container : Plain_List;
+ Position : Cursor) return Boolean;
+
+ procedure Insert_Internal
+ (Container : in out List;
+ Before : Count_Type;
+ New_Node : Count_Type);
+
+ procedure Iterate_Between
+ (Container : List;
+ From : Count_Type;
+ To : Count_Type;
+ Process :
+ not null access procedure (Container : List; Position : Cursor));
+
+ function Next_Unchecked
+ (Container : List;
+ Position : Count_Type) return Count_Type;
+
+ procedure Query_Element_Plain
+ (Container : Plain_List; Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ function Reverse_Find_Between
+ (Container : Plain_List;
+ Item : Element_Type;
+ From : Count_Type;
+ To : Count_Type) return Cursor;
+
+ procedure Reverse_Iterate_Between
+ (Container : List;
+ From : Count_Type;
+ To : Count_Type;
+ Process :
+ not null access procedure (Container : List; Position : Cursor));
+
+ function Vet (L : List; Position : Cursor) return Boolean;
+
+ procedure Write_Between
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Plain_List;
+ Length : Count_Type;
+ From : Count_Type;
+ To : Count_Type);
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : List) return Boolean is
+ LI, 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 Element_Unchecked (Left, LI) /= Element_Unchecked (Right, LI) then
+ return False;
+ end if;
+
+ LI := Next_Unchecked (Left, LI);
+ RI := Next_Unchecked (Right, RI);
+ end loop;
+
+ return True;
+ end "=";
+
+ --------------
+ -- Allocate --
+ --------------
+
+ procedure Allocate
+ (Container : in out List;
+ New_Item : Element_Type;
+ New_Node : out Count_Type)
+ is
+ ContainerP : Plain_List renames Container.Plain.all;
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ N : Node_Array renames Container.Plain.all.Nodes;
+
+ begin
+ if ContainerP.Free >= 0 then
+ New_Node := ContainerP.Free;
+ N (New_Node).Element := New_Item;
+ ContainerP.Free := N (New_Node).Next;
+
+ else
+ New_Node := abs ContainerP.Free;
+ N (New_Node).Element := New_Item;
+ ContainerP.Free := ContainerP.Free - 1;
+ end if;
+ end;
+ end Allocate;
+
+ procedure Allocate
+ (Container : in out List;
+ New_Node : out Count_Type)
+ is
+ ContainerP : Plain_List renames Container.Plain.all;
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ N : Node_Array renames ContainerP.Nodes;
+
+ begin
+ if ContainerP.Free >= 0 then
+ New_Node := ContainerP.Free;
+ ContainerP.Free := N (New_Node).Next;
+
+ else
+ New_Node := abs ContainerP.Free;
+ ContainerP.Free := ContainerP.Free - 1;
+ end if;
+ end;
+ end Allocate;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ begin
+ Insert (Container, No_Element, New_Item, Count);
+ end Append;
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out List; Source : List) is
+ begin
+ if Target.K /= Plain or Source.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ N : Node_Array renames Source.Plain.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);
+ J := N (J).Next;
+ end loop;
+ end;
+ end Assign;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out List) is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error;
+ end if;
+
+ declare
+ N : Node_Array renames Container.Plain.Nodes;
+ X : Count_Type;
+
+ begin
+ if Container.Length = 0 then
+ pragma Assert (Container.First = 0);
+ pragma Assert (Container.Last = 0);
+ pragma Assert (Container.Plain.Busy = 0);
+ pragma Assert (Container.Plain.Lock = 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);
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
+
+ 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.Plain.all, X);
+ end loop;
+
+ X := Container.First;
+
+ Container.First := 0;
+ Container.Last := 0;
+ Container.Length := 0;
+
+ Free (Container.Plain.all, X);
+ end;
+ end Clear;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains
+ (Container : List;
+ Item : Element_Type) return Boolean
+ is
+ begin
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy
+ (Source : Plain_List;
+ Capacity : Count_Type := 0) return PList_Access
+ is
+ C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity);
+ P : PList_Access;
+ N : Count_Type := 1;
+ begin
+ P := new Plain_List (C);
+ 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;
+ if P.Free >= 0 then
+ N := Source.Capacity + 1;
+ while N <= C loop
+ Free (P.all, N);
+ N := N + 1;
+ end loop;
+ end if;
+ return P;
+ end Copy;
+
+ function Copy
+ (Source : List;
+ Capacity : Count_Type := 0) return List
+ is
+ Cap : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity);
+ begin
+ case Source.K is
+ when Plain =>
+ return (Capacity => Cap,
+ Length => Source.Length,
+ Plain => Copy (Source.Plain.all, Cap),
+ First => Source.First,
+ Last => Source.Last,
+ others => <>);
+ when Part =>
+ declare
+ Target : List (Capacity => Cap);
+ C : Cursor;
+ P : Cursor;
+ begin
+ Target := (Capacity => Cap,
+ Length => Source.Part.LLength,
+ Plain => Copy (Source.Plain.all, Cap),
+ First => Source.Part.LFirst,
+ Last => Source.Part.LLast,
+ others => <>);
+ C := (Node => Target.First);
+ while C.Node /= Source.First loop
+ P := Next (Target, C);
+ Delete (Container => Target, Position => C);
+ C := P;
+ end loop;
+ if Source.Last /= 0 then
+ C := (Node => Source.Plain.all.Nodes (Source.Last).Next);
+ while C.Node /= 0 loop
+ P := Next (Target, C);
+ Delete (Container => Target, Position => C);
+ C := P;
+ end loop;
+ end if;
+ return Target;
+ end;
+ end case;
+ end Copy;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete
+ (Container : in out List;
+ Position : in out Cursor;
+ Count : Count_Type := 1)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ N : Node_Array renames Container.Plain.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;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ 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.Plain.all, 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.Plain.all, X);
+ end loop;
+ Position := No_Element;
+ end;
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First
+ (Container : in out List;
+ Count : Count_Type := 1)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ N : Node_Array renames Container.Plain.Nodes;
+ X : Count_Type;
+
+ begin
+ if Count >= Container.Length then
+ Clear (Container);
+ return;
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
+
+ for I 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.Plain.all, X);
+ end loop;
+ end;
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last
+ (Container : in out List;
+ Count : Count_Type := 1)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ N : Node_Array renames Container.Plain.Nodes;
+ X : Count_Type;
+
+ begin
+ if Count >= Container.Length then
+ Clear (Container);
+ return;
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
+
+ for I 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.Plain.all, X);
+ end loop;
+ end;
+ end Delete_Last;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element_Unchecked
+ (Container : List;
+ Position : Count_Type) return Element_Type is
+ begin
+ case Container.K is
+ when Plain =>
+ return Container.Plain.Nodes (Position).Element;
+ when others =>
+ return Container.Plain.all.Nodes (Position).Element;
+ end case;
+ end Element_Unchecked;
+
+ 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 Element_Unchecked (Container => Container,
+ Position => Position.Node);
+ end Element;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find_Between
+ (Container : Plain_List;
+ Item : Element_Type;
+ From : Count_Type;
+ To : Count_Type;
+ Bg : Count_Type) return Cursor
+ is
+ Nodes : Node_Array renames Container.Nodes;
+ Node : Count_Type := Bg;
+ begin
+ while Node /= From loop
+ if Node = 0 or else Node = To then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ Node := Nodes (Node).Next;
+ end loop;
+ while Node /= Nodes (To).Next loop
+ if Nodes (Node).Element = Item then
+ return (Node => Node);
+ end if;
+ Node := Nodes (Node).Next;
+ end loop;
+
+ return No_Element;
+ end Find_Between;
+
+ 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_Base (Container.Plain.all, Position) then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ return Find_Between (Container => Container.Plain.all,
+ Item => Item,
+ From => From,
+ To => Container.Last,
+ Bg => Container.First);
+ 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 Element_Unchecked (Container, F);
+ end if;
+ end First_Element;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free
+ (Container : in out Plain_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 I in Container.Free .. Container.Capacity - 1 loop
+ N (I).Next := I + 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 is
+
+ ---------------
+ -- Is_Sorted --
+ ---------------
+
+ function Is_Sorted (Container : List) return Boolean is
+ Nodes : Node_Array renames Container.Plain.all.Nodes;
+ Node : Count_Type := Container.First;
+ begin
+ for I in 2 .. Container.Length loop
+ if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
+ return False;
+ end if;
+
+ Node := Nodes (Node).Next;
+ end loop;
+
+ return True;
+ end Is_Sorted;
+
+ -----------
+ -- Merge --
+ -----------
+
+ procedure Merge
+ (Target : in out List;
+ Source : in out List)
+ is
+ begin
+ if Target.K /= Plain or Source.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ LN : Node_Array renames Target.Plain.Nodes;
+ RN : Node_Array renames Source.Plain.Nodes;
+ LI : Cursor;
+ RI : Cursor;
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Target (list is busy)";
+ end if;
+
+ if Source.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Source (list is busy)";
+ 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;
+ end Merge;
+
+ ----------
+ -- Sort --
+ ----------
+
+ procedure Sort (Container : in out List) is
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ N : Node_Array renames Container.Plain.Nodes;
+
+ procedure Partition (Pivot, Back : Count_Type);
+ procedure Sort (Front, Back : Count_Type);
+
+ ---------------
+ -- Partition --
+ ---------------
+
+ procedure Partition (Pivot, Back : Count_Type) is
+ Node : Count_Type := N (Pivot).Next;
+
+ begin
+ while Node /= Back loop
+ if N (Node).Element < N (Pivot).Element then
+ declare
+ Prev : constant Count_Type := N (Node).Prev;
+ Next : constant Count_Type := N (Node).Next;
+
+ begin
+ N (Prev).Next := Next;
+
+ if Next = 0 then
+ Container.Last := Prev;
+ else
+ N (Next).Prev := Prev;
+ end if;
+
+ N (Node).Next := Pivot;
+ N (Node).Prev := N (Pivot).Prev;
+
+ N (Pivot).Prev := Node;
+
+ if N (Node).Prev = 0 then
+ Container.First := Node;
+ else
+ N (N (Node).Prev).Next := Node;
+ end if;
+
+ Node := Next;
+ end;
+
+ else
+ Node := N (Node).Next;
+ end if;
+ end loop;
+ end Partition;
+
+ ----------
+ -- Sort --
+ ----------
+
+ procedure Sort (Front, Back : Count_Type) is
+ Pivot : Count_Type;
+
+ begin
+ if Front = 0 then
+ Pivot := Container.First;
+ else
+ Pivot := N (Front).Next;
+ end if;
+
+ if Pivot /= Back then
+ Partition (Pivot, Back);
+ Sort (Front, Pivot);
+ Sort (Pivot, Back);
+ end if;
+ end Sort;
+
+ -- Start of processing for Sort
+
+ begin
+ if Container.Length <= 1 then
+ return;
+ end if;
+
+ pragma Assert (N (Container.First).Prev = 0);
+ pragma Assert (N (Container.Last).Next = 0);
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
+
+ Sort (Front => 0, Back => 0);
+
+ pragma Assert (N (Container.First).Prev = 0);
+ pragma Assert (N (Container.Last).Next = 0);
+ end;
+ end Sort;
+
+ end Generic_Sorting;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element_Base (Container : Plain_List; Position : Cursor)
+ return Boolean
+ is
+ begin
+ return Container.Nodes (Position.Node).Prev /= -1;
+ end Has_Element_Base;
+
+ function Has_Element (Container : List; Position : Cursor) return Boolean is
+ begin
+ if Position.Node = 0 then
+ return False;
+ end if;
+
+ case Container.K is
+ when Plain =>
+ return Container.Plain.Nodes (Position.Node).Prev /= -1;
+ when Part =>
+ declare
+ Current : Count_Type := Container.First;
+ begin
+ if Container.Plain.Nodes (Position.Node).Prev = -1 then
+ return False;
+ end if;
+ while Current /= 0 loop
+ if Current = Position.Node then
+ return True;
+ end if;
+ Current := Next_Unchecked (Container, Current);
+ end loop;
+ return False;
+ end;
+ end case;
+ end Has_Element;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ J : Count_Type;
+
+ begin
+
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ if Before.Node /= 0 then
+ null;
+ 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;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ 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;
+ Count : Count_Type := 1)
+ is
+ Position : Cursor;
+
+ begin
+ Insert (Container, Before, New_Item, Position, Count);
+ end Insert;
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ J : Count_Type;
+
+ begin
+
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ if Before.Node /= 0 then
+ null;
+ 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;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
+
+ Allocate (Container, New_Node => J);
+ Insert_Internal (Container, Before.Node, New_Node => J);
+ Position := (Node => J);
+
+ for Index in 2 .. Count loop
+ Allocate (Container, New_Node => J);
+ Insert_Internal (Container, Before.Node, New_Node => J);
+ end loop;
+ end Insert;
+
+ ---------------------
+ -- Insert_Internal --
+ ---------------------
+
+ procedure Insert_Internal
+ (Container : in out List;
+ Before : Count_Type;
+ New_Node : Count_Type)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ N : Node_Array renames Container.Plain.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;
+ end Insert_Internal;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : List) return Boolean is
+ begin
+ return Length (Container) = 0;
+ end Is_Empty;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate_Between
+ (Container : List;
+ From : Count_Type;
+ To : Count_Type;
+ Process :
+ not null access procedure (Container : List; Position : Cursor))
+ is
+ C : Plain_List renames Container.Plain.all;
+ N : Node_Array renames C.Nodes;
+ B : Natural renames C.Busy;
+
+ Node : Count_Type := From;
+
+ begin
+ B := B + 1;
+
+ begin
+ while Node /= N (To).Next loop
+ pragma Assert (N (Node).Prev >= 0);
+ Process (Container, Position => (Node => Node));
+ Node := N (Node).Next;
+ end loop;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Iterate_Between;
+
+ procedure Iterate
+ (Container : List;
+ Process :
+ not null access procedure (Container : List; Position : Cursor))
+ is
+ begin
+ if Container.Length = 0 then
+ return;
+ end if;
+ Iterate_Between (Container, Container.First, Container.Last, Process);
+ end Iterate;
+
+ ----------
+ -- 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 Element_Unchecked (Container, L);
+ end if;
+ end Last_Element;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Container : List; Position : Cursor) return List is
+ L : Count_Type := 0;
+ C : Count_Type := Container.First;
+ LLe : Count_Type;
+ LF : Count_Type;
+ LLa : Count_Type;
+ begin
+ case Container.K is
+ when Plain =>
+ LLe := Container.Length;
+ LF := Container.First;
+ LLa := Container.Last;
+ when Part =>
+ LLe := Container.Part.LLength;
+ LF := Container.Part.LFirst;
+ LLa := Container.Part.LLast;
+ end case;
+ if Position.Node = 0 then
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Length => Container.Length,
+ First => Container.First,
+ Last => Container.Last,
+ Plain => Container.Plain,
+ Part => (LLength => LLe, LFirst => LF, LLast => LLa));
+ else
+ while C /= Position.Node loop
+ if C = Container.Last or C = 0 then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ C := Next_Unchecked (Container, C);
+ L := L + 1;
+ end loop;
+ if L = 0 then
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Length => 0,
+ First => 0,
+ Last => 0,
+ Plain => Container.Plain,
+ Part => (LLength => LLe, LFirst => LF, LLast => LLa));
+ else
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Length => L,
+ First => Container.First,
+ Last => Container.Plain.Nodes (C).Prev,
+ Plain => Container.Plain,
+ Part => (LLength => LLe, LFirst => LF, LLast => LLa));
+ end if;
+ end if;
+ end Left;
+
+ ------------
+ -- 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
+ begin
+ if Target.K /= Plain or Source.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+
+ N : Node_Array renames Source.Plain.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;
+
+ if Source.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Source (list is busy)";
+ end if;
+
+ Clear (Target);
+
+ while Source.Length > 0 loop
+ X := Source.First;
+ Append (Target, N (X).Element); -- optimize away???
+
+ Source.First := N (X).Next;
+ N (Source.First).Prev := 0;
+
+ Source.Length := Source.Length - 1;
+ Free (Source.Plain.all, X);
+ end loop;
+ end;
+ 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 => Next_Unchecked (Container, Position.Node));
+ end Next;
+
+ function Next_Unchecked (Container : List; Position : Count_Type)
+ return Count_Type
+ is
+ begin
+ case Container.K is
+ when Plain =>
+ return Container.Plain.Nodes (Position).Next;
+ when Part =>
+ if Position = Container.Last then
+ return 0;
+ else
+ return Container.Plain.Nodes (Position).Next;
+ end if;
+ end case;
+ end Next_Unchecked;
+
+ -------------
+ -- Prepend --
+ -------------
+
+ procedure Prepend
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ 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;
+
+ case Container.K is
+ when Plain =>
+ return (Node => Container.Plain.Nodes (Position.Node).Prev);
+ when Part =>
+ if Container.First = Position.Node then
+ return No_Element;
+ else
+ return (Node => Container.Plain.Nodes (Position.Node).Prev);
+ end if;
+ end case;
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element_Plain
+ (Container : Plain_List; Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ C : Plain_List renames Container'Unrestricted_Access.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ declare
+ N : Node_Type renames C.Nodes (Position.Node);
+ begin
+ Process (N.Element);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end Query_Element_Plain;
+
+ procedure Query_Element
+ (Container : List; Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ Query_Element_Plain (Container.Plain.all, Position, Process);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out List)
+ is
+ N : Count_Type'Base;
+
+ begin
+ Clear (Item);
+
+ Count_Type'Base'Read (Stream, N);
+
+ if N < 0 then
+ raise Program_Error with "bad list length";
+ end if;
+
+ if N = 0 then
+ return;
+ end if;
+
+ if N > Item.Capacity then
+ raise Constraint_Error with "length exceeds capacity";
+ end if;
+
+ for J in 1 .. N loop
+ Item.Append (Element_Type'Input (Stream)); -- ???
+ end loop;
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream list cursor";
+ end Read;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Container : in out List;
+ Position : Cursor;
+ New_Item : Element_Type)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Container.Plain.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (list is locked)";
+ end if;
+
+ pragma Assert (Vet (Container, Position),
+ "bad cursor in Replace_Element");
+
+ declare
+ N : Node_Array renames Container.Plain.Nodes;
+ begin
+ N (Position.Node).Element := New_Item;
+ end;
+ end Replace_Element;
+
+ ----------------------
+ -- Reverse_Elements --
+ ----------------------
+
+ procedure Reverse_Elements (Container : in out List) is
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ N : Node_Array renames Container.Plain.Nodes;
+ I : Count_Type := Container.First;
+ J : Count_Type := Container.Last;
+
+ procedure Swap (L, R : Count_Type);
+
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap (L, 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);
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
+
+ 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;
+ end Reverse_Elements;
+
+ ------------------
+ -- Reverse_Find --
+ ------------------
+
+ function Reverse_Find_Between
+ (Container : Plain_List;
+ Item : Element_Type;
+ From : Count_Type;
+ To : Count_Type) return Cursor
+ is
+ Nodes : Node_Array renames Container.Nodes;
+ Node : Count_Type := To;
+ begin
+ while Node /= Nodes (From).Prev loop
+ if Nodes (Node).Element = Item then
+ return (Node => Node);
+ end if;
+ Node := Nodes (Node).Prev;
+ end loop;
+
+ return No_Element;
+ end Reverse_Find_Between;
+
+ 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.First;
+ end if;
+
+ if Container.Length = 0 then
+ return No_Element;
+ end if;
+ return Reverse_Find_Between (Container => Container.Plain.all,
+ Item => Item,
+ From => CFirst,
+ To => Container.Last);
+ end Reverse_Find;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate_Between
+ (Container : List;
+ From : Count_Type;
+ To : Count_Type;
+ Process :
+ not null access procedure (Container : List; Position : Cursor))
+ is
+ C : Plain_List renames Container.Plain.all;
+ N : Node_Array renames C.Nodes;
+ B : Natural renames C.Busy;
+
+ Node : Count_Type := To;
+
+ begin
+ B := B + 1;
+
+ begin
+ while Node /= N (From).Prev loop
+ pragma Assert (N (Node).Prev >= 0);
+ Process (Container, Position => (Node => Node));
+ Node := N (Node).Prev;
+ end loop;
+
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Reverse_Iterate_Between;
+
+ procedure Reverse_Iterate
+ (Container : List;
+ Process :
+ not null access procedure (Container : List; Position : Cursor))
+ is
+ begin
+ if Container.Length = 0 then
+ return;
+ end if;
+ Reverse_Iterate_Between
+ (Container, Container.First, Container.Last, Process);
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Container : List; Position : Cursor) return List is
+ L : Count_Type := 0;
+ C : Count_Type := Container.First;
+ LLe : Count_Type;
+ LF : Count_Type;
+ LLa : Count_Type;
+ begin
+ case Container.K is
+ when Plain =>
+ LLe := Container.Length;
+ LF := Container.First;
+ LLa := Container.Last;
+ when Part =>
+ LLe := Container.Part.LLength;
+ LF := Container.Part.LFirst;
+ LLa := Container.Part.LLast;
+ end case;
+ if Position.Node = 0 then
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Length => 0,
+ First => 0,
+ Last => 0,
+ Plain => Container.Plain,
+ Part => (LLength => LLe, LFirst => LF, LLast => LLa));
+ else
+ while C /= Position.Node loop
+ if C = Container.Last or C = 0 then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ C := Next_Unchecked (Container, C);
+ L := L + 1;
+ end loop;
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Length => Container.Length - L,
+ First => Position.Node,
+ Last => Container.Last,
+ Plain => Container.Plain,
+ Part => (LLength => LLe, LFirst => LF, LLast => LLa));
+ end if;
+ end Right;
+
+ ------------
+ -- Splice --
+ ------------
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Source : in out List)
+ is
+ begin
+ if Target.K /= Plain or Source.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ SN : Node_Array renames Source.Plain.Nodes;
+
+ begin
+ if Before.Node /= 0 then
+ null;
+ pragma Assert (Vet (Target, Before), "bad cursor in Splice");
+ end if;
+
+ if Target'Address = Source'Address
+ or else Source.Length = 0
+ then
+ return;
+ 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;
+
+ if Target.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Target (list is busy)";
+ end if;
+
+ if Source.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Source (list is busy)";
+ end if;
+
+ loop
+ Insert (Target, Before, SN (Source.Last).Element);
+ Delete_Last (Source);
+ exit when Is_Empty (Source);
+ end loop;
+ end;
+ 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.K /= Plain or Source.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ if Target'Address = Source'Address then
+ Splice (Target, Before, Position);
+ return;
+ 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;
+
+ if Target.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Target (list is busy)";
+ end if;
+
+ if Source.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Source (list is busy)";
+ end if;
+
+ Insert
+ (Container => Target,
+ Before => Before,
+ New_Item => Source.Plain.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
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ N : Node_Array renames Container.Plain.Nodes;
+
+ begin
+ if Before.Node /= 0 then
+ null;
+ 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 Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ end if;
+
+ 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;
+ end Splice;
+
+ ------------------
+ -- Strict_Equal --
+ ------------------
+
+ function Strict_Equal (Left, Right : List) return Boolean is
+ CL : Count_Type := Left.First;
+ CR : Count_Type := Right.First;
+ begin
+ while CL /= 0 or CR /= 0 loop
+ if CL /= CR or else
+ Element_Unchecked (Left, CL) /= Element_Unchecked (Right, CL) then
+ return False;
+ end if;
+ CL := Next_Unchecked (Left, CL);
+ CR := Next_Unchecked (Right, CR);
+ end loop;
+ return True;
+ end Strict_Equal;
+
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap
+ (Container : in out List;
+ I, J : Cursor)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ 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;
+
+ if Container.Plain.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (list is locked)";
+ 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.Plain.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, J : Cursor)
+ is
+ I_Next, J_Next : Cursor;
+
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ 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;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (list is busy)";
+ 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;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Container : in out List;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ if Container.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ if Position.Node = 0 then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ pragma Assert (Vet (Container, Position),
+ "bad cursor in Update_Element");
+
+ declare
+ B : Natural renames Container.Plain.Busy;
+ L : Natural renames Container.Plain.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ declare
+ N : Node_Type renames Container.Plain.Nodes (Position.Node);
+ begin
+ Process (N.Element);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Update_Element;
+
+ ---------
+ -- Vet --
+ ---------
+
+ function Vet (L : List; Position : Cursor) return Boolean is
+ begin
+ if L.K /= Plain then
+ raise Program_Error with "cannot modify part of container";
+ end if;
+
+ declare
+ N : Node_Array renames L.Plain.Nodes;
+
+ begin
+ 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;
+ end Vet;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write_Between
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Plain_List;
+ Length : Count_Type;
+ From : Count_Type;
+ To : Count_Type) is
+
+ N : Node_Array renames Item.Nodes;
+ Node : Count_Type;
+
+ begin
+ Count_Type'Base'Write (Stream, Length);
+
+ Node := From;
+ while Node /= N (To).Next loop
+ Element_Type'Write (Stream, N (Node).Element);
+ Node := N (Node).Next;
+ end loop;
+ end Write_Between;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : List)
+ is
+ begin
+ Write_Between
+ (Stream, Item.Plain.all, Item.Length, Item.First, Item.Last);
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream list cursor";
+ end Write;
+
+end Ada.Containers.Formal_Doubly_Linked_Lists;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2010, 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/>. --
+------------------------------------------------------------------------------
+
+private with Ada.Streams;
+with Ada.Containers; use Ada.Containers;
+
+generic
+ type Element_Type is private;
+
+ with function "=" (Left, Right : Element_Type)
+ return Boolean is <>;
+
+package Ada.Containers.Formal_Doubly_Linked_Lists is
+ pragma Pure;
+
+ type List (Capacity : Count_Type) is tagged private;
+ -- pragma Preelaborable_Initialization (List);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_List : constant List;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : List) return Boolean;
+
+ function Length (Container : List) return Count_Type;
+
+ function Is_Empty (Container : List) return Boolean;
+
+ procedure Clear (Container : in out List);
+
+ procedure Assign (Target : in out List; Source : List);
+
+ function Copy (Source : List; Capacity : Count_Type := 0) return List;
+
+ function Element (Container : List; Position : Cursor) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out List;
+ Position : Cursor;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Container : List; Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Update_Element
+ (Container : in out List;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Move (Target : in out List; Source : in out List);
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out List;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Prepend
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Append
+ (Container : in out List;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Delete
+ (Container : in out List;
+ Position : in out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Delete_First
+ (Container : in out List;
+ Count : Count_Type := 1);
+
+ procedure Delete_Last
+ (Container : in out List;
+ Count : Count_Type := 1);
+
+ procedure Reverse_Elements (Container : in out List);
+
+ procedure Swap
+ (Container : in out List;
+ I, J : Cursor);
+
+ procedure Swap_Links
+ (Container : in out List;
+ I, J : Cursor);
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Source : in out List);
+
+ procedure Splice
+ (Target : in out List;
+ Before : Cursor;
+ Source : in out List;
+ Position : in out Cursor);
+
+ procedure Splice
+ (Container : in out List;
+ Before : Cursor;
+ Position : Cursor);
+
+ function First (Container : List) return Cursor;
+
+ function First_Element (Container : List) return Element_Type;
+
+ function Last (Container : List) return Cursor;
+
+ function Last_Element (Container : List) return Element_Type;
+
+ function Next (Container : List; Position : Cursor) return Cursor;
+
+ procedure Next (Container : List; Position : in out Cursor);
+
+ function Previous (Container : List; Position : Cursor) return Cursor;
+
+ procedure Previous (Container : List; Position : in out Cursor);
+
+ function Find
+ (Container : List;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor;
+
+ function Reverse_Find
+ (Container : List;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor;
+
+ function Contains
+ (Container : List;
+ Item : Element_Type) return Boolean;
+
+ function Has_Element (Container : List; Position : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : List;
+ Process :
+ not null access procedure (Container : List; Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : List;
+ Process :
+ not null access procedure (Container : List; Position : Cursor));
+
+ generic
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ package Generic_Sorting is
+
+ function Is_Sorted (Container : List) return Boolean;
+
+ procedure Sort (Container : in out List);
+
+ procedure Merge (Target, Source : in out List);
+
+ end Generic_Sorting;
+
+ function Strict_Equal (Left, Right : List) return Boolean;
+
+ function Left (Container : List; Position : Cursor) return List;
+
+ function Right (Container : List; Position : Cursor) return List;
+
+private
+
+ type Node_Type is record
+ Prev : Count_Type'Base := -1;
+ Next : Count_Type;
+ Element : 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_Access is access all List;
+ for List_Access'Storage_Size use 0;
+
+ type Kind is (Plain, Part);
+
+ type Plain_List (Capacity : Count_Type) is record
+ Nodes : Node_Array (1 .. Capacity) := (others => <>);
+ Free : Count_Type'Base := -1;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
+ end record;
+
+ type PList_Access is access Plain_List;
+
+ type Part_List is record
+ LLength : Count_Type := 0;
+ LFirst : Count_Type := 0;
+ LLast : Count_Type := 0;
+ end record;
+
+ type List (Capacity : Count_Type) is tagged record
+ K : Kind := Plain;
+ Length : Count_Type := 0;
+ First : Count_Type := 0;
+ Last : Count_Type := 0;
+ Part : Part_List;
+ Plain : PList_Access := new Plain_List'(Capacity, others => <>);
+ end record;
+
+ use Ada.Streams;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out List);
+
+ for List'Read use Read;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : List);
+
+ for List'Write use Write;
+
+ type Cursor is
+ record
+ Node : Count_Type := 0;
+ end record;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor);
+
+ for Cursor'Read use Read;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor);
+
+ for Cursor'Write use Write;
+
+ Empty_List : constant List := (0, others => <>);
+
+ No_Element : constant Cursor := (Node => 0);
+
+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, 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_Bounded_Operations;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
+
+with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
+
+with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
+
+with System; use type System.Address;
+
+package body Ada.Containers.Formal_Hashed_Maps is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Equivalent_Keys
+ (Key : Key_Type;
+ Node : Node_Type) return Boolean;
+ pragma Inline (Equivalent_Keys);
+
+ function Find_Between
+ (HT : Hash_Table_Type;
+ Key : Key_Type;
+ From : Count_Type;
+ To : Count_Type) return Count_Type;
+
+ procedure Free
+ (HT : in out Hash_Table_Type;
+ 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);
+
+ function Next_Unchecked
+ (Container : Map;
+ Position : Cursor) return Cursor;
+
+ 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;
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package HT_Ops is
+ new Hash_Tables.Generic_Bounded_Operations
+ (HT_Types => HT_Types,
+ Hash_Node => Hash_Node,
+ Next => Next,
+ Set_Next => Set_Next);
+
+ package Key_Ops is
+ new Hash_Tables.Generic_Bounded_Keys
+ (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 := First (Left).Node;
+ ENode : Count_Type;
+ Last : Count_Type;
+ begin
+
+ if Left.K = Plain then
+ Last := 0;
+ else
+ Last := HT_Ops.Next (Left.HT.all, Left.Last);
+ end if;
+
+ while Node /= Last loop
+ ENode := Find (Container => Right,
+ Key => Left.HT.Nodes (Node).Key).Node;
+ if ENode = 0 or else
+ Right.HT.Nodes (ENode).Element /= Left.HT.Nodes (Node).Element
+ then
+ return False;
+ end if;
+
+ Node := HT_Ops.Next (Left.HT.all, 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.HT.Nodes (Source_Node);
+ begin
+ Target.Insert (N.Key, N.Element);
+ end Insert_Element;
+
+ -- Start of processing for Assign
+
+ begin
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Capacity < Length (Source) then
+ raise Constraint_Error with -- correct exception ???
+ "Source length exceeds Target capacity";
+ end if;
+
+ Clear (Target); -- checks busy bits
+
+ case Source.K is
+ when Plain =>
+ Insert_Elements (Source.HT.all);
+ when Part =>
+ declare
+ N : Count_Type := Source.First;
+ begin
+ while N /= HT_Ops.Next (Source.HT.all, Source.Last) loop
+ Insert_Element (N);
+ N := HT_Ops.Next (Source.HT.all, N);
+ end loop;
+ end;
+ end case;
+ end Assign;
+
+ --------------
+ -- Capacity --
+ --------------
+
+ function Capacity (Container : Map) return Count_Type is
+ begin
+ return Container.HT.Nodes'Length;
+ end Capacity;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Map) is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ HT_Ops.Clear (Container.HT.all);
+ end Clear;
+
+ --------------
+ -- 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);
+ H : Hash_Type := 1;
+ N : Count_Type := 1;
+ Target : Map (C, Source.Modulus);
+ Cu : Cursor;
+ begin
+ if (Source.K = Part and Source.Length = 0) or
+ Source.HT.Length = 0 then
+ return Target;
+ end if;
+
+ Target.HT.Length := Source.HT.Length;
+ Target.HT.Free := Source.HT.Free;
+ while H <= Source.Modulus loop
+ Target.HT.Buckets (H) := Source.HT.Buckets (H);
+ H := H + 1;
+ end loop;
+ while N <= Source.Capacity loop
+ Target.HT.Nodes (N) := Source.HT.Nodes (N);
+ N := N + 1;
+ end loop;
+ while N <= C loop
+ Cu := (Node => N);
+ Free (Target.HT.all, Cu.Node);
+ N := N + 1;
+ end loop;
+ if Source.K = Part then
+ N := HT_Ops.First (Target.HT.all);
+ while N /= Source.First loop
+ Cu := (Node => N);
+ N := HT_Ops.Next (Target.HT.all, N);
+ Delete (Target, Cu);
+ end loop;
+ N := HT_Ops.Next (Target.HT.all, Source.Last);
+ while N /= 0 loop
+ Cu := (Node => N);
+ N := HT_Ops.Next (Target.HT.all, N);
+ Delete (Target, Cu);
+ end loop;
+ end if;
+ 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
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ Key_Ops.Delete_Key_Sans_Free (Container.HT.all, Key, X);
+
+ if X = 0 then
+ raise Constraint_Error with "attempt to delete key not in map";
+ end if;
+
+ Free (Container.HT.all, X);
+ end Delete;
+
+ procedure Delete (Container : in out Map; Position : in out Cursor) is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor of Delete has no element";
+ end if;
+
+ if Container.HT.Busy > 0 then
+ raise Program_Error with
+ "Delete attempted to tamper with elements (map is busy)";
+ end if;
+
+ pragma Assert (Vet (Container, Position), "bad cursor in Delete");
+
+ HT_Ops.Delete_Node_Sans_Free (Container.HT.all, Position.Node);
+
+ Free (Container.HT.all, Position.Node);
+ 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.HT.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.HT.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;
+
+ function Equivalent_Keys (Left : Map; CLeft : Cursor;
+ Right : Map; CRight : Cursor)
+ return Boolean is
+ begin
+ if not Has_Element (Left, CLeft) then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Keys has no element";
+ end if;
+
+ if not Has_Element (Right, CRight) then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Keys has no element";
+ end if;
+
+ pragma Assert (Vet (Left, CLeft),
+ "Left cursor of Equivalent_Keys is bad");
+ pragma Assert (Vet (Right, CRight),
+ "Right cursor of Equivalent_Keys is bad");
+
+ declare
+ LT : Hash_Table_Type renames Left.HT.all;
+ RT : Hash_Table_Type renames Right.HT.all;
+
+ LN : Node_Type renames LT.Nodes (CLeft.Node);
+ RN : Node_Type renames RT.Nodes (CRight.Node);
+
+ begin
+ return Equivalent_Keys (LN.Key, RN.Key);
+ end;
+ end Equivalent_Keys;
+
+ function Equivalent_Keys
+ (Left : Map;
+ CLeft : Cursor;
+ Right : Key_Type) return Boolean is
+ begin
+ if not Has_Element (Left, CLeft) then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Keys has no element";
+ end if;
+
+ pragma Assert (Vet (Left, CLeft),
+ "Left cursor in Equivalent_Keys is bad");
+
+ declare
+ LT : Hash_Table_Type renames Left.HT.all;
+ LN : Node_Type renames LT.Nodes (CLeft.Node);
+
+ begin
+ return Equivalent_Keys (LN.Key, Right);
+ end;
+ end Equivalent_Keys;
+
+ function Equivalent_Keys
+ (Left : Key_Type;
+ Right : Map;
+ CRight : Cursor) return Boolean is
+ begin
+ if Has_Element (Right, CRight) then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Keys has no element";
+ end if;
+
+ pragma Assert (Vet (Right, CRight),
+ "Right cursor of Equivalent_Keys is bad");
+
+ declare
+ RT : Hash_Table_Type renames Right.HT.all;
+ RN : Node_Type renames RT.Nodes (CRight.Node);
+
+ begin
+ return Equivalent_Keys (Left, RN.Key);
+ end;
+ end Equivalent_Keys;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Map; Key : Key_Type) is
+ X : Count_Type;
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ Key_Ops.Delete_Key_Sans_Free (Container.HT.all, Key, X);
+ Free (Container.HT.all, X);
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+ function Find_Between
+ (HT : Hash_Table_Type;
+ Key : Key_Type;
+ From : Count_Type;
+ To : Count_Type) return Count_Type is
+
+ Indx : Hash_Type;
+ Indx_From : constant Hash_Type :=
+ Key_Ops.Index (HT, HT.Nodes (From).Key);
+ Indx_To : constant Hash_Type :=
+ Key_Ops.Index (HT, HT.Nodes (To).Key);
+ Node : Count_Type;
+ To_Node : Count_Type;
+
+ begin
+
+ Indx := Key_Ops.Index (HT, Key);
+
+ if Indx < Indx_From or Indx > Indx_To then
+ return 0;
+ end if;
+
+ if Indx = Indx_From then
+ Node := From;
+ else
+ Node := HT.Buckets (Indx);
+ end if;
+
+ if Indx = Indx_To then
+ To_Node := HT.Nodes (To).Next;
+ else
+ To_Node := 0;
+ end if;
+
+ while Node /= To_Node loop
+ if Equivalent_Keys (Key, HT.Nodes (Node)) then
+ return Node;
+ end if;
+ Node := HT.Nodes (Node).Next;
+ end loop;
+ return 0;
+ end Find_Between;
+
+ function Find (Container : Map; Key : Key_Type) return Cursor is
+ begin
+ case Container.K is
+ when Plain =>
+ declare
+ Node : constant Count_Type :=
+ Key_Ops.Find (Container.HT.all, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ when Part =>
+ if Container.Length = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Find_Between (Container.HT.all, Key,
+ Container.First, Container.Last));
+ end case;
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Map) return Cursor is
+ begin
+ case Container.K is
+ when Plain =>
+ declare
+ Node : constant Count_Type := HT_Ops.First (Container.HT.all);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ when Part =>
+ declare
+ Node : constant Count_Type := Container.First;
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end case;
+ end First;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free
+ (HT : in out Hash_Table_Type;
+ X : Count_Type)
+ is
+ begin
+ HT.Nodes (X).Has_Element := False;
+ HT_Ops.Free (HT, X);
+ 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;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Container : Map; Position : Cursor) return Boolean is
+ begin
+ if Position.Node = 0 or else
+ not Container.HT.Nodes (Position.Node).Has_Element then
+ return False;
+ end if;
+
+ if Container.K = Plain then
+ return True;
+ end if;
+
+ declare
+ Lst_Index : constant Hash_Type :=
+ Key_Ops.Index (Container.HT.all,
+ Container.HT.Nodes (Container.Last).Key);
+ Fst_Index : constant Hash_Type :=
+ Key_Ops.Index (Container.HT.all,
+ Container.HT.Nodes (Container.First).Key);
+ Index : constant Hash_Type :=
+ Key_Ops.Index (Container.HT.all,
+ Container.HT.Nodes (Position.Node).Key);
+ Lst_Node : Count_Type;
+ Node : Count_Type;
+ begin
+
+ if Index < Fst_Index or Index > Lst_Index then
+ return False;
+ end if;
+
+ if Index > Fst_Index and Index < Lst_Index then
+ return True;
+ end if;
+
+ if Index = Fst_Index then
+ Node := Container.First;
+ else
+ Node := Container.HT.Buckets (Index);
+ end if;
+
+ if Index = Lst_Index then
+ Lst_Node := Container.HT.Nodes (Container.Last).Next;
+ else
+ Lst_Node := 0;
+ end if;
+
+ while Node /= Lst_Node loop
+ if Position.Node = Node then
+ return True;
+ end if;
+ Node := HT_Ops.Next (Container.HT.all, Node);
+ end loop;
+
+ return False;
+ end;
+ 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
+ if Container.HT.Lock > 0 then
+ raise Program_Error with
+ "Include attempted to tamper with cursors (map is locked)";
+ end if;
+
+ declare
+ N : Node_Type renames Container.HT.Nodes (Position.Node);
+ begin
+ N.Key := Key;
+ N.Element := New_Item;
+ end;
+ end if;
+ end Include;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+ declare
+ procedure Assign_Key (Node : in out Node_Type);
+ pragma Inline (Assign_Key);
+
+ function New_Node return 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 --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+ begin
+ Allocate (Container.HT.all, Result);
+ return Result;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+
+ Local_Insert (Container.HT.all, Key, Position.Node, Inserted);
+ end;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+ declare
+ procedure Assign_Key (Node : in out Node_Type);
+ pragma Inline (Assign_Key);
+
+ function New_Node return 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 --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+ begin
+ Allocate (Container.HT.all, Result);
+ return Result;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+
+ Local_Insert (Container.HT.all, Key, Position.Node, Inserted);
+ end;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ pragma Unreferenced (Position);
+
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, Key, New_Item, 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;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Map;
+ Process :
+ not null access procedure (Container : Map; Position : Cursor))
+ is
+ procedure Process_Node (Node : Count_Type);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Count_Type) is
+ begin
+ Process (Container, (Node => Node));
+ end Process_Node;
+
+ B : Natural renames Container'Unrestricted_Access.HT.Busy;
+
+ -- Start of processing for Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+ case Container.K is
+ when Plain =>
+ Local_Iterate (Container.HT.all);
+ when Part =>
+
+ if Container.Length = 0 then
+ return;
+ end if;
+
+ declare
+ Node : Count_Type := Container.First;
+ begin
+ while Node /= Container.HT.Nodes (Container.Last).Next loop
+ Process_Node (Node);
+ Node := HT_Ops.Next (Container.HT.all, Node);
+ end loop;
+ end;
+ end case;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Iterate;
+
+ ---------
+ -- 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.HT.Nodes (Position.Node).Key;
+ end Key;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Container : Map; Position : Cursor) return Map is
+ Lst : Count_Type;
+ Fst : constant Count_Type := First (Container).Node;
+ L : Count_Type := 0;
+ C : Count_Type := Fst;
+ begin
+ while C /= Position.Node loop
+ if C = 0 or C = Container.Last then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ Lst := C;
+ C := HT_Ops.Next (Container.HT.all, C);
+ L := L + 1;
+ end loop;
+ if L = 0 then
+ return (Capacity => Container.Capacity,
+ Modulus => Container.Modulus,
+ K => Part,
+ HT => Container.HT,
+ Length => 0,
+ First => 0,
+ Last => 0);
+ else
+ return (Capacity => Container.Capacity,
+ Modulus => Container.Modulus,
+ K => Part,
+ HT => Container.HT,
+ Length => L,
+ First => Fst,
+ Last => Lst);
+ end if;
+ end Left;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Map) return Count_Type is
+ begin
+ case Container.K is
+ when Plain =>
+ return Container.HT.Length;
+ when Part =>
+ return Container.Length;
+ end case;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move
+ (Target : in out Map;
+ Source : in out Map)
+ is
+ HT : HT_Types.Hash_Table_Type renames Source.HT.all;
+ NN : HT_Types.Nodes_Type renames HT.Nodes;
+ X, Y : Count_Type;
+
+ begin
+
+ if Target.K /= Plain or Source.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ 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;
+
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Source (list is busy)";
+ end if;
+
+ Clear (Target);
+
+ if HT.Length = 0 then
+ return;
+ end if;
+
+ X := HT_Ops.First (HT);
+ while X /= 0 loop
+ Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
+
+ Y := HT_Ops.Next (HT, X);
+
+ HT_Ops.Delete_Node_Sans_Free (HT, X);
+ Free (HT, 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_Unchecked
+ (Container : Map;
+ Position : Cursor) return Cursor
+ is
+ HT : Hash_Table_Type renames Container.HT.all;
+ Node : constant Count_Type := HT_Ops.Next (HT, Position.Node);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ if Container.K = Part and then Container.Last = Position.Node then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end Next_Unchecked;
+
+ 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");
+
+ return Next_Unchecked (Container, Position);
+ end Next;
+
+ procedure Next (Container : Map; Position : in out Cursor) is
+ begin
+ Position := Next (Container, Position);
+ end Next;
+
+ -------------
+ -- Overlap --
+ -------------
+
+ function Overlap (Left, Right : Map) return Boolean is
+ Left_Node : Count_Type;
+ Left_Nodes : Nodes_Type renames Left.HT.Nodes;
+ To_Node : Count_Type;
+ begin
+ if Length (Right) = 0 or Length (Left) = 0 then
+ return False;
+ end if;
+
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ Left_Node := First (Left).Node;
+
+ if Left.K = Plain then
+ To_Node := 0;
+ else
+ To_Node := Left.HT.Nodes (Left.Last).Next;
+ end if;
+
+ while Left_Node /= To_Node loop
+ declare
+ N : Node_Type renames Left_Nodes (Left_Node);
+ E : Key_Type renames N.Key;
+
+ begin
+ if Find (Right, E).Node /= 0 then
+ return True;
+ end if;
+ end;
+
+ Left_Node := HT_Ops.Next (Left.HT.all, Left_Node);
+ end loop;
+
+ return False;
+ end Overlap;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : Element_Type))
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor of Query_Element has no element";
+ end if;
+
+ pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
+
+ declare
+ HT : Hash_Table_Type renames Container.HT.all;
+ N : Node_Type renames HT.Nodes (Position.Node);
+
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ declare
+ K : Key_Type renames N.Key;
+ E : Element_Type renames N.Element;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Map)
+ is
+ function Read_Node (Stream : not null access Root_Stream_Type'Class)
+ return Count_Type;
+
+ procedure Read_Nodes is
+ new HT_Ops.Generic_Read (Read_Node);
+
+ ---------------
+ -- Read_Node --
+ ---------------
+
+ function Read_Node (Stream : not null access Root_Stream_Type'Class)
+ return Count_Type
+ is
+ procedure Read_Element (Node : in out Node_Type);
+ pragma Inline (Read_Element);
+
+ procedure Allocate is
+ new Generic_Allocate (Read_Element);
+
+ procedure Read_Element (Node : in out Node_Type) is
+ begin
+ Element_Type'Read (Stream, Node.Element);
+ end Read_Element;
+
+ Node : Count_Type;
+
+ -- Start of processing for Read_Node
+
+ begin
+ Allocate (Container.HT.all, Node);
+ return Node;
+ end Read_Node;
+
+ -- Start of processing for Read
+ Result : HT_Access;
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error;
+ end if;
+
+ if Container.HT = null then
+ Result := new HT_Types.Hash_Table_Type (Container.Capacity,
+ Container.Modulus);
+ else
+ Result := Container.HT;
+ end if;
+
+ Read_Nodes (Stream, Result.all);
+ Container.HT := Result;
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream set cursor";
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Count_Type := Key_Ops.Find (Container.HT.all, Key);
+
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Node = 0 then
+ raise Constraint_Error with
+ "attempt to replace key not in map";
+ end if;
+
+ if Container.HT.Lock > 0 then
+ raise Program_Error with
+ "Replace attempted to tamper with cursors (map is locked)";
+ end if;
+
+ declare
+ N : Node_Type renames Container.HT.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 Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor of Replace_Element has no element";
+ end if;
+
+ if Container.HT.Lock > 0 then
+ raise Program_Error with
+ "Replace_Element attempted to tamper with cursors (map is locked)";
+ end if;
+
+ pragma Assert (Vet (Container, Position),
+ "bad cursor in Replace_Element");
+
+ Container.HT.Nodes (Position.Node).Element := New_Item;
+ end Replace_Element;
+
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ procedure Reserve_Capacity
+ (Container : in out Map;
+ Capacity : Count_Type)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Capacity > Container.Capacity then
+ raise Capacity_Error with "requested capacity is too large";
+ end if;
+ end Reserve_Capacity;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Container : Map; Position : Cursor) return Map is
+ Last : Count_Type;
+ Lst : Count_Type;
+ L : Count_Type := 0;
+ C : Count_Type := Position.Node;
+ begin
+
+ if C = 0 then
+ return (Capacity => Container.Capacity,
+ Modulus => Container.Modulus,
+ K => Part,
+ HT => Container.HT,
+ Length => 0,
+ First => 0,
+ Last => 0);
+ end if;
+
+ if Container.K = Plain then
+ Lst := 0;
+ else
+ Lst := HT_Ops.Next (Container.HT.all, Container.Last);
+ end if;
+
+ if C = Lst then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+
+ while C /= Lst loop
+ if C = 0 then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ Last := C;
+ C := HT_Ops.Next (Container.HT.all, C);
+ L := L + 1;
+ end loop;
+
+ return (Capacity => Container.Capacity,
+ Modulus => Container.Modulus,
+ K => Part,
+ HT => Container.HT,
+ Length => L,
+ First => Position.Node,
+ Last => Last);
+ end Right;
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
+ begin
+ Node.Next := Next;
+ end Set_Next;
+
+ ------------------
+ -- Strict_Equal --
+ ------------------
+
+ function Strict_Equal (Left, Right : Map) return Boolean is
+ CuL : Cursor := First (Left);
+ CuR : Cursor := First (Right);
+ begin
+ if Length (Left) /= Length (Right) then
+ return False;
+ end if;
+
+ while CuL.Node /= 0 or CuR.Node /= 0 loop
+ if CuL.Node /= CuR.Node or else
+ (Left.HT.Nodes (CuL.Node).Element /=
+ Right.HT.Nodes (CuR.Node).Element or
+ Left.HT.Nodes (CuL.Node).Key /=
+ Right.HT.Nodes (CuR.Node).Key) then
+ return False;
+ end if;
+ CuL := Next_Unchecked (Left, CuL);
+ CuR := Next_Unchecked (Right, CuR);
+ end loop;
+
+ return True;
+ end Strict_Equal;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access procedure (Key : Key_Type;
+ Element : in out Element_Type))
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor of Update_Element has no element";
+ end if;
+
+ pragma Assert (Vet (Container, Position),
+ "bad cursor in Update_Element");
+
+ declare
+ HT : Hash_Table_Type renames Container.HT.all;
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ declare
+ N : Node_Type renames HT.Nodes (Position.Node);
+ K : Key_Type renames N.Key;
+ E : Element_Type renames N.Element;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Update_Element;
+
+ ---------
+ -- Vet --
+ ---------
+
+ function Vet (Container : Map; Position : Cursor) return Boolean is
+ begin
+ if Position.Node = 0 then
+ return True;
+ end if;
+
+ declare
+ M : HT_Types.Hash_Table_Type renames Container.HT.all;
+ X : Count_Type;
+
+ begin
+ if M.Length = 0 then
+ return False;
+ end if;
+
+ if M.Capacity = 0 then
+ return False;
+ end if;
+
+ if M.Buckets'Length = 0 then
+ return False;
+ end if;
+
+ if Position.Node > M.Capacity then
+ return False;
+ end if;
+
+ if M.Nodes (Position.Node).Next = Position.Node then
+ return False;
+ end if;
+
+ X := M.Buckets (Key_Ops.Index (M, M.Nodes (Position.Node).Key));
+
+ for J in 1 .. M.Length loop
+ if X = Position.Node then
+ return True;
+ end if;
+
+ if X = 0 then
+ return False;
+ end if;
+
+ if X = M.Nodes (X).Next then -- to prevent unnecessary looping
+ return False;
+ end if;
+
+ X := M.Nodes (X).Next;
+ end loop;
+
+ return False;
+ end;
+ end Vet;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Map)
+ is
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type);
+ pragma Inline (Write_Node);
+
+ procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
+
+ ----------------
+ -- Write_Node --
+ ----------------
+
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type)
+ is
+ begin
+ Key_Type'Write (Stream, Node.Key);
+ Element_Type'Write (Stream, Node.Element);
+ end Write_Node;
+
+ -- Start of processing for Write
+
+ begin
+ Write_Nodes (Stream, Container.HT.all);
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream map cursor";
+ end Write;
+
+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 _ M A P S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2010, 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/>. --
+------------------------------------------------------------------------------
+
+private with Ada.Containers.Hash_Tables;
+private with Ada.Streams;
+with Ada.Containers; use Ada.Containers;
+
+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, Right : Key_Type) return Boolean;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Formal_Hashed_Maps is
+ pragma Pure;
+
+ type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
+ -- pragma Preelaborable_Initialization (Map);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_Map : constant Map;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Map) return Boolean;
+
+ function Capacity (Container : Map) return Count_Type;
+
+ procedure Reserve_Capacity
+ (Container : in out Map;
+ Capacity : Count_Type);
+
+ function Length (Container : Map) return Count_Type;
+
+ function Is_Empty (Container : Map) return Boolean;
+
+ -- ??? what does clear do to active elements?
+ procedure Clear (Container : in out Map);
+
+ procedure Assign (Target : in out Map; Source : Map);
+
+ -- ???
+ -- capacity=0 means use container.length as cap of tgt
+ -- modulos=0 means use default_modulous(container.length)
+ function Copy (Source : Map;
+ Capacity : Count_Type := 0) return Map;
+
+ function Key (Container : Map; Position : Cursor) return Key_Type;
+
+ function Element (Container : Map; Position : Cursor) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Map;
+ Position : Cursor;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : Element_Type));
+
+ procedure Update_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : in out Element_Type));
+
+ procedure Move (Target : in out Map; Source : in out Map);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Exclude (Container : in out Map; Key : Key_Type);
+
+ procedure Delete (Container : in out Map; Key : Key_Type);
+
+ procedure Delete (Container : in out Map; Position : in out Cursor);
+
+ function First (Container : Map) return Cursor;
+
+ function Next (Container : Map; Position : Cursor) return Cursor;
+
+ procedure Next (Container : Map; Position : in out Cursor);
+
+ function Find (Container : Map; Key : Key_Type) return Cursor;
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean;
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type;
+
+ function Has_Element (Container : Map; Position : Cursor) return Boolean;
+
+ function Equivalent_Keys
+ (Left : Map;
+ CLeft : Cursor;
+ Right : Map;
+ CRight : Cursor) return Boolean;
+
+ function Equivalent_Keys
+ (Left : Map;
+ CLeft : Cursor;
+ Right : Key_Type) return Boolean;
+
+ function Equivalent_Keys
+ (Left : Key_Type;
+ Right : Map;
+ CRight : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Map;
+ Process :
+ not null access procedure (Container : Map; Position : Cursor));
+
+ function Default_Modulus (Capacity : Count_Type) return Hash_Type;
+
+ function Strict_Equal (Left, Right : Map) return Boolean;
+
+ function Left (Container : Map; Position : Cursor) return Map;
+
+ function Right (Container : Map; Position : Cursor) return Map;
+
+ function Overlap (Left, Right : Map) return Boolean;
+
+private
+ -- pragma Inline ("=");
+ pragma Inline (Length);
+ pragma Inline (Is_Empty);
+ pragma Inline (Clear);
+ pragma Inline (Key);
+ pragma Inline (Element);
+ -- pragma Inline (Move); ???
+ pragma Inline (Contains);
+ pragma Inline (Capacity);
+ -- pragma Inline (Reserve_Capacity); ???
+ pragma Inline (Has_Element);
+ pragma Inline (Equivalent_Keys);
+ pragma Inline (Next);
+
+ type Node_Type is record
+ Key : Key_Type;
+ Element : Element_Type;
+ Next : Count_Type;
+ Has_Element : Boolean := False;
+ end record;
+
+ package HT_Types is new
+ Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types
+ (Node_Type);
+
+ type HT_Access is access all HT_Types.Hash_Table_Type;
+
+ type Kind is (Plain, Part);
+
+ type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged record
+ HT : HT_Access := new HT_Types.Hash_Table_Type (Capacity, Modulus);
+ K : Kind := Plain;
+ Length : Count_Type := 0;
+ First : Count_Type := 0;
+ Last : Count_Type := 0;
+ end record;
+
+ use HT_Types;
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Map);
+
+ for Map'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Map);
+
+ for Map'Read use Read;
+
+ type Map_Access is access all Map;
+ for Map_Access'Storage_Size use 0;
+
+ type Cursor is
+ record
+ Node : Count_Type;
+ end record;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor);
+
+ for Cursor'Read use Read;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor);
+
+ for Cursor'Write use Write;
+
+ Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>);
+
+ No_Element : constant Cursor := (Node => 0);
+
+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, 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_Bounded_Operations;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
+
+with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
+pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
+
+with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
+
+with System; use type System.Address;
+
+package body Ada.Containers.Formal_Hashed_Sets is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Difference
+ (Left, Right : Set;
+ Target : in out Hash_Table_Type);
+
+ function Equivalent_Keys
+ (Key : Element_Type;
+ Node : Node_Type) return Boolean;
+ pragma Inline (Equivalent_Keys);
+
+ procedure Free
+ (HT : in out Hash_Table_Type;
+ 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 Hash_Table_Type;
+ New_Item : Element_Type;
+ Node : out Count_Type;
+ Inserted : out Boolean);
+
+ procedure Intersection
+ (Left : Hash_Table_Type;
+ Right : Set;
+ Target : in out Hash_Table_Type);
+
+ function Is_In
+ (HT : HT_Types.Hash_Table_Type;
+ 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_Unchecked
+ (Container : Set;
+ Position : Cursor) return Cursor;
+
+ 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;
+
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
+
+ package HT_Ops is new Hash_Tables.Generic_Bounded_Operations
+ (HT_Types => HT_Types,
+ Hash_Node => Hash_Node,
+ Next => Next,
+ Set_Next => Set_Next);
+
+ package Element_Keys is new Hash_Tables.Generic_Bounded_Keys
+ (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 := First (Left).Node;
+ ENode : Count_Type;
+ Last : Count_Type;
+ begin
+
+ if Left.K = Plain then
+ Last := 0;
+ else
+ Last := HT_Ops.Next (Left.HT.all, Left.Last);
+ end if;
+
+ while Node /= Last loop
+ ENode := Find (Container => Right,
+ Item => Left.HT.Nodes (Node).Element).Node;
+ if ENode = 0 or else
+ Right.HT.Nodes (ENode).Element /= Left.HT.Nodes (Node).Element
+ then
+ return False;
+ end if;
+
+ Node := HT_Ops.Next (Left.HT.all, 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.HT.Nodes (Source_Node);
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ Insert (Target.HT.all, N.Element, X, B);
+ pragma Assert (B);
+ end Insert_Element;
+
+ -- Start of processing for Assign
+
+ begin
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ 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;
+
+ HT_Ops.Clear (Target.HT.all);
+
+ case Source.K is
+ when Plain =>
+ Insert_Elements (Source.HT.all);
+ when Part =>
+ declare
+ N : Count_Type := Source.First;
+ begin
+ while N /= HT_Ops.Next (Source.HT.all, Source.Last) loop
+ Insert_Element (N);
+ N := HT_Ops.Next (Source.HT.all, N);
+ end loop;
+ end;
+ end case;
+ end Assign;
+
+ --------------
+ -- Capacity --
+ --------------
+
+ function Capacity (Container : Set) return Count_Type is
+ begin
+ return Container.HT.Nodes'Length;
+ end Capacity;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Set) is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ HT_Ops.Clear (Container.HT.all);
+ end Clear;
+
+ --------------
+ -- 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);
+ H : Hash_Type := 1;
+ N : Count_Type := 1;
+ Target : Set (C, Source.Modulus);
+ Cu : Cursor;
+ begin
+ if (Source.K = Part and Source.Length = 0) or
+ Source.HT.Length = 0 then
+ return Target;
+ end if;
+
+ Target.HT.Length := Source.HT.Length;
+ Target.HT.Free := Source.HT.Free;
+ while H <= Source.Modulus loop
+ Target.HT.Buckets (H) := Source.HT.Buckets (H);
+ H := H + 1;
+ end loop;
+ while N <= Source.Capacity loop
+ Target.HT.Nodes (N) := Source.HT.Nodes (N);
+ N := N + 1;
+ end loop;
+ while N <= C loop
+ Cu := (Node => N);
+ Free (Target.HT.all, Cu.Node);
+ N := N + 1;
+ end loop;
+ if Source.K = Part then
+ N := HT_Ops.First (Target.HT.all);
+ while N /= Source.First loop
+ Cu := (Node => N);
+ N := HT_Ops.Next (Target.HT.all, N);
+ Delete (Target, Cu);
+ end loop;
+ N := HT_Ops.Next (Target.HT.all, Source.Last);
+ while N /= 0 loop
+ Cu := (Node => N);
+ N := HT_Ops.Next (Target.HT.all, N);
+ Delete (Target, Cu);
+ end loop;
+ end if;
+ 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
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ Element_Keys.Delete_Key_Sans_Free (Container.HT.all, Item, X);
+
+ if X = 0 then
+ raise Constraint_Error with "attempt to delete element not in set";
+ end if;
+ Free (Container.HT.all, X);
+ end Delete;
+
+ procedure Delete
+ (Container : in out Set;
+ Position : in out Cursor)
+ is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Container.HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
+ end if;
+
+ pragma Assert (Vet (Container, Position), "bad cursor in Delete");
+
+ HT_Ops.Delete_Node_Sans_Free (Container.HT.all, Position.Node);
+ Free (Container.HT.all, Position.Node);
+
+ Position := No_Element;
+ end Delete;
+
+ ----------------
+ -- Difference --
+ ----------------
+
+ procedure Difference
+ (Target : in out Set;
+ Source : Set)
+ is
+ Tgt_Node, Src_Node, Src_Last, Src_Length : Count_Type;
+
+ TN : Nodes_Type renames Target.HT.Nodes;
+ SN : Nodes_Type renames Source.HT.Nodes;
+
+ begin
+
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ case Source.K is
+ when Plain =>
+ Src_Length := Source.HT.Length;
+ when Part =>
+ Src_Length := Source.Length;
+ end case;
+
+ if Src_Length = 0 then
+ return;
+ end if;
+
+ if Target.HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
+ end if;
+
+ case Source.K is
+ when Plain =>
+ if Src_Length >= Target.HT.Length then
+ Tgt_Node := HT_Ops.First (Target.HT.all);
+ while Tgt_Node /= 0 loop
+ if Element_Keys.Find (Source.HT.all,
+ TN (Tgt_Node).Element) /= 0 then
+ declare
+ X : constant Count_Type := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target.HT.all, X);
+ Free (Target.HT.all, X);
+ end;
+ else
+ Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node);
+ end if;
+ end loop;
+ return;
+ else
+ Src_Node := HT_Ops.First (Source.HT.all);
+ Src_Last := 0;
+ end if;
+ when Part =>
+ Src_Node := Source.First;
+ Src_Last := HT_Ops.Next (Source.HT.all, Source.Last);
+ end case;
+ while Src_Node /= Src_Last loop
+ Tgt_Node := Element_Keys.Find
+ (Target.HT.all, SN (Src_Node).Element);
+
+ if Tgt_Node /= 0 then
+ HT_Ops.Delete_Node_Sans_Free (Target.HT.all, Tgt_Node);
+ Free (Target.HT.all, Tgt_Node);
+ end if;
+
+ Src_Node := HT_Ops.Next (Source.HT.all, Src_Node);
+ end loop;
+ end Difference;
+
+ procedure Difference
+ (Left, Right : Set;
+ Target : in out Hash_Table_Type)
+ 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.HT.Nodes (L_Node).Element;
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ if Find (Right, E).Node = 0 then
+ Insert (Target, E, X, B);
+ pragma Assert (B);
+ end if;
+ end Process;
+
+ -- Start of processing for Difference
+
+ begin
+ if Left.K = Plain then
+ Iterate (Left.HT.all);
+ else
+
+ if Left.Length = 0 then
+ return;
+ end if;
+
+ declare
+ Node : Count_Type := Left.First;
+ begin
+ while Node /= Left.HT.Nodes (Left.Last).Next loop
+ Process (Node);
+ Node := HT_Ops.Next (Left.HT.all, Node);
+ end loop;
+ end;
+ end if;
+ end Difference;
+
+ function Difference (Left, Right : Set) return Set is
+ C : Count_Type;
+ H : Hash_Type;
+ S : Set (C, H);
+ 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 Left.Copy;
+ end if;
+
+ C := Length (Left);
+ H := Default_Modulus (C);
+ Difference (Left, Right, Target => S.HT.all);
+ return S;
+ 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");
+
+ declare
+ HT : Hash_Table_Type renames Container.HT.all;
+ begin
+ return HT.Nodes (Position.Node).Element;
+ end;
+ end Element;
+
+ ---------------------
+ -- Equivalent_Sets --
+ ---------------------
+
+ function Equivalent_Sets (Left, Right : Set) return Boolean is
+ begin
+ if Left.K = Plain and Right.K = Plain then
+ declare
+
+ function Find_Equivalent_Key
+ (R_HT : Hash_Table_Type'Class;
+ 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'Class;
+ 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 of Equivalent_Sets
+
+ begin
+ return Is_Equivalent (Left.HT.all, Right.HT.all);
+ end;
+ else
+ declare
+
+ function Equal_Between
+ (L : Hash_Table_Type; R : Set;
+ From : Count_Type; To : Count_Type) return Boolean;
+
+ -- To and From are valid and Length are equal
+ function Equal_Between
+ (L : Hash_Table_Type; R : Set;
+ From : Count_Type; To : Count_Type) return Boolean
+ is
+ L_Index : Hash_Type;
+ To_Index : constant Hash_Type :=
+ Element_Keys.Index (L, L.Nodes (To).Element);
+ L_Node : Count_Type := From;
+
+ begin
+
+ L_Index := Element_Keys.Index (L, L.Nodes (From).Element);
+
+ -- For each node of hash table L, search for an equivalent
+ -- node in hash table R.
+
+ while L_Index /= To_Index or else
+ L_Node /= HT_Ops.Next (L, To) loop
+ pragma Assert (L_Node /= 0);
+
+ if Find (R, L.Nodes (L_Node).Element).Node = 0 then
+ return False;
+ end if;
+
+ L_Node := L.Nodes (L_Node).Next;
+
+ if L_Node = 0 then
+ -- We have exhausted the nodes in this bucket
+ -- Find the next bucket
+
+ loop
+ L_Index := L_Index + 1;
+ L_Node := L.Buckets (L_Index);
+ exit when L_Node /= 0;
+ end loop;
+ end if;
+ end loop;
+
+ return True;
+ end Equal_Between;
+
+ begin
+ if Length (Left) /= Length (Right) then
+ return False;
+ end if;
+ if Length (Left) = 0 then
+ return True;
+ end if;
+ if Left.K = Part then
+ return Equal_Between (Left.HT.all, Right,
+ Left.First, Left.Last);
+ else
+ return Equal_Between (Right.HT.all, Left,
+ Right.First, Right.Last);
+ end if;
+ end;
+ end if;
+ end Equivalent_Sets;
+
+ -------------------------
+ -- Equivalent_Elements --
+ -------------------------
+
+ function Equivalent_Elements (Left : Set; CLeft : Cursor;
+ Right : Set; CRight : Cursor)
+ return Boolean is
+ begin
+ if not Has_Element (Left, CLeft) then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Elements has no element";
+ end if;
+
+ if not Has_Element (Right, CRight) then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Elements has no element";
+ end if;
+
+ pragma Assert (Vet (Left, CLeft),
+ "bad Left cursor in Equivalent_Elements");
+ pragma Assert (Vet (Right, CRight),
+ "bad Right cursor in Equivalent_Elements");
+
+ declare
+ LN : Node_Type renames Left.HT.Nodes (CLeft.Node);
+ RN : Node_Type renames Right.HT.Nodes (CRight.Node);
+ begin
+ return Equivalent_Elements (LN.Element, RN.Element);
+ end;
+ end Equivalent_Elements;
+
+ function Equivalent_Elements
+ (Left : Set;
+ CLeft : Cursor;
+ Right : Element_Type) return Boolean is
+ begin
+ if not Has_Element (Left, CLeft) then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Elements has no element";
+ end if;
+
+ pragma Assert (Vet (Left, CLeft),
+ "Left cursor in Equivalent_Elements is bad");
+
+ declare
+ LN : Node_Type renames Left.HT.Nodes (CLeft.Node);
+ begin
+ return Equivalent_Elements (LN.Element, Right);
+ end;
+ end Equivalent_Elements;
+
+ function Equivalent_Elements
+ (Left : Element_Type;
+ Right : Set;
+ CRight : Cursor) return Boolean is
+ begin
+ if not Has_Element (Right, CRight) then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Elements has no element";
+ end if;
+
+ pragma Assert
+ (Vet (Right, CRight),
+ "Right cursor of Equivalent_Elements is bad");
+
+ declare
+ RN : Node_Type renames Right.HT.Nodes (CRight.Node);
+ begin
+ return Equivalent_Elements (Left, RN.Element);
+ end;
+ end Equivalent_Elements;
+
+ -- NOT MODIFIED
+
+ ---------------------
+ -- 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
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+ Element_Keys.Delete_Key_Sans_Free (Container.HT.all, Item, X);
+ Free (Container.HT.all, X);
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (Container : Set;
+ Item : Element_Type) return Cursor
+ is
+ begin
+ case Container.K is
+ when Plain =>
+ declare
+ Node : constant Count_Type :=
+ Element_Keys.Find (Container.HT.all, Item);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+ return (Node => Node);
+ end;
+ when Part =>
+ declare
+ function Find_Between
+ (HT : Hash_Table_Type;
+ Key : Element_Type;
+ From : Count_Type;
+ To : Count_Type) return Count_Type;
+
+ function Find_Between
+ (HT : Hash_Table_Type;
+ Key : Element_Type;
+ From : Count_Type;
+ To : Count_Type) return Count_Type is
+
+ Indx : Hash_Type;
+ Indx_From : constant Hash_Type :=
+ Element_Keys.Index (HT,
+ HT.Nodes (From).Element);
+ Indx_To : constant Hash_Type :=
+ Element_Keys.Index (HT,
+ HT.Nodes (To).Element);
+ Node : Count_Type;
+ To_Node : Count_Type;
+
+ begin
+
+ Indx := Element_Keys.Index (HT, Key);
+
+ if Indx < Indx_From or Indx > Indx_To then
+ return 0;
+ end if;
+
+ if Indx = Indx_From then
+ Node := From;
+ else
+ Node := HT.Buckets (Indx);
+ end if;
+
+ if Indx = Indx_To then
+ To_Node := HT.Nodes (To).Next;
+ else
+ To_Node := 0;
+ end if;
+
+ while Node /= To_Node loop
+ if Equivalent_Keys (Key, HT.Nodes (Node)) then
+ return Node;
+ end if;
+ Node := HT.Nodes (Node).Next;
+ end loop;
+ return 0;
+ end Find_Between;
+ begin
+
+ if Container.Length = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Find_Between (Container.HT.all, Item,
+ Container.First, Container.Last));
+ end;
+ end case;
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Set) return Cursor is
+ begin
+ case Container.K is
+ when Plain =>
+ declare
+ Node : constant Count_Type := HT_Ops.First (Container.HT.all);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ when Part =>
+ declare
+ Node : constant Count_Type := Container.First;
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end case;
+ end First;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free
+ (HT : in out Hash_Table_Type;
+ X : Count_Type)
+ is
+ begin
+ HT.Nodes (X).Has_Element := False;
+ HT_Ops.Free (HT, X);
+ 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;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Container : Set; Position : Cursor) return Boolean is
+ begin
+ if Position.Node = 0 or else
+ not Container.HT.Nodes (Position.Node).Has_Element then
+ return False;
+ end if;
+
+ if Container.K = Plain then
+ return True;
+ end if;
+
+ declare
+ Lst_Index : constant Hash_Type :=
+ Element_Keys.Index (Container.HT.all,
+ Container.HT.Nodes
+ (Container.Last).Element);
+ Fst_Index : constant Hash_Type :=
+ Element_Keys.Index (Container.HT.all,
+ Container.HT.Nodes
+ (Container.First).Element);
+ Index : constant Hash_Type :=
+ Element_Keys.Index (Container.HT.all,
+ Container.HT.Nodes
+ (Position.Node).Element);
+ Lst_Node : Count_Type;
+ Node : Count_Type;
+ begin
+
+ if Index < Fst_Index or Index > Lst_Index then
+ return False;
+ end if;
+
+ if Index > Fst_Index and Index < Lst_Index then
+ return True;
+ end if;
+
+ if Index = Fst_Index then
+ Node := Container.First;
+ else
+ Node := Container.HT.Buckets (Index);
+ end if;
+
+ if Index = Lst_Index then
+ Lst_Node := Container.HT.Nodes (Container.Last).Next;
+ else
+ Lst_Node := 0;
+ end if;
+
+ while Node /= Lst_Node loop
+ if Position.Node = Node then
+ return True;
+ end if;
+ Node := HT_Ops.Next (Container.HT.all, Node);
+ end loop;
+
+ return False;
+ end;
+ 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
+ Position : Cursor;
+ Inserted : Boolean;
+
+ begin
+ Insert (Container, New_Item, Position, Inserted);
+
+ if not Inserted then
+ if Container.HT.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
+ end if;
+
+ Container.HT.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
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ Insert (Container.HT.all, 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;
+
+ procedure Insert
+ (Container : in out Hash_Table_Type;
+ 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);
+
+ function New_Node return 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 --
+ --------------
+
+ function New_Node return Count_Type is
+ Result : Count_Type;
+ begin
+ Allocate (Container, Result);
+ return Result;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+
+ Local_Insert (Container, 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.HT.Nodes;
+
+ begin
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.HT.Length = 0 then
+ Clear (Target);
+ return;
+ end if;
+
+ if Target.HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
+ end if;
+
+ Tgt_Node := HT_Ops.First (Target.HT.all);
+ while Tgt_Node /= 0 loop
+ if Find (Source, TN (Tgt_Node).Element).Node /= 0 then
+ Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node);
+
+ else
+ declare
+ X : constant Count_Type := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target.HT.all, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target.HT.all, X);
+ Free (Target.HT.all, X);
+ end;
+ end if;
+ end loop;
+ end Intersection;
+
+ procedure Intersection
+ (Left : Hash_Table_Type;
+ Right : Set;
+ Target : in out Hash_Table_Type)
+ 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.Nodes (L_Node).Element;
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ if Find (Right, E).Node /= 0 then
+ Insert (Target, E, X, B);
+ pragma Assert (B);
+ end if;
+ end Process;
+
+ -- Start of processing for Intersection
+
+ begin
+ Iterate (Left);
+ end Intersection;
+
+ function Intersection (Left, Right : Set) return Set is
+ C : Count_Type;
+ H : Hash_Type;
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ if Left'Address = Right'Address then
+ return Left.Copy;
+ end if;
+
+ C := Count_Type'Min (Length (Left), Length (Right)); -- ???
+ H := Default_Modulus (C);
+ return S : Set (C, H) do
+ if Length (Left) /= 0 and Length (Right) /= 0 then
+ if Left.K = Plain then
+ Intersection (Left.HT.all, Right, Target => S.HT.all);
+ else
+ C := Left.First;
+ while C /= Left.HT.Nodes (Left.Last).Next loop
+ pragma Assert (C /= 0);
+ if Find (Right, Left.HT.Nodes (C).Element).Node /= 0 then
+ Insert (S.HT.all, Left.HT.Nodes (C).Element, X, B);
+ pragma Assert (B);
+ end if;
+ C := Left.HT.Nodes (C).Next;
+ end loop;
+ end if;
+ 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 : HT_Types.Hash_Table_Type;
+ Key : Node_Type) return Boolean is
+ begin
+ return Element_Keys.Find (HT, 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.HT.Nodes;
+ To_Node : Count_Type;
+ begin
+ if Subset'Address = Of_Set'Address then
+ return True;
+ end if;
+
+ if Length (Subset) > Length (Of_Set) then
+ return False;
+ end if;
+
+ Subset_Node := First (Subset).Node;
+
+ if Subset.K = Plain then
+ To_Node := 0;
+ else
+ To_Node := Subset.HT.Nodes (Subset.Last).Next;
+ end if;
+
+ while Subset_Node /= To_Node loop
+ declare
+ N : Node_Type renames Subset_Nodes (Subset_Node);
+ 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.HT.all, Subset_Node);
+ end loop;
+
+ return True;
+ end Is_Subset;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Set;
+ Process :
+ not null access procedure (Container : Set; Position : Cursor))
+ is
+ procedure Process_Node (Node : Count_Type);
+ pragma Inline (Process_Node);
+
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Count_Type) is
+ begin
+ Process (Container, (Node => Node));
+ end Process_Node;
+
+ B : Natural renames Container'Unrestricted_Access.HT.Busy;
+
+ -- Start of processing for Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+ case Container.K is
+ when Plain =>
+ Iterate (Container.HT.all);
+ when Part =>
+
+ if Container.Length = 0 then
+ return;
+ end if;
+
+ declare
+ Node : Count_Type := Container.First;
+ begin
+ while Node /= Container.HT.Nodes (Container.Last).Next loop
+ Process_Node (Node);
+ Node := HT_Ops.Next (Container.HT.all, Node);
+ end loop;
+ end;
+ end case;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Iterate;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Container : Set; Position : Cursor) return Set is
+ Lst : Count_Type;
+ Fst : constant Count_Type := First (Container).Node;
+ L : Count_Type := 0;
+ C : Count_Type := Fst;
+ begin
+ while C /= Position.Node loop
+ if C = 0 or C = Container.Last then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ Lst := C;
+ C := HT_Ops.Next (Container.HT.all, C);
+ L := L + 1;
+ end loop;
+ if L = 0 then
+ return (Capacity => Container.Capacity,
+ Modulus => Container.Modulus,
+ K => Part,
+ HT => Container.HT,
+ Length => 0,
+ First => 0,
+ Last => 0);
+ else
+ return (Capacity => Container.Capacity,
+ Modulus => Container.Modulus,
+ K => Part,
+ HT => Container.HT,
+ Length => L,
+ First => Fst,
+ Last => Lst);
+ end if;
+ end Left;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Set) return Count_Type is
+ begin
+ case Container.K is
+ when Plain =>
+ return Container.HT.Length;
+ when Part =>
+ return Container.Length;
+ end case;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Set; Source : in out Set) is
+ HT : HT_Types.Hash_Table_Type renames Source.HT.all;
+ NN : HT_Types.Nodes_Type renames HT.Nodes;
+ X, Y : Count_Type;
+
+ begin
+
+ if Target.K /= Plain or Source.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ 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;
+
+ if HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Source (list is busy)";
+ end if;
+
+ Clear (Target);
+
+ if HT.Length = 0 then
+ return;
+ end if;
+
+ X := HT_Ops.First (HT);
+ while X /= 0 loop
+ Insert (Target, NN (X).Element); -- optimize???
+
+ Y := HT_Ops.Next (HT, X);
+
+ HT_Ops.Delete_Node_Sans_Free (HT, X);
+ Free (HT, 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_Unchecked
+ (Container : Set;
+ Position : Cursor) return Cursor
+ is
+ HT : Hash_Table_Type renames Container.HT.all;
+ Node : constant Count_Type := HT_Ops.Next (HT, Position.Node);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ if Container.K = Part and then Container.Last = Position.Node then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end Next_Unchecked;
+
+ 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 Next_Unchecked (Container, Position);
+ 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.HT.Nodes;
+ To_Node : Count_Type;
+ begin
+ if Length (Right) = 0 or Length (Left) = 0 then
+ return False;
+ end if;
+
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ Left_Node := First (Left).Node;
+
+ if Left.K = Plain then
+ To_Node := 0;
+ else
+ To_Node := Left.HT.Nodes (Left.Last).Next;
+ end if;
+
+ while Left_Node /= To_Node loop
+ declare
+ N : Node_Type renames Left_Nodes (Left_Node);
+ 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.HT.all, Left_Node);
+ end loop;
+
+ return False;
+ end Overlap;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor of Query_Element has no element";
+ end if;
+
+ pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
+
+ declare
+ HT : Hash_Table_Type renames Container.HT.all;
+
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (HT.Nodes (Position.Node).Element);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Set)
+ is
+ function Read_Node (Stream : not null access Root_Stream_Type'Class)
+ return Count_Type;
+
+ procedure Read_Nodes is
+ new HT_Ops.Generic_Read (Read_Node);
+
+ ---------------
+ -- Read_Node --
+ ---------------
+
+ function Read_Node (Stream : not null access Root_Stream_Type'Class)
+ return Count_Type
+ is
+ procedure Read_Element (Node : in out Node_Type);
+ pragma Inline (Read_Element);
+
+ procedure Allocate is
+ new Generic_Allocate (Read_Element);
+
+ procedure Read_Element (Node : in out Node_Type) is
+ begin
+ Element_Type'Read (Stream, Node.Element);
+ end Read_Element;
+
+ Node : Count_Type;
+
+ -- Start of processing for Read_Node
+
+ begin
+ Allocate (Container.HT.all, Node);
+ return Node;
+ end Read_Node;
+
+ -- Start of processing for Read
+ Result : HT_Access;
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error;
+ end if;
+
+ if Container.HT = null then
+ Result := new HT_Types.Hash_Table_Type (Container.Capacity,
+ Container.Modulus);
+ else
+ Result := Container.HT;
+ end if;
+
+ Read_Nodes (Stream, Result.all);
+ Container.HT := Result;
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream set cursor";
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Node : constant Count_Type :=
+ Element_Keys.Find (Container.HT.all, New_Item);
+
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Node = 0 then
+ raise Constraint_Error with
+ "attempt to replace element not in set";
+ end if;
+
+ if Container.HT.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
+ end if;
+
+ Container.HT.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 Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ 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.HT.all, Position.Node, New_Item);
+ end Replace_Element;
+
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ procedure Reserve_Capacity
+ (Container : in out Set;
+ Capacity : Count_Type)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+ if Capacity > Container.Capacity then
+ raise Constraint_Error with "requested capacity is too large";
+ end if;
+ end Reserve_Capacity;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Container : Set; Position : Cursor) return Set is
+ Last : Count_Type;
+ Lst : Count_Type;
+ L : Count_Type := 0;
+ C : Count_Type := Position.Node;
+ begin
+
+ if C = 0 then
+ return (Capacity => Container.Capacity,
+ Modulus => Container.Modulus,
+ K => Part,
+ HT => Container.HT,
+ Length => 0,
+ First => 0,
+ Last => 0);
+ end if;
+
+ if Container.K = Plain then
+ Lst := 0;
+ else
+ Lst := HT_Ops.Next (Container.HT.all, Container.Last);
+ end if;
+
+ if C = Lst then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+
+ while C /= Lst loop
+ if C = 0 then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ Last := C;
+ C := HT_Ops.Next (Container.HT.all, C);
+ L := L + 1;
+ end loop;
+
+ return (Capacity => Container.Capacity,
+ Modulus => Container.Modulus,
+ K => Part,
+ HT => Container.HT,
+ Length => L,
+ First => Position.Node,
+ Last => Last);
+ end Right;
+
+ ------------------
+ -- 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;
+
+ ------------------
+ -- Strict_Equal --
+ ------------------
+
+ function Strict_Equal (Left, Right : Set) return Boolean is
+ CuL : Cursor := First (Left);
+ CuR : Cursor := First (Right);
+ begin
+ if Length (Left) /= Length (Right) then
+ return False;
+ end if;
+
+ while CuL.Node /= 0 or CuR.Node /= 0 loop
+ if CuL.Node /= CuR.Node or else
+ Left.HT.Nodes (CuL.Node).Element /=
+ Right.HT.Nodes (CuR.Node).Element then
+ return False;
+ end if;
+ CuL := Next_Unchecked (Left, CuL);
+ CuR := Next_Unchecked (Right, CuR);
+ end loop;
+
+ return True;
+ end Strict_Equal;
+
+ --------------------------
+ -- 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
+ N : Node_Type renames Source.HT.Nodes (Source_Node);
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ if Is_In (Target.HT.all, N) then
+ Delete (Target, N.Element);
+ else
+ Insert (Target.HT.all, N.Element, X, B);
+ pragma Assert (B);
+ end if;
+ end Process;
+
+ -- Start of processing for Symmetric_Difference
+
+ begin
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ if Length (Target) = 0 then
+ Assign (Target, Source);
+ return;
+ end if;
+
+ if Target.HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
+ end if;
+
+ if Source.K = Plain then
+ Iterate (Source.HT.all);
+ else
+
+ if Source.Length = 0 then
+ return;
+ end if;
+
+ declare
+ Node : Count_Type := Source.First;
+ begin
+ while Node /= Source.HT.Nodes (Source.Last).Next loop
+ Process (Node);
+ Node := HT_Ops.Next (Source.HT.all, Node);
+ end loop;
+ end;
+ end if;
+
+ end Symmetric_Difference;
+
+ function Symmetric_Difference (Left, Right : Set) return Set is
+ C : Count_Type;
+ H : Hash_Type;
+
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
+
+ if Length (Right) = 0 then
+ return Left.Copy;
+ end if;
+
+ if Length (Left) = 0 then
+ return Right.Copy;
+ end if;
+
+ C := Length (Left) + Length (Right);
+ H := Default_Modulus (C);
+ return S : Set (C, H) do
+ Difference (Left, Right, S.HT.all);
+ Difference (Right, Left, S.HT.all);
+ end return;
+ end Symmetric_Difference;
+
+ ------------
+ -- To_Set --
+ ------------
+
+ function To_Set (New_Item : Element_Type) return Set is
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ return S : Set (Capacity => 1, Modulus => 1) do
+ Insert (S.HT.all, New_Item, 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.HT.Nodes (Src_Node);
+ E : Element_Type renames N.Element;
+
+ X : Count_Type;
+ B : Boolean;
+
+ begin
+ Insert (Target.HT.all, E, X, B);
+ end Process;
+
+ -- Start of processing for Union
+
+ begin
+
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
+ end if;
+
+ if Source.K = Plain then
+ Iterate (Source.HT.all);
+ else
+
+ if Source.Length = 0 then
+ return;
+ end if;
+
+ declare
+ Node : Count_Type := Source.First;
+ begin
+ while Node /= Source.HT.Nodes (Source.Last).Next loop
+ Process (Node);
+ Node := HT_Ops.Next (Source.HT.all, Node);
+ end loop;
+ end;
+ end if;
+ end Union;
+
+ function Union (Left, Right : Set) return Set is
+ C : Count_Type;
+ H : Hash_Type;
+
+ begin
+ if Left'Address = Right'Address then
+ return Left.Copy;
+ end if;
+
+ if Length (Right) = 0 then
+ return Left.Copy;
+ end if;
+
+ if Length (Left) = 0 then
+ return Right.Copy;
+ end if;
+
+ C := Length (Left) + Length (Right);
+ H := Default_Modulus (C);
+ return S : Set (C, H) do
+ Assign (Target => S, Source => Left);
+ Union (Target => S, Source => Right);
+ end return;
+ end Union;
+
+ ---------
+ -- Vet --
+ ---------
+
+ function Vet (Container : Set; Position : Cursor) return Boolean is
+ begin
+ if Position.Node = 0 then
+ return True;
+ end if;
+
+ declare
+ S : Set renames Container;
+ N : Nodes_Type renames S.HT.Nodes;
+ X : Count_Type;
+
+ begin
+ if S.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.HT.Buckets (Element_Keys.Index (S.HT.all,
+ N (Position.Node).Element));
+
+ for J in 1 .. S.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;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Set)
+ is
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type);
+ pragma Inline (Write_Node);
+
+ procedure Write_Nodes is
+ new HT_Ops.Generic_Write (Write_Node);
+
+ ----------------
+ -- Write_Node --
+ ----------------
+
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type)
+ is
+ begin
+ Element_Type'Write (Stream, Node.Element);
+ end Write_Node;
+
+ -- Start of processing for Write
+
+ begin
+ Write_Nodes (Stream, Container.HT.all);
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream set cursor";
+ end Write;
+ package body Generic_Keys 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_Bounded_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
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ Key_Keys.Delete_Key_Sans_Free (Container.HT.all, Key, X);
+
+ if X = 0 then
+ raise Constraint_Error with "attempt to delete key not in set";
+ end if;
+
+ Free (Container.HT.all, 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.HT.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
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ Key_Keys.Delete_Key_Sans_Free (Container.HT.all, Key, X);
+ Free (Container.HT.all, X);
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (Container : Set;
+ Key : Key_Type) return Cursor
+ is
+ begin
+ if Container.K = Plain then
+ declare
+ Node : constant Count_Type :=
+ Key_Keys.Find (Container.HT.all, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ else
+ declare
+ function Find_Between
+ (HT : Hash_Table_Type;
+ Key : Key_Type;
+ From : Count_Type;
+ To : Count_Type) return Count_Type;
+
+ function Find_Between
+ (HT : Hash_Table_Type;
+ Key : Key_Type;
+ From : Count_Type;
+ To : Count_Type) return Count_Type is
+
+ Indx : Hash_Type;
+ Indx_From : constant Hash_Type :=
+ Key_Keys.Index (HT, Generic_Keys.Key
+ (HT.Nodes (From).Element));
+ Indx_To : constant Hash_Type :=
+ Key_Keys.Index (HT, Generic_Keys.Key
+ (HT.Nodes (To).Element));
+ Node : Count_Type;
+ To_Node : Count_Type;
+
+ begin
+
+ Indx := Key_Keys.Index (HT, Key);
+
+ if Indx < Indx_From or Indx > Indx_To then
+ return 0;
+ end if;
+
+ if Indx = Indx_From then
+ Node := From;
+ else
+ Node := HT.Buckets (Indx);
+ end if;
+
+ if Indx = Indx_To then
+ To_Node := HT.Nodes (To).Next;
+ else
+ To_Node := 0;
+ end if;
+
+ while Node /= To_Node loop
+ if Equivalent_Key_Node (Key, HT.Nodes (Node)) then
+ return Node;
+ end if;
+ Node := HT.Nodes (Node).Next;
+ end loop;
+
+ return 0;
+ end Find_Between;
+
+ begin
+ if Container.Length = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Find_Between (Container.HT.all, Key,
+ Container.First, Container.Last));
+ end;
+ end if;
+ end Find;
+
+ ---------
+ -- 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
+ HT : Hash_Table_Type renames Container.HT.all;
+ N : Node_Type renames HT.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
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ declare
+ Node : constant Count_Type :=
+ Key_Keys.Find (Container.HT.all, Key);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "attempt to replace key not in set";
+ end if;
+
+ Replace_Element (Container.HT.all, Node, New_Item);
+ end;
+ end Replace;
+
+ -----------------------------------
+ -- Update_Element_Preserving_Key --
+ -----------------------------------
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type))
+ is
+ Indx : Hash_Type;
+ N : Nodes_Type renames Container.HT.Nodes;
+
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Position.Node = 0 then
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
+ end if;
+
+ -- ???
+ -- if HT.Buckets = null
+ -- or else HT.Buckets'Length = 0
+ -- or else HT.Length = 0
+ -- or else Position.Node.Next = Position.Node
+ -- then
+ -- raise Program_Error with
+ -- "Position cursor is bad (set is empty)";
+ -- end if;
+
+ pragma Assert
+ (Vet (Container, Position),
+ "bad cursor in Update_Element_Preserving_Key");
+
+ -- Record bucket now, in case key is changed.
+ Indx := HT_Ops.Index (Container.HT.Buckets, N (Position.Node));
+
+ declare
+ E : Element_Type renames N (Position.Node).Element;
+ K : constant Key_Type := Key (E);
+
+ B : Natural renames Container.HT.Busy;
+ L : Natural renames Container.HT.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+
+ if Equivalent_Keys (K, Key (E)) then
+ pragma Assert (Hash (K) = Hash (E));
+ return;
+ end if;
+ end;
+
+ -- Key was modified, so remove this node from set.
+
+ if Container.HT.Buckets (Indx) = Position.Node then
+ Container.HT.Buckets (Indx) := N (Position.Node).Next;
+
+ else
+ declare
+ Prev : Count_Type := Container.HT.Buckets (Indx);
+
+ begin
+ while N (Prev).Next /= Position.Node loop
+ Prev := N (Prev).Next;
+
+ if Prev = 0 then
+ raise Program_Error with
+ "Position cursor is bad (node not found)";
+ end if;
+ end loop;
+
+ N (Prev).Next := N (Position.Node).Next;
+ end;
+ end if;
+
+ Container.Length := Container.Length - 1;
+ Free (Container.HT.all, Position.Node);
+
+ raise Program_Error with "key was modified";
+ end Update_Element_Preserving_Key;
+
+ end Generic_Keys;
+
+end Ada.Containers.Formal_Hashed_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 _ H A S H E D _ S E T S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2010, 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/>. --
+------------------------------------------------------------------------------
+
+private with Ada.Containers.Hash_Tables;
+private with Ada.Streams;
+
+with Ada.Containers;
+use Ada.Containers;
+
+generic
+ type Element_Type is private;
+
+ with function Hash (Element : Element_Type) return Hash_Type;
+
+ with function Equivalent_Elements (Left, Right : Element_Type)
+ return Boolean;
+
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Formal_Hashed_Sets is
+ pragma Pure;
+
+ type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
+ -- pragma Preelaborable_Initialization (Set);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_Set : constant Set;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Set) return Boolean;
+
+ function Equivalent_Sets (Left, Right : Set) return Boolean;
+
+ function To_Set (New_Item : Element_Type) return Set;
+
+ function Capacity (Container : Set) return Count_Type;
+
+ procedure Reserve_Capacity
+ (Container : in out Set;
+ Capacity : Count_Type);
+
+ function Length (Container : Set) return Count_Type;
+
+ function Is_Empty (Container : Set) return Boolean;
+
+ procedure Clear (Container : in out Set);
+
+ procedure Assign (Target : in out Set; Source : Set);
+
+ function Copy (Source : Set;
+ Capacity : Count_Type := 0) return Set;
+
+ function Element (Container : Set; Position : Cursor) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Set;
+ Position : Cursor;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Move (Target : in out Set; Source : in out Set);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert (Container : in out Set; New_Item : Element_Type);
+
+ procedure Include (Container : in out Set; New_Item : Element_Type);
+
+ procedure Replace (Container : in out Set; New_Item : Element_Type);
+
+ procedure Exclude (Container : in out Set; Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Item : Element_Type);
+
+ procedure Delete (Container : in out Set; Position : in out Cursor);
+
+ procedure Union (Target : in out Set; Source : Set);
+
+ function Union (Left, Right : Set) return Set;
+
+ function "or" (Left, Right : Set) return Set renames Union;
+
+ procedure Intersection (Target : in out Set; Source : Set);
+
+ function Intersection (Left, Right : Set) return Set;
+
+ function "and" (Left, Right : Set) return Set renames Intersection;
+
+ procedure Difference (Target : in out Set; Source : Set);
+
+ function Difference (Left, Right : Set) return Set;
+
+ function "-" (Left, Right : Set) return Set renames Difference;
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set);
+
+ function Symmetric_Difference (Left, Right : Set) return Set;
+
+ function "xor" (Left, Right : Set) return Set
+ renames Symmetric_Difference;
+
+ function Overlap (Left, Right : Set) return Boolean;
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
+
+ function First (Container : Set) return Cursor;
+
+ function Next (Container : Set; Position : Cursor) return Cursor;
+
+ procedure Next (Container : Set; Position : in out Cursor);
+
+ function Find
+ (Container : Set;
+ Item : Element_Type) return Cursor;
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean;
+
+ function Has_Element (Container : Set; Position : Cursor) return Boolean;
+
+ function Equivalent_Elements (Left : Set; CLeft : Cursor;
+ Right : Set; CRight : Cursor) return Boolean;
+
+ function Equivalent_Elements
+ (Left : Set; CLeft : Cursor;
+ Right : Element_Type) return Boolean;
+
+ function Equivalent_Elements
+ (Left : Element_Type;
+ Right : Set; CRight : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Set;
+ Process :
+ not null access procedure (Container : Set; Position : Cursor));
+
+ function Default_Modulus (Capacity : Count_Type) return Hash_Type;
+
+ 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 is
+
+ function Key (Container : Set; Position : Cursor) return Key_Type;
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type;
+
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Exclude (Container : in out Set; Key : Key_Type);
+
+ procedure Delete (Container : in out Set; Key : Key_Type);
+
+ function Find (Container : Set; Key : Key_Type) return Cursor;
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean;
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type));
+
+ end Generic_Keys;
+
+ function Strict_Equal (Left, Right : Set) return Boolean;
+
+ function Left (Container : Set; Position : Cursor) return Set;
+
+ function Right (Container : Set; Position : Cursor) return Set;
+
+private
+
+ pragma Inline (Next);
+
+ type Node_Type is
+ record
+ Element : Element_Type;
+ Next : Count_Type;
+ Has_Element : Boolean := False;
+ end record;
+
+ package HT_Types is
+ new Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types
+ (Node_Type);
+
+ type HT_Access is access all HT_Types.Hash_Table_Type;
+
+ type Kind is (Plain, Part);
+
+ type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged record
+ HT : HT_Access :=
+ new HT_Types.Hash_Table_Type'(Capacity, Modulus,
+ others => <>);
+ K : Kind := Plain;
+ Length : Count_Type := 0;
+ First : Count_Type := 0;
+ Last : Count_Type := 0;
+ end record;
+
+ use HT_Types;
+ use Ada.Streams;
+
+ type Cursor is
+ record
+ Node : Count_Type;
+ end record;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor);
+
+ for Cursor'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor);
+
+ for Cursor'Read use Read;
+
+ No_Element : constant Cursor := (Node => 0);
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Set);
+
+ for Set'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Set);
+
+ for Set'Read use Read;
+
+ Empty_Set : constant Set := (Capacity => 0, Modulus => 0, others => <>);
+
+end Ada.Containers.Formal_Hashed_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 _ O R D E R E D _ M A P S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2010, 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 System; use type System.Address;
+
+package body Ada.Containers.Formal_Ordered_Maps is
+
+ -----------------------------
+ -- 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);
+
+ function Parent (Node : Node_Type) return Count_Type;
+ pragma Inline (Parent);
+
+ function Right_Son (Node : Node_Type) return Count_Type;
+ pragma Inline (Right);
+
+ 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 --
+ -----------------------
+
+ 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 Tree_Types.Tree_Type; 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);
+
+ function Next_Unchecked
+ (Container : Map;
+ Position : Count_Type) return Count_Type;
+
+ --------------------------
+ -- 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 := First (Left).Node;
+ 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.Tree.all, Last (Left).Node);
+ while Node /= Lst loop
+ ENode := Find (Right, Left.Tree.Nodes (Node).Key).Node;
+ if ENode = 0 or else
+ Left.Tree.Nodes (Node).Element /= Right.Tree.Nodes (ENode).Element
+ then
+ return False;
+ end if;
+ Node := Next (Left.Tree.all, 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.Tree.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.Tree.all, 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.Tree.all,
+ Hint => 0,
+ Key => SN.Key,
+ Node => Target_Node);
+ end Append_Element;
+
+ -- Start of processing for Assign
+
+ begin
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ 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.Tree.all);
+
+ if Source.K = Plain then
+ Append_Elements (Source.Tree.all);
+ else
+ declare
+ X : Count_Type;
+ begin
+ X := Source.First;
+ while X /= Next (Source.Tree.all, Source.Last) loop
+ Append_Element (X);
+ X := Next (Source.Tree.all, X);
+ end loop;
+ end;
+ end if;
+ end Assign;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Map; Key : Key_Type) return Cursor is
+ begin
+
+ if Container.K = Part then
+ if Container.Length = 0 then
+ return No_Element;
+ end if;
+
+ if Key < Container.Tree.Nodes (Container.First).Key then
+ return (Node => Container.First);
+ end if;
+
+ if Container.Tree.Nodes (Container.Last).Key < Key then
+ return No_Element;
+ end if;
+ end if;
+
+ declare
+ Node : constant Count_Type :=
+ Key_Ops.Ceiling (Container.Tree.all, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end Ceiling;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Map) is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ Tree_Operations.Clear_Tree (Container.Tree.all);
+ end Clear;
+
+ -----------
+ -- Color --
+ -----------
+
+ function Color (Node : Node_Type) return Color_Type is
+ begin
+ return Node.Color;
+ end Color;
+
+ --------------
+ -- 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;
+ Cu : Cursor;
+ begin
+ return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do
+ if Length (Source) > 0 then
+ Target.Tree.Length := Source.Tree.Length;
+ Target.Tree.Root := Source.Tree.Root;
+ Target.Tree.First := Source.Tree.First;
+ Target.Tree.Last := Source.Tree.Last;
+ Target.Tree.Free := Source.Tree.Free;
+
+ while Node <= Source.Capacity loop
+ Target.Tree.Nodes (Node).Element :=
+ Source.Tree.Nodes (Node).Element;
+ Target.Tree.Nodes (Node).Key :=
+ Source.Tree.Nodes (Node).Key;
+ Target.Tree.Nodes (Node).Parent :=
+ Source.Tree.Nodes (Node).Parent;
+ Target.Tree.Nodes (Node).Left :=
+ Source.Tree.Nodes (Node).Left;
+ Target.Tree.Nodes (Node).Right :=
+ Source.Tree.Nodes (Node).Right;
+ Target.Tree.Nodes (Node).Color :=
+ Source.Tree.Nodes (Node).Color;
+ Target.Tree.Nodes (Node).Has_Element :=
+ Source.Tree.Nodes (Node).Has_Element;
+ Node := Node + 1;
+ end loop;
+
+ while Node <= Target.Capacity loop
+ N := Node;
+ Formal_Ordered_Maps.Free (Tree => Target.Tree.all, X => N);
+ Node := Node + 1;
+ end loop;
+
+ if Source.K = Part then
+ Node := Target.Tree.First;
+ while Node /= Source.First loop
+ Cu := (Node => Node);
+ Node := Next (Target.Tree.all, Node);
+ Delete (Target, Cu);
+ end loop;
+
+ Node := Next (Target.Tree.all, Source.Last);
+
+ while Node /= 0 loop
+ Cu := (Node => Node);
+ Node := Next (Target.Tree.all, Node);
+ Delete (Target, Cu);
+ end loop;
+ end if;
+ end if;
+ end return;
+ end Copy;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Map; Position : in out Cursor) is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor of Delete has no element";
+ end if;
+
+ pragma Assert (Vet (Container.Tree.all, Position.Node),
+ "Position cursor of Delete is bad");
+
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all,
+ Position.Node);
+ Formal_Ordered_Maps.Free (Container.Tree.all, Position.Node);
+ end Delete;
+
+ procedure Delete (Container : in out Map; Key : Key_Type) is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+ declare
+ X : constant Node_Access := Key_Ops.Find (Container.Tree.all, Key);
+
+ begin
+ if X = 0 then
+ raise Constraint_Error with "key not in map";
+ end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
+ Formal_Ordered_Maps.Free (Container.Tree.all, X);
+ end;
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First (Container : in out Map) is
+ X : constant Node_Access := First (Container).Node;
+
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
+ Formal_Ordered_Maps.Free (Container.Tree.all, 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 Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
+ Formal_Ordered_Maps.Free (Container.Tree.all, 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.Tree.all, Position.Node),
+ "Position cursor of function Element is bad");
+
+ return Container.Tree.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.Tree.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.Tree.all, Key);
+
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
+ Formal_Ordered_Maps.Free (Container.Tree.all, X);
+ end if;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Map; Key : Key_Type) return Cursor is
+ begin
+ if Container.K = Part then
+ if Container.Length = 0 then
+ return No_Element;
+ end if;
+
+ if Key < Container.Tree.Nodes (Container.First).Key or
+ Container.Tree.Nodes (Container.Last).Key < Key then
+ return No_Element;
+ end if;
+ end if;
+
+ declare
+ Node : constant Count_Type :=
+ Key_Ops.Find (Container.Tree.all, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Map) return Cursor is
+ begin
+ if Length (Container) = 0 then
+ return No_Element;
+ end if;
+
+ if Container.K = Plain then
+ return (Node => Container.Tree.First);
+ else
+ return (Node => Container.First);
+ end if;
+
+ 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.Tree.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.Tree.Nodes (First (Container).Node).Key;
+ end First_Key;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Map; Key : Key_Type) return Cursor is
+ begin
+
+ if Container.K = Part then
+ if Container.Length = 0 then
+ return No_Element;
+ end if;
+
+ if Key < Container.Tree.Nodes (Container.First).Key then
+ return No_Element;
+ end if;
+
+ if Container.Tree.Nodes (Container.Last).Key < Key then
+ return (Node => Container.Last);
+ end if;
+ end if;
+
+ declare
+ Node : constant Count_Type :=
+ Key_Ops.Floor (Container.Tree.all, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end Floor;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free
+ (Tree : in out Tree_Types.Tree_Type;
+ X : Count_Type)
+ is
+ begin
+ Tree.Nodes (X).Has_Element := False;
+ Tree_Operations.Free (Tree, 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;
+
+ if not Container.Tree.Nodes (Position.Node).Has_Element then
+ return False;
+ end if;
+
+ if Container.K = Plain then
+ return True;
+ end if;
+
+ declare
+ Key : constant Key_Type := Container.Tree.Nodes (Position.Node).Key;
+ begin
+
+ if Key < Container.Tree.Nodes (Container.First).Key or
+ Container.Tree.Nodes (Container.Last).Key < Key then
+ return False;
+ end if;
+
+ return True;
+ end;
+ 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
+ if Container.Tree.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (map is locked)";
+ end if;
+
+ declare
+ N : Node_Type renames Container.Tree.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
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ declare
+ function New_Node return Node_Access;
+
+ 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.Tree.all, X);
+ return X;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Insert_Sans_Hint
+ (Container.Tree.all,
+ Key,
+ Position.Node,
+ Inserted);
+ end;
+ 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;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ declare
+ function New_Node return Node_Access;
+
+ 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;
+ end Initialize;
+
+ X : Node_Access;
+
+ begin
+ Allocate_Node (Container.Tree.all, X);
+ return X;
+ end New_Node;
+
+ -- Start of processing for Insert
+
+ begin
+ Insert_Sans_Hint
+ (Container.Tree.all,
+ Key,
+ Position.Node,
+ Inserted);
+ end;
+ 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;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Map;
+ Process :
+ not null access procedure (Container : Map; Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Tree_Operations.Generic_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Container, (Node => Node));
+ end Process_Node;
+
+ B : Natural renames Container.Tree.all.Busy;
+
+ -- Start of processing for Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+
+ if Container.K = Plain then
+ Local_Iterate (Container.Tree.all);
+ return;
+ end if;
+
+ if Container.Length = 0 then
+ return;
+ end if;
+
+ declare
+ FElt : constant Key_Type :=
+ Container.Tree.Nodes (Container.First).Key;
+ TElt : constant Key_Type :=
+ Container.Tree.Nodes (Container.Last).Key;
+
+ procedure Iterate (P : Count_Type);
+
+ procedure Iterate (P : Count_Type) is
+ X : Count_Type := P;
+ begin
+ while X /= 0 loop
+ if Container.Tree.Nodes (X).Key < FElt then
+ X := Container.Tree.Nodes (X).Right;
+ elsif TElt < Container.Tree.Nodes (X).Key then
+ X := Container.Tree.Nodes (X).Left;
+ else
+ Iterate (Container.Tree.Nodes (X).Left);
+ Process_Node (X);
+ X := Container.Tree.Nodes (X).Right;
+ end if;
+ end loop;
+ end Iterate;
+
+ begin
+ Iterate (Container.Tree.Root);
+ end;
+
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Iterate;
+
+ ---------
+ -- 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.Tree.all, Position.Node),
+ "Position cursor of function Key is bad");
+
+ return Container.Tree.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;
+
+ if Container.K = Plain then
+ return (Node => Container.Tree.Last);
+ end if;
+
+ return (Node => Container.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.Tree.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.Tree.Nodes (Last (Container).Node).Key;
+ end Last_Key;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Container : Map; Position : Cursor) return Map is
+ Lst : Count_Type;
+ Fst : constant Count_Type := First (Container).Node;
+ L : Count_Type := 0;
+ C : Count_Type := Fst;
+ begin
+ while C /= Position.Node loop
+ if C = Last (Container).Node or C = 0 then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ Lst := C;
+ C := Next (Container.Tree.all, C);
+ L := L + 1;
+ end loop;
+ if L = 0 then
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Tree => Container.Tree,
+ Length => 0,
+ First => 0,
+ Last => 0);
+ else
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Tree => Container.Tree,
+ Length => L,
+ First => Fst,
+ Last => Lst);
+ end if;
+ end Left;
+
+ --------------
+ -- 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
+ if Container.K = Plain then
+ return Container.Tree.Length;
+ else
+ return Container.Length;
+ end if;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Map; Source : in out Map) is
+ NN : Tree_Types.Nodes_Type renames Source.Tree.Nodes;
+ X : Node_Access;
+
+ begin
+ if Target.K /= Plain or Source.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ 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;
+
+ if Source.Tree.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Source (list is busy)";
+ 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.Tree.all, X);
+ Formal_Ordered_Maps.Free (Source.Tree.all, X);
+ end loop;
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next_Unchecked
+ (Container : Map;
+ Position : Count_Type) return Count_Type is
+ begin
+
+ if Container.K = Part and then
+ (Container.Length = 0 or Position = Container.Last) then
+ return 0;
+ end if;
+
+ return Tree_Operations.Next (Container.Tree.all, Position);
+ end Next_Unchecked;
+
+ 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.Tree.all, Position.Node),
+ "bad cursor in Next");
+
+ return (Node => Next_Unchecked (Container, Position.Node));
+ end Next;
+
+ -------------
+ -- Overlap --
+ -------------
+
+ function Overlap (Left, Right : Map) return Boolean is
+ begin
+
+ if Length (Left) = 0 or Length (Right) = 0 then
+ return False;
+ end if;
+
+ declare
+
+ L_Node : Count_Type := First (Left).Node;
+ R_Node : Count_Type := First (Right).Node;
+
+ L_Last : constant Count_Type :=
+ Next (Left.Tree.all, Last (Left).Node);
+ R_Last : constant Count_Type :=
+ Next (Right.Tree.all, Last (Right).Node);
+
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ loop
+ if L_Node = L_Last
+ or else R_Node = R_Last
+ then
+ return False;
+ end if;
+
+ if Left.Tree.Nodes (L_Node).Key
+ < Right.Tree.Nodes (R_Node).Key then
+ L_Node := Next (Left.Tree.all, L_Node);
+ elsif Right.Tree.Nodes (R_Node).Key
+ < Left.Tree.Nodes (L_Node).Key then
+ R_Node := Next (Right.Tree.all, R_Node);
+
+ else
+ return True;
+ end if;
+ end loop;
+ end;
+ end Overlap;
+
+ ------------
+ -- 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.Tree.all, Position.Node),
+ "bad cursor in Previous");
+
+ if Container.K = Part and then
+ (Container.Length = 0 or Position.Node = Container.First) then
+ return No_Element;
+ end if;
+
+ declare
+ Tree : Tree_Types.Tree_Type renames Container.Tree.all;
+ Node : constant Count_Type :=
+ Tree_Operations.Previous (Tree, Position.Node);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access procedure (Key : Key_Type;
+ Element : Element_Type))
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor of Query_Element has no element";
+ end if;
+
+ pragma Assert (Vet (Container.Tree.all, Position.Node),
+ "Position cursor of Query_Element is bad");
+
+ declare
+ T : Tree_Types.Tree_Type renames Container.Tree.all;
+
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ declare
+ N : Node_Type renames T.Nodes (Position.Node);
+ K : Key_Type renames N.Key;
+ E : Element_Type renames N.Element;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Map)
+ is
+ procedure Read_Element (Node : in out Node_Type);
+ pragma Inline (Read_Element);
+
+ procedure Allocate is
+ new Generic_Allocate (Read_Element);
+
+ procedure Read_Elements is
+ new Tree_Operations.Generic_Read (Allocate);
+
+ ------------------
+ -- Read_Element --
+ ------------------
+
+ procedure Read_Element (Node : in out Node_Type) is
+ begin
+ Key_Type'Read (Stream, Node.Key);
+ Element_Type'Read (Stream, Node.Element);
+ end Read_Element;
+
+ -- Start of processing for Read
+ Result : Tree_Type_Access;
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error;
+ end if;
+
+ if Container.Tree = null then
+ Result := new Tree_Types.Tree_Type (Container.Capacity);
+ else
+ Result := Container.Tree;
+ end if;
+
+ Read_Elements (Stream, Result.all);
+ Container.Tree := Result;
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream map cursor";
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ declare
+ Node : constant Node_Access := Key_Ops.Find (Container.Tree.all, Key);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with "key not in map";
+ end if;
+
+ if Container.Tree.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (map is locked)";
+ end if;
+
+ declare
+ N : Node_Type renames Container.Tree.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 Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor of Replace_Element has no element";
+ end if;
+
+ if Container.Tree.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (map is locked)";
+ end if;
+
+ pragma Assert (Vet (Container.Tree.all, Position.Node),
+ "Position cursor of Replace_Element is bad");
+
+ Container.Tree.Nodes (Position.Node).Element := New_Item;
+ end Replace_Element;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Map;
+ Process :
+ not null access procedure (Container : Map; Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Container, (Node => Node));
+ end Process_Node;
+
+ B : Natural renames Container.Tree.Busy;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+
+ if Container.K = Plain then
+ Local_Reverse_Iterate (Container.Tree.all);
+ return;
+ end if;
+
+ if Container.Length = 0 then
+ return;
+ end if;
+
+ declare
+ FElt : constant Key_Type :=
+ Container.Tree.Nodes (Container.First).Key;
+ TElt : constant Key_Type :=
+ Container.Tree.Nodes (Container.Last).Key;
+
+ procedure Iterate (P : Count_Type);
+
+ procedure Iterate (P : Count_Type) is
+ X : Count_Type := P;
+ begin
+ while X /= 0 loop
+ if Container.Tree.Nodes (X).Key < FElt then
+ X := Container.Tree.Nodes (X).Right;
+ elsif TElt < Container.Tree.Nodes (X).Key then
+ X := Container.Tree.Nodes (X).Left;
+ else
+ Iterate (Container.Tree.Nodes (X).Right);
+ Process_Node (X);
+ X := Container.Tree.Nodes (X).Left;
+ end if;
+ end loop;
+ end Iterate;
+
+ begin
+ Iterate (Container.Tree.Root);
+ end;
+
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Container : Map; Position : Cursor) return Map is
+ Lst : Count_Type;
+ L : Count_Type := 0;
+ C : Count_Type := Position.Node;
+ begin
+
+ if C = 0 then
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Tree => Container.Tree,
+ Length => 0,
+ First => 0,
+ Last => 0);
+ end if;
+
+ if Container.K = Plain then
+ Lst := 0;
+ else
+ Lst := Next (Container.Tree.all, Container.Last);
+ end if;
+
+ if C = Lst then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+
+ while C /= Lst loop
+ if C = 0 then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ C := Next (Container.Tree.all, C);
+ L := L + 1;
+ end loop;
+
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Tree => Container.Tree,
+ Length => L,
+ First => Position.Node,
+ Last => Last (Container).Node);
+ end Right;
+
+ ---------------
+ -- 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;
+
+ ------------------
+ -- Strict_Equal --
+ ------------------
+
+ function Strict_Equal (Left, Right : Map) return Boolean is
+ LNode : Count_Type := First (Left).Node;
+ RNode : Count_Type := First (Right).Node;
+ begin
+ if Length (Left) /= Length (Right) then
+ return False;
+ end if;
+
+ while LNode = RNode loop
+ if LNode = 0 then
+ return True;
+ end if;
+
+ if Left.Tree.Nodes (LNode).Element /=
+ Right.Tree.Nodes (RNode).Element or
+ Left.Tree.Nodes (LNode).Key /= Right.Tree.Nodes (RNode).Key then
+ exit;
+ end if;
+
+ LNode := Next_Unchecked (Left, LNode);
+ RNode := Next_Unchecked (Right, RNode);
+ end loop;
+ return False;
+ end Strict_Equal;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access procedure (Key : Key_Type;
+ Element : in out Element_Type))
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor of Update_Element has no element";
+ end if;
+
+ pragma Assert (Vet (Container.Tree.all, Position.Node),
+ "Position cursor of Update_Element is bad");
+
+ declare
+ T : Tree_Types.Tree_Type renames Container.Tree.all;
+
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ declare
+ N : Node_Type renames T.Nodes (Position.Node);
+ K : Key_Type renames N.Key;
+ E : Element_Type renames N.Element;
+
+ begin
+ Process (K, E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Map)
+ is
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type);
+ pragma Inline (Write_Node);
+
+ procedure Write_Nodes is
+ new Tree_Operations.Generic_Write (Write_Node);
+
+ ----------------
+ -- Write_Node --
+ ----------------
+
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type)
+ is
+ begin
+ Key_Type'Write (Stream, Node.Key);
+ Element_Type'Write (Stream, Node.Element);
+ end Write_Node;
+
+ -- Start of processing for Write
+
+ begin
+ Write_Nodes (Stream, Container.Tree.all);
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream map cursor";
+ end Write;
+
+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 _ M A P S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2010, 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/>. --
+------------------------------------------------------------------------------
+
+private with Ada.Containers.Red_Black_Trees;
+private with Ada.Streams;
+with Ada.Containers; use Ada.Containers;
+
+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 is
+ pragma Pure;
+
+ function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
+
+ type Map (Capacity : Count_Type) is tagged private;
+ -- pragma Preelaborable_Initialization (Map);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_Map : constant Map;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Map) return Boolean;
+
+ function Length (Container : Map) return Count_Type;
+
+ function Is_Empty (Container : Map) return Boolean;
+
+ procedure Clear (Container : in out Map);
+
+ procedure Assign (Target : in out Map; Source : Map);
+
+ function Copy (Source : Map; Capacity : Count_Type := 0) return Map;
+
+ function Key (Container : Map; Position : Cursor) return Key_Type;
+
+ function Element (Container : Map; Position : Cursor) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Map;
+ Position : Cursor;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : Element_Type));
+
+ procedure Update_Element
+ (Container : in out Map;
+ Position : Cursor;
+ Process : not null access
+ procedure (Key : Key_Type; Element : in out Element_Type));
+
+ procedure Move (Target : in out Map; Source : in out Map);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Include
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Replace
+ (Container : in out Map;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Exclude (Container : in out Map; Key : Key_Type);
+
+ procedure Delete (Container : in out Map; Key : Key_Type);
+
+ procedure Delete (Container : in out Map; Position : in out Cursor);
+
+ procedure Delete_First (Container : in out Map);
+
+ procedure Delete_Last (Container : in out Map);
+
+ function First (Container : Map) return Cursor;
+
+ function First_Element (Container : Map) return Element_Type;
+
+ function First_Key (Container : Map) return Key_Type;
+
+ function Last (Container : Map) return Cursor;
+
+ function Last_Element (Container : Map) return Element_Type;
+
+ function Last_Key (Container : Map) return Key_Type;
+
+ function Next (Container : Map; Position : Cursor) return Cursor;
+
+ procedure Next (Container : Map; Position : in out Cursor);
+
+ function Previous (Container : Map; Position : Cursor) return Cursor;
+
+ procedure Previous (Container : Map; Position : in out Cursor);
+
+ function Find (Container : Map; Key : Key_Type) return Cursor;
+
+ function Element (Container : Map; Key : Key_Type) return Element_Type;
+
+ function Floor (Container : Map; Key : Key_Type) return Cursor;
+
+ function Ceiling (Container : Map; Key : Key_Type) return Cursor;
+
+ function Contains (Container : Map; Key : Key_Type) return Boolean;
+
+ function Has_Element (Container : Map; Position : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Map;
+ Process :
+ not null access procedure (Container : Map; Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Map;
+ Process :
+ not null access procedure (Container : Map; Position : Cursor));
+
+ function Strict_Equal (Left, Right : Map) return Boolean;
+
+ function Left (Container : Map; Position : Cursor) return Map;
+
+ function Right (Container : Map; Position : Cursor) return Map;
+
+ function Overlap (Left, Right : Map) return Boolean;
+
+private
+
+ 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;
+ Left : Node_Access;
+ Right : Node_Access;
+ Color : Red_Black_Trees.Color_Type := Red;
+ Key : Key_Type;
+ Element : Element_Type;
+ end record;
+
+ type Kind is (Plain, Part);
+
+ package Tree_Types is
+ new Ada.Containers.Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
+
+ type Tree_Type_Access is access all Tree_Types.Tree_Type;
+
+ type Map (Capacity : Count_Type) is tagged record
+ Tree : Tree_Type_Access := new Tree_Types.Tree_Type (Capacity);
+ K : Kind := Plain;
+ Length : Count_Type := 0;
+ First : Count_Type := 0;
+ Last : Count_Type := 0;
+ end record;
+
+ use Ada.Streams;
+
+ type Map_Access is access all Map;
+ for Map_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Node : Node_Access;
+ end record;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor);
+
+ for Cursor'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor);
+
+ for Cursor'Read use Read;
+
+ No_Element : constant Cursor := (Node => 0);
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Map);
+
+ for Map'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Map);
+
+ for Map'Read use Read;
+
+ Empty_Map : constant Map := (Capacity => 0, others => <>);
+
+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, 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 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);
+
+ function Parent (Node : Node_Type) return Count_Type;
+ pragma Inline (Parent);
+
+ function Right_Son (Node : Node_Type) return Count_Type;
+ pragma Inline (Right);
+
+ 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 --
+ -----------------------
+
+ 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 Assign (Target : in out Tree_Types.Tree_Type;
+ Source : Tree_Types.Tree_Type);
+
+ procedure Clear (Container : in out Tree_Types.Tree_Type);
+
+ procedure Free (Tree : in out Tree_Types.Tree_Type; 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);
+
+ generic
+ with procedure Process (Node : Count_Type) is <>;
+ procedure Iterate_Between (Tree : Tree_Types.Tree_Type;
+ From : Count_Type;
+ To : Count_Type);
+
+ function Next_Unchecked
+ (Container : Set;
+ Position : Count_Type) return Count_Type;
+
+ procedure Replace_Element
+ (Tree : in out Tree_Types.Tree_Type;
+ 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 := First (Left).Node;
+ 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.Tree.all, Last (Left).Node);
+ while Node /= Lst loop
+ ENode := Find (Right, Left.Tree.Nodes (Node).Element).Node;
+ if ENode = 0 or else
+ Left.Tree.Nodes (Node).Element /= Right.Tree.Nodes (ENode).Element
+ then
+ return False;
+ end if;
+ Node := Next (Left.Tree.all, 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;
+
+ 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
+ X : Count_Type;
+ begin
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ 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;
+
+ if Source.K = Plain then
+ Assign (Target => Target.Tree.all, Source => Source.Tree.all);
+ else
+ declare
+ procedure Append_Element (Source_Node : Count_Type);
+
+ procedure Append_Element (Source_Node : Count_Type) is
+ SN : Node_Type renames Source.Tree.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.Tree.all, 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;
+
+ Target_Node : Count_Type;
+
+ -- Start of processing for Append_Element
+
+ begin
+ Unconditional_Insert_Avec_Hint
+ (Tree => Target.Tree.all,
+ Hint => 0,
+ Key => SN.Element,
+ Node => Target_Node);
+ end Append_Element;
+ begin
+ Tree_Operations.Clear_Tree (Target.Tree.all);
+ X := Source.First;
+ while X /= Next (Source.Tree.all, Source.Last) loop
+ Append_Element (X);
+ X := Next (Source.Tree.all, X);
+ end loop;
+ end;
+ end if;
+ end Assign;
+
+ -------------
+ -- Ceiling --
+ -------------
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor is
+ begin
+
+ if Container.K = Part then
+ if Container.Length = 0 then
+ return No_Element;
+ end if;
+
+ if Item < Container.Tree.Nodes (Container.First).Element then
+ return (Node => Container.First);
+ end if;
+
+ if Container.Tree.Nodes (Container.Last).Element < Item then
+ return No_Element;
+ end if;
+ end if;
+
+ declare
+ Node : constant Count_Type :=
+ Element_Keys.Ceiling (Container.Tree.all, Item);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end Ceiling;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Tree_Types.Tree_Type) is
+ begin
+ Tree_Operations.Clear_Tree (Container);
+ end Clear;
+
+ procedure Clear (Container : in out Set) is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ Clear (Container.Tree.all);
+ end Clear;
+
+ -----------
+ -- Color --
+ -----------
+
+ function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is
+ begin
+ return Node.Color;
+ end Color;
+
+ --------------
+ -- 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 := 1;
+ N : Count_Type;
+ Cu : Cursor;
+ Target : Set (Count_Type'Max (Source.Capacity, Capacity));
+ begin
+ if Length (Source) > 0 then
+ Target.Tree.Length := Source.Tree.Length;
+ Target.Tree.Root := Source.Tree.Root;
+ Target.Tree.First := Source.Tree.First;
+ Target.Tree.Last := Source.Tree.Last;
+ Target.Tree.Free := Source.Tree.Free;
+
+ while Node <= Source.Capacity loop
+ Target.Tree.Nodes (Node).Element :=
+ Source.Tree.Nodes (Node).Element;
+ Target.Tree.Nodes (Node).Parent :=
+ Source.Tree.Nodes (Node).Parent;
+ Target.Tree.Nodes (Node).Left :=
+ Source.Tree.Nodes (Node).Left;
+ Target.Tree.Nodes (Node).Right :=
+ Source.Tree.Nodes (Node).Right;
+ Target.Tree.Nodes (Node).Color :=
+ Source.Tree.Nodes (Node).Color;
+ Target.Tree.Nodes (Node).Has_Element :=
+ Source.Tree.Nodes (Node).Has_Element;
+ Node := Node + 1;
+ end loop;
+
+ while Node <= Target.Capacity loop
+ N := Node;
+ Formal_Ordered_Sets.Free (Tree => Target.Tree.all, X => N);
+ Node := Node + 1;
+ end loop;
+
+ if Source.K = Part then
+ Node := Target.Tree.First;
+ while Node /= Source.First loop
+ Cu := (Node => Node);
+ Node := Next (Target.Tree.all, Node);
+ Delete (Target, Cu);
+ end loop;
+
+ Node := Next (Target.Tree.all, Source.Last);
+
+ while Node /= 0 loop
+ Cu := (Node => Node);
+ Node := Next (Target.Tree.all, Node);
+ Delete (Target, Cu);
+ end loop;
+ end if;
+ Node := 1;
+
+ end if;
+ return Target;
+ end Copy;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (Container : in out Set; Position : in out Cursor) is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ pragma Assert (Vet (Container.Tree.all, Position.Node),
+ "bad cursor in Delete");
+
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all,
+ Position.Node);
+ Formal_Ordered_Sets.Free (Container.Tree.all, 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.Tree.all, Item);
+
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if X = 0 then
+ raise Constraint_Error with "attempt to delete element not in set";
+ end if;
+
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
+ Formal_Ordered_Sets.Free (Container.Tree.all, X);
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First (Container : in out Set) is
+ Tree : Tree_Types.Tree_Type renames Container.Tree.all;
+ X : constant Count_Type := Tree.First;
+
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Formal_Ordered_Sets.Free (Tree, X);
+ end if;
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last (Container : in out Set) is
+ Tree : Tree_Types.Tree_Type renames Container.Tree.all;
+ X : constant Count_Type := Tree.Last;
+
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Formal_Ordered_Sets.Free (Tree, X);
+ end if;
+ end Delete_Last;
+
+ ----------------
+ -- Difference --
+ ----------------
+
+ procedure Difference (Target : in out Set; Source : Set) is
+ begin
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Source.K = Plain then
+ Set_Ops.Set_Difference (Target.Tree.all, Source.Tree.all);
+ else
+ declare
+ Tgt : Count_Type := Target.Tree.First;
+ Src : Count_Type := Source.First;
+ begin
+ if Target'Address = Source'Address then
+ if Target.Tree.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ Clear (Target.Tree.all);
+ return;
+ end if;
+
+ if Source.Length = 0 then
+ return;
+ end if;
+
+ if Target.Tree.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ loop
+ if Tgt = 0 then
+ return;
+ end if;
+
+ if Src = Next (Source.Tree.all, Source.Last) then
+ return;
+ end if;
+
+ if Target.Tree.Nodes (Tgt).Element <
+ Source.Tree.Nodes (Src).Element then
+ Tgt := Next (Target.Tree.all, Tgt);
+
+ elsif Source.Tree.Nodes (Src).Element <
+ Target.Tree.Nodes (Tgt).Element then
+ Src := Next (Source.Tree.all, Src);
+
+ else
+ declare
+ X : constant Count_Type := Tgt;
+ begin
+ Tgt := Next (Target.Tree.all, Tgt);
+ Delete_Node_Sans_Free (Target.Tree.all, X);
+ Formal_Ordered_Sets.Free (Target.Tree.all, X);
+ end;
+
+ Src := Next (Source.Tree.all, Src);
+ end if;
+ end loop;
+ end;
+ end if;
+ 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 Left.Copy;
+ end if;
+
+ return S : Set (Length (Left)) do
+ if Left.K = Plain and Right.K = Plain then
+ Assign (S.Tree.all,
+ Set_Ops.Set_Difference (Left.Tree.all, Right.Tree.all));
+ else
+ declare
+ Tree : Tree_Types.Tree_Type renames S.Tree.all;
+
+ L_Node : Count_Type := First (Left).Node;
+ R_Node : Count_Type := First (Right).Node;
+
+ L_Last : constant Count_Type := Next (Left.Tree.all,
+ Last (Left).Node);
+ R_Last : constant Count_Type := Next (Right.Tree.all,
+ Last (Right).Node);
+
+ Dst_Node : Count_Type;
+
+ begin
+ loop
+ if L_Node = L_Last then
+ return;
+ end if;
+
+ if R_Node = R_Last then
+ while L_Node /= L_Last loop
+ Insert_With_Hint
+ (Dst_Set => Tree,
+ Dst_Hint => 0,
+ Src_Node => Left.Tree.Nodes (L_Node),
+ Dst_Node => Dst_Node);
+
+ L_Node := Next (Left.Tree.all, L_Node);
+
+ end loop;
+
+ return;
+ end if;
+
+ if Left.Tree.Nodes (L_Node).Element <
+ Right.Tree.Nodes (R_Node).Element then
+ Insert_With_Hint
+ (Dst_Set => Tree,
+ Dst_Hint => 0,
+ Src_Node => Left.Tree.Nodes (L_Node),
+ Dst_Node => Dst_Node);
+
+ L_Node := Next (Left.Tree.all, L_Node);
+
+ elsif Right.Tree.Nodes (R_Node).Element <
+ Left.Tree.Nodes (L_Node).Element then
+ R_Node := Next (Right.Tree.all, R_Node);
+
+ else
+ L_Node := Next (Left.Tree.all, L_Node);
+ R_Node := Next (Right.Tree.all, R_Node);
+ end if;
+ end loop;
+ end;
+ end if;
+ 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.Tree.all, Position.Node),
+ "bad cursor in Element");
+
+ declare
+ N : Tree_Types.Nodes_Type renames Container.Tree.Nodes;
+ begin
+ return N (Position.Node).Element;
+ end;
+ 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
+ if Left.K = Plain and Right.K = Plain then
+ return Is_Equivalent (Left.Tree.all, Right.Tree.all);
+ end if;
+
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ if Length (Left) /= Length (Right) then
+ return False;
+ end if;
+
+ if Length (Left) = 0 then
+ return True;
+ end if;
+
+ declare
+ L_Node : Count_Type;
+ R_Node : Count_Type;
+
+ L_Last : constant Count_Type := Next (Left.Tree.all,
+ Last (Left).Node);
+ begin
+
+ L_Node := First (Left).Node;
+ R_Node := First (Right).Node;
+ while L_Node /= L_Last loop
+ if not Is_Equivalent_Node_Node (Left.Tree.Nodes (L_Node),
+ Right.Tree.Nodes (R_Node)) then
+ return False;
+ end if;
+
+ L_Node := Next (Left.Tree.all, L_Node);
+ R_Node := Next (Right.Tree.all, R_Node);
+ end loop;
+
+ return True;
+ end;
+ end Equivalent_Sets;
+
+ -------------
+ -- Exclude --
+ -------------
+
+ procedure Exclude (Container : in out Set; Item : Element_Type) is
+ X : constant Count_Type := Element_Keys.Find (Container.Tree.all, Item);
+
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if X /= 0 then
+ Tree_Operations.Delete_Node_Sans_Free (Container.Tree.all, X);
+ Formal_Ordered_Sets.Free (Container.Tree.all, X);
+ end if;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Item : Element_Type) return Cursor is
+ begin
+
+ if Container.K = Part then
+ if Container.Length = 0 then
+ return No_Element;
+ end if;
+
+ if Item < Container.Tree.Nodes (Container.First).Element or
+ Container.Tree.Nodes (Container.Last).Element < Item then
+ return No_Element;
+ end if;
+ end if;
+
+ declare
+ Node : constant Count_Type :=
+ Element_Keys.Find (Container.Tree.all, Item);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end Find;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Set) return Cursor is
+ begin
+ if Length (Container) = 0 then
+ return No_Element;
+ end if;
+
+ if Container.K = Plain then
+ return (Node => Container.Tree.First);
+ else
+ return (Node => Container.First);
+ end if;
+
+ 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.Tree.Nodes;
+ begin
+ return N (Fst).Element;
+ end;
+ end First_Element;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor is
+ begin
+
+ if Container.K = Part then
+ if Container.Length = 0 then
+ return No_Element;
+ end if;
+
+ if Item < Container.Tree.Nodes (Container.First).Element then
+ return No_Element;
+ end if;
+
+ if Container.Tree.Nodes (Container.Last).Element < Item then
+ return (Node => Container.Last);
+ end if;
+ end if;
+
+ declare
+ Node : constant Count_Type :=
+ Element_Keys.Floor (Container.Tree.all, Item);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end Floor;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free
+ (Tree : in out Tree_Types.Tree_Type;
+ X : Count_Type)
+ is
+ begin
+ Tree.Nodes (X).Has_Element := False;
+ Tree_Operations.Free (Tree, 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 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
+ begin
+
+ if Container.K = Part then
+ if Container.Length = 0 then
+ return No_Element;
+ end if;
+
+ if Key < Generic_Keys.Key
+ (Container.Tree.Nodes (Container.First).Element) then
+ return (Node => Container.First);
+ end if;
+
+ if Generic_Keys.Key
+ (Container.Tree.Nodes (Container.Last).Element) < Key then
+ return No_Element;
+ end if;
+ end if;
+
+ declare
+ Node : constant Count_Type :=
+ Key_Keys.Ceiling (Container.Tree.all, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ 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
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ declare
+ X : constant Count_Type := Key_Keys.Find (Container.Tree.all, Key);
+
+ begin
+ if X = 0 then
+ raise Constraint_Error with "attempt to delete key not in set";
+ end if;
+
+ Delete_Node_Sans_Free (Container.Tree.all, X);
+ Formal_Ordered_Sets.Free (Container.Tree.all, X);
+ end;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type is
+ begin
+
+ if Container.K = Part then
+ if Container.Length = 0 or else
+ (Key < Generic_Keys.Key
+ (Container.Tree.Nodes (Container.First).Element) or
+ Generic_Keys.Key
+ (Container.Tree.Nodes (Container.Last).Element) < Key) then
+ raise Constraint_Error with "key not in set";
+ end if;
+ end if;
+
+ declare
+ Node : constant Count_Type :=
+ Key_Keys.Find (Container.Tree.all, Key);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with "key not in set";
+ end if;
+
+ declare
+ N : Tree_Types.Nodes_Type renames Container.Tree.Nodes;
+ begin
+ return N (Node).Element;
+ end;
+ 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
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ declare
+
+ X : constant Count_Type := Key_Keys.Find (Container.Tree.all, Key);
+
+ begin
+ if X /= 0 then
+ Delete_Node_Sans_Free (Container.Tree.all, X);
+ Formal_Ordered_Sets.Free (Container.Tree.all, X);
+ end if;
+ end;
+ end Exclude;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find (Container : Set; Key : Key_Type) return Cursor is
+ begin
+
+ if Container.K = Part then
+ if Container.Length = 0 or else
+ (Key < Generic_Keys.Key
+ (Container.Tree.Nodes (Container.First).Element) or
+ Generic_Keys.Key
+ (Container.Tree.Nodes (Container.Last).Element) < Key) then
+ return No_Element;
+ end if;
+ end if;
+
+ declare
+
+ Node : constant Count_Type := Key_Keys.Find (Container.Tree.all,
+ Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end Find;
+
+ -----------
+ -- Floor --
+ -----------
+
+ function Floor (Container : Set; Key : Key_Type) return Cursor is
+ begin
+ if Container.K = Part then
+ if Container.Length = 0 or else
+ Key < Generic_Keys.Key
+ (Container.Tree.Nodes (Container.First).Element) then
+ return No_Element;
+ end if;
+
+ if Generic_Keys.Key
+ (Container.Tree.Nodes (Container.Last).Element) < Key then
+ return (Node => Container.Last);
+ end if;
+ end if;
+
+ declare
+ Node : constant Count_Type :=
+ Key_Keys.Floor (Container.Tree.all, Key);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end Floor;
+
+ -------------------------
+ -- 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.Tree.all, Position.Node),
+ "bad cursor in Key");
+
+ declare
+ N : Tree_Types.Nodes_Type renames Container.Tree.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.Tree.all, Key);
+
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, (Node => Node)) then
+ raise Constraint_Error with
+ "attempt to replace key not in set";
+ end if;
+
+ Replace_Element (Container.Tree.all, Node, New_Item);
+ end Replace;
+
+ -----------------------------------
+ -- Update_Element_Preserving_Key --
+ -----------------------------------
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ Tree : Tree_Types.Tree_Type renames Container.Tree.all;
+
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+
+ pragma Assert (Vet (Container.Tree.all, Position.Node),
+ "bad cursor in Update_Element_Preserving_Key");
+
+ declare
+ N : Tree_Types.Nodes_Type renames Container.Tree.Nodes;
+
+ E : Element_Type renames N (Position.Node).Element;
+ K : constant Key_Type := Key (E);
+
+ B : Natural renames Tree.Busy;
+ L : Natural renames Tree.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (E);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+
+ if Equivalent_Keys (K, Key (E)) then
+ return;
+ end if;
+ end;
+
+ declare
+ X : constant Count_Type := Position.Node;
+ begin
+ Tree_Operations.Delete_Node_Sans_Free (Tree, X);
+ Formal_Ordered_Sets.Free (Tree, X);
+ end;
+
+ raise Program_Error with "key was modified";
+ end Update_Element_Preserving_Key;
+
+ end Generic_Keys;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element (Container : Set; Position : Cursor) return Boolean is
+ begin
+ if Position.Node = 0 then
+ return False;
+ end if;
+
+ if not Container.Tree.Nodes (Position.Node).Has_Element then
+ return False;
+ end if;
+
+ if Container.K = Plain then
+ return True;
+ end if;
+
+ declare
+ Elt : constant Element_Type :=
+ Container.Tree.Nodes (Position.Node).Element;
+ begin
+
+ if Elt < Container.Tree.Nodes (Container.First).Element or
+ Container.Tree.Nodes (Container.Last).Element < Elt then
+ return False;
+ end if;
+
+ return True;
+ end;
+ 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
+ if Container.Tree.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
+ end if;
+
+ declare
+ N : Tree_Types.Nodes_Type renames Container.Tree.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
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ Insert_Sans_Hint
+ (Container.Tree.all,
+ 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;
+ pragma Unreferenced (Success);
+
+ 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
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Source.K = Plain then
+ Set_Ops.Set_Intersection (Target.Tree.all, Source.Tree.all);
+ else
+ declare
+ Tgt : Count_Type := Target.First;
+ Src : Count_Type := Source.First;
+
+ S_Last : constant Count_Type :=
+ Next (Source.Tree.all, Source.Last);
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Tree.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ if Source.Length = 0 then
+ Clear (Target);
+ return;
+ end if;
+
+ while Tgt /= 0
+ and then Src /= S_Last
+ loop
+ if Target.Tree.Nodes (Tgt).Element <
+ Source.Tree.Nodes (Src).Element then
+ declare
+ X : constant Count_Type := Tgt;
+ begin
+ Tgt := Next (Target.Tree.all, Tgt);
+ Delete_Node_Sans_Free (Target.Tree.all, X);
+ Formal_Ordered_Sets.Free (Target.Tree.all, X);
+ end;
+
+ elsif Source.Tree.Nodes (Src).Element <
+ Target.Tree.Nodes (Tgt).Element then
+ Src := Next (Source.Tree.all, Src);
+
+ else
+ Tgt := Next (Target.Tree.all, Tgt);
+ Src := Next (Source.Tree.all, Src);
+ end if;
+ end loop;
+
+ while Tgt /= 0 loop
+ declare
+ X : constant Count_Type := Tgt;
+ begin
+ Tgt := Next (Target.Tree.all, Tgt);
+ Delete_Node_Sans_Free (Target.Tree.all, X);
+ Formal_Ordered_Sets.Free (Target.Tree.all, X);
+ end;
+ end loop;
+ end;
+ end if;
+ end Intersection;
+
+ function Intersection (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Left.Copy;
+ end if;
+
+ return S : Set (Count_Type'Min (Length (Left), Length (Right))) do
+ if Left.K = Plain and Right.K = Plain then
+ Assign (S.Tree.all, Set_Ops.Set_Intersection
+ (Left.Tree.all, Right.Tree.all));
+ return;
+ end if;
+
+ if Length (Left) = 0 or Length (Right) = 0 then
+ return;
+ end if;
+
+ declare
+
+ L_Node : Count_Type := First (Left).Node;
+ R_Node : Count_Type := First (Right).Node;
+
+ L_Last : constant Count_Type :=
+ Next (Left.Tree.all, Last (Left).Node);
+ R_Last : constant Count_Type :=
+ Next (Right.Tree.all, Last (Right).Node);
+
+ Dst_Node : Count_Type;
+
+ begin
+ loop
+
+ if L_Node = L_Last or R_Node = R_Last then
+ return;
+ end if;
+
+ if Left.Tree.Nodes (L_Node).Element <
+ Right.Tree.Nodes (R_Node).Element then
+ L_Node := Next (Left.Tree.all, L_Node);
+
+ elsif Right.Tree.Nodes (R_Node).Element <
+ Left.Tree.Nodes (L_Node).Element then
+ R_Node := Next (Right.Tree.all, R_Node);
+
+ else
+ Insert_With_Hint
+ (Dst_Set => S.Tree.all,
+ Dst_Hint => 0,
+ Src_Node => Left.Tree.Nodes (L_Node),
+ Dst_Node => Dst_Node);
+
+ L_Node := Next (Left.Tree.all, L_Node);
+ R_Node := Next (Right.Tree.all, R_Node);
+ end if;
+ end loop;
+ end;
+ 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
+ if Subset.K = Plain and Of_Set.K = Plain then
+ return Set_Ops.Set_Subset (Subset.Tree.all,
+ Of_Set => Of_Set.Tree.all);
+ end if;
+
+ if Subset'Address = Of_Set'Address then
+ return True;
+ end if;
+
+ if Length (Subset) > Length (Of_Set) then
+ return False;
+ end if;
+
+ declare
+ Subset_Node : Count_Type := First (Subset).Node;
+ Set_Node : Count_Type := First (Of_Set).Node;
+
+ Subset_Last : constant Count_Type :=
+ Next (Subset.Tree.all, Last (Subset).Node);
+ Set_Last : constant Count_Type :=
+ Next (Of_Set.Tree.all, Last (Of_Set).Node);
+
+ begin
+ loop
+ if Set_Node = Set_Last then
+ return Subset_Node = 0;
+ end if;
+
+ if Subset_Node = Subset_Last then
+ return True;
+ end if;
+
+ if Subset.Tree.Nodes (Subset_Node).Element <
+ Of_Set.Tree.Nodes (Set_Node).Element then
+ return False;
+ end if;
+
+ if Of_Set.Tree.Nodes (Set_Node).Element <
+ Subset.Tree.Nodes (Subset_Node).Element then
+ Set_Node := Next (Of_Set.Tree.all, Set_Node);
+ else
+ Set_Node := Next (Of_Set.Tree.all, Set_Node);
+ Subset_Node := Next (Subset.Tree.all, Subset_Node);
+ end if;
+ end loop;
+ end;
+ end Is_Subset;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Set;
+ Process :
+ not null access procedure (Container : Set; Position : Cursor))
+ is
+ procedure Process_Node (Node : Count_Type);
+ pragma Inline (Process_Node);
+
+ procedure Local_Iterate is
+ new Tree_Operations.Generic_Iteration (Process_Node);
+
+ procedure Local_Iterate_Between is
+ new Iterate_Between (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Count_Type) is
+ begin
+ Process (Container, (Node => Node));
+ end Process_Node;
+
+ T : Tree_Types.Tree_Type renames Container.Tree.all;
+ B : Natural renames T.Busy;
+
+ -- Start of prccessing for Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+ if Container.K = Plain then
+ Local_Iterate (T);
+ return;
+ end if;
+
+ if Container.Length = 0 then
+ return;
+ end if;
+
+ Local_Iterate_Between (T, Container.First, Container.Last);
+
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Iterate;
+
+ ---------------------
+ -- Iterate_Between --
+ ---------------------
+
+ procedure Iterate_Between (Tree : Tree_Types.Tree_Type;
+ From : Count_Type;
+ To : Count_Type) is
+
+ FElt : constant Element_Type := Tree.Nodes (From).Element;
+ TElt : constant Element_Type := Tree.Nodes (To).Element;
+ procedure Iterate (P : Count_Type);
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate (P : Count_Type) is
+ X : Count_Type := P;
+ begin
+ while X /= 0 loop
+ if Tree.Nodes (X).Element < FElt then
+ X := Tree.Nodes (X).Right;
+ elsif TElt < Tree.Nodes (X).Element then
+ X := Tree.Nodes (X).Left;
+ else
+ Iterate (Tree.Nodes (X).Left);
+ Process (X);
+ X := Tree.Nodes (X).Right;
+ end if;
+ end loop;
+ end Iterate;
+
+ begin
+ Iterate (Tree.Root);
+ end Iterate_Between;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : Set) return Cursor is
+ begin
+ if Length (Container) = 0 then
+ return No_Element;
+ end if;
+
+ if Container.K = Plain then
+ return (Node => Container.Tree.Last);
+ end if;
+
+ return (Node => Container.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.Tree.Nodes;
+ begin
+ return N (Last (Container).Node).Element;
+ end;
+ end Last_Element;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Container : Set; Position : Cursor) return Set is
+ Lst : Count_Type;
+ Fst : constant Count_Type := First (Container).Node;
+ L : Count_Type := 0;
+ C : Count_Type := Fst;
+ begin
+ while C /= Position.Node loop
+ if C = Last (Container).Node or C = 0 then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ Lst := C;
+ C := Next (Container.Tree.all, C);
+ L := L + 1;
+ end loop;
+ if L = 0 then
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Tree => Container.Tree,
+ Length => 0,
+ First => 0,
+ Last => 0);
+ else
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Tree => Container.Tree,
+ Length => L,
+ First => Fst,
+ Last => Lst);
+ end if;
+ end Left;
+
+ --------------
+ -- 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
+ if Container.K = Plain then
+ return Container.Tree.Length;
+ else
+ return Container.Length;
+ end if;
+ end Length;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Set; Source : in out Set) is
+ S : Tree_Types.Tree_Type renames Source.Tree.all;
+ N : Tree_Types.Nodes_Type renames S.Nodes;
+ X : Count_Type;
+
+ begin
+ if Target.K /= Plain or Source.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ 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;
+
+ if S.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors of Source (list is busy)";
+ end if;
+
+ Clear (Target);
+
+ loop
+ X := S.First;
+ exit when X = 0;
+
+ Insert (Target, N (X).Element); -- optimize???
+
+ Tree_Operations.Delete_Node_Sans_Free (S, X);
+ Formal_Ordered_Sets.Free (S, X);
+ end loop;
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next_Unchecked
+ (Container : Set;
+ Position : Count_Type) return Count_Type is
+ begin
+
+ if Container.K = Part and then
+ (Container.Length = 0 or Position = Container.Last) then
+ return 0;
+ end if;
+
+ return Tree_Operations.Next (Container.Tree.all, Position);
+ end Next_Unchecked;
+
+ 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.Tree.all, Position.Node),
+ "bad cursor in Next");
+ return (Node => Next_Unchecked (Container, 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
+ if Left.K = Plain and Right.K = Plain then
+ return Set_Ops.Set_Overlap (Left.Tree.all, Right.Tree.all);
+ end if;
+
+ if Length (Left) = 0 or Length (Right) = 0 then
+ return False;
+ end if;
+
+ declare
+
+ L_Node : Count_Type := First (Left).Node;
+ R_Node : Count_Type := First (Right).Node;
+
+ L_Last : constant Count_Type :=
+ Next (Left.Tree.all, Last (Left).Node);
+ R_Last : constant Count_Type :=
+ Next (Right.Tree.all, Last (Right).Node);
+
+ begin
+ if Left'Address = Right'Address then
+ return True;
+ end if;
+
+ loop
+ if L_Node = L_Last
+ or else R_Node = R_Last
+ then
+ return False;
+ end if;
+
+ if Left.Tree.Nodes (L_Node).Element <
+ Right.Tree.Nodes (R_Node).Element then
+ L_Node := Next (Left.Tree.all, L_Node);
+
+ elsif Right.Tree.Nodes (R_Node).Element <
+ Left.Tree.Nodes (L_Node).Element then
+ R_Node := Next (Right.Tree.all, R_Node);
+
+ else
+ return True;
+ end if;
+ end loop;
+ end;
+ 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.Tree.all, Position.Node),
+ "bad cursor in Previous");
+
+ if Container.K = Part and then
+ (Container.Length = 0 or Position.Node = Container.First) then
+ return No_Element;
+ end if;
+
+ declare
+ Tree : Tree_Types.Tree_Type renames Container.Tree.all;
+ Node : constant Count_Type :=
+ Tree_Operations.Previous (Tree, Position.Node);
+
+ begin
+ if Node = 0 then
+ return No_Element;
+ end if;
+
+ return (Node => Node);
+ end;
+ end Previous;
+
+ procedure Previous (Container : Set; Position : in out Cursor) is
+ begin
+ Position := Previous (Container, Position);
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ pragma Assert (Vet (Container.Tree.all, Position.Node),
+ "bad cursor in Query_Element");
+
+ declare
+ T : Tree_Types.Tree_Type renames Container.Tree.all;
+
+ B : Natural renames T.Busy;
+ L : Natural renames T.Lock;
+
+ begin
+ B := B + 1;
+ L := L + 1;
+
+ begin
+ Process (T.Nodes (Position.Node).Element);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Set)
+ is
+ procedure Read_Element (Node : in out Node_Type);
+ pragma Inline (Read_Element);
+
+ procedure Allocate is
+ new Generic_Allocate (Read_Element);
+
+ procedure Read_Elements is
+ new Tree_Operations.Generic_Read (Allocate);
+
+ ------------------
+ -- Read_Element --
+ ------------------
+
+ procedure Read_Element (Node : in out Node_Type) is
+ begin
+ Element_Type'Read (Stream, Node.Element);
+ end Read_Element;
+
+ -- Start of processing for Read
+ Result : Tree_Type_Access;
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error;
+ end if;
+
+ if Container.Tree = null then
+ Result := new Tree_Types.Tree_Type (Container.Capacity);
+ else
+ Result := Container.Tree;
+ end if;
+
+ Read_Elements (Stream, Result.all);
+ Container.Tree := Result;
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream set cursor";
+ end Read;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace (Container : in out Set; New_Item : Element_Type) is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ declare
+ Node : constant Count_Type :=
+ Element_Keys.Find (Container.Tree.all, New_Item);
+
+ begin
+ if Node = 0 then
+ raise Constraint_Error with
+ "attempt to replace element not in set";
+ end if;
+
+ if Container.Tree.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
+ end if;
+
+ Container.Tree.Nodes (Node).Element := New_Item;
+ end;
+ end Replace;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Tree : in out Tree_Types.Tree_Type;
+ 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.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
+ if Tree.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
+ end if;
+
+ NN (Node).Element := Item;
+ return;
+ end if;
+
+ Hint := Element_Keys.Ceiling (Tree, Item);
+
+ if Hint = 0 then
+ null;
+
+ elsif Item < NN (Hint).Element then
+ if Hint = Node then
+ if Tree.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
+ end if;
+
+ 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, Node); -- Checks busy-bit
+
+ Local_Insert_With_Hint
+ (Tree => Tree,
+ 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 Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Has_Element (Container, Position) then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+
+ pragma Assert (Vet (Container.Tree.all, Position.Node),
+ "bad cursor in Replace_Element");
+
+ Replace_Element (Container.Tree.all, Position.Node, New_Item);
+ end Replace_Element;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process :
+ not null access procedure (Container : Set; Position : Cursor))
+ is
+ procedure Process_Node (Node : Count_Type);
+ pragma Inline (Process_Node);
+
+ procedure Local_Reverse_Iterate is
+ new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
+
+ ------------------
+ -- Process_Node --
+ ------------------
+
+ procedure Process_Node (Node : Count_Type) is
+ begin
+ Process (Container, (Node => Node));
+ end Process_Node;
+
+ T : Tree_Types.Tree_Type renames Container.Tree.all;
+ B : Natural renames T.Busy;
+
+ -- Start of processing for Reverse_Iterate
+
+ begin
+ B := B + 1;
+
+ begin
+ if Container.K = Plain then
+ Local_Reverse_Iterate (T);
+ return;
+ end if;
+
+ if Container.Length = 0 then
+ return;
+ end if;
+
+ declare
+ Node : Count_Type := Container.Last;
+ First : constant Count_Type :=
+ Previous (Container.Tree.all, Container.First);
+
+ begin
+
+ while Node /= First loop
+ Process_Node (Node);
+ Node := Previous (Container.Tree.all, Node);
+ end loop;
+
+ end;
+
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Container : Set; Position : Cursor) return Set is
+ Lst : Count_Type;
+ L : Count_Type := 0;
+ C : Count_Type := Position.Node;
+ begin
+
+ if C = 0 then
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Tree => Container.Tree,
+ Length => 0,
+ First => 0,
+ Last => 0);
+ end if;
+
+ if Container.K = Plain then
+ Lst := 0;
+ else
+ Lst := Next (Container.Tree.all, Container.Last);
+ end if;
+
+ if C = Lst then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+
+ while C /= Lst loop
+ if C = 0 then
+ raise Constraint_Error with
+ "Position cursor has no element";
+ end if;
+ C := Next (Container.Tree.all, C);
+ L := L + 1;
+ end loop;
+
+ return (Capacity => Container.Capacity,
+ K => Part,
+ Tree => Container.Tree,
+ Length => L,
+ First => Position.Node,
+ Last => Last (Container).Node);
+ end Right;
+
+ ---------------
+ -- 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;
+
+ ------------------
+ -- Strict_Equal --
+ ------------------
+
+ function Strict_Equal (Left, Right : Set) return Boolean is
+ LNode : Count_Type := First (Left).Node;
+ RNode : Count_Type := First (Right).Node;
+ begin
+ if Length (Left) /= Length (Right) then
+ return False;
+ end if;
+
+ while LNode = RNode loop
+ if LNode = 0 then
+ return True;
+ end if;
+
+ if Left.Tree.Nodes (LNode).Element /=
+ Right.Tree.Nodes (RNode).Element then
+ exit;
+ end if;
+
+ LNode := Next_Unchecked (Left, LNode);
+ RNode := Next_Unchecked (Right, RNode);
+ end loop;
+ return False;
+
+ end Strict_Equal;
+
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set) is
+ begin
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Source.K = Plain then
+ Set_Ops.Set_Symmetric_Difference (Target.Tree.all, Source.Tree.all);
+ return;
+ end if;
+
+ if Source.Length = 0 then
+ return;
+ end if;
+
+ declare
+
+ Tgt : Count_Type := Target.First;
+ Src : Count_Type := Source.First;
+
+ SLast : constant Count_Type := Next (Source.Tree.all, Source.Last);
+
+ New_Tgt_Node : Count_Type;
+
+ begin
+ if Target.Tree.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
+
+ loop
+ if Tgt = 0 then
+ while Src /= SLast loop
+ Insert_With_Hint
+ (Dst_Set => Target.Tree.all,
+ Dst_Hint => 0,
+ Src_Node => Source.Tree.Nodes (Src),
+ Dst_Node => New_Tgt_Node);
+
+ Src := Next (Source.Tree.all, Src);
+ end loop;
+
+ return;
+ end if;
+
+ if Src = SLast then
+ return;
+ end if;
+
+ if Target.Tree.Nodes (Tgt).Element <
+ Source.Tree.Nodes (Src).Element then
+ Tgt := Next (Target.Tree.all, Tgt);
+
+ elsif Source.Tree.Nodes (Src).Element <
+ Target.Tree.Nodes (Tgt).Element then
+ Insert_With_Hint
+ (Dst_Set => Target.Tree.all,
+ Dst_Hint => Tgt,
+ Src_Node => Source.Tree.Nodes (Src),
+ Dst_Node => New_Tgt_Node);
+
+ Src := Next (Source.Tree.all, Src);
+
+ else
+ declare
+ X : constant Count_Type := Tgt;
+ begin
+ Tgt := Next (Target.Tree.all, Tgt);
+ Delete_Node_Sans_Free (Target.Tree.all, X);
+ Formal_Ordered_Sets.Free (Target.Tree.all, X);
+ end;
+
+ Src := Next (Source.Tree.all, Src);
+ end if;
+ end loop;
+ end;
+ 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 Left.Copy;
+ end if;
+
+ if Length (Left) = 0 then
+ return Right.Copy;
+ end if;
+
+ return S : Set (Length (Left) + Length (Right)) do
+ if Left.K = Plain and Right.K = Plain then
+ Assign (S.Tree.all,
+ Set_Ops.Set_Symmetric_Difference (Left.Tree.all,
+ Right.Tree.all));
+ return;
+ end if;
+
+ declare
+
+ Tree : Tree_Types.Tree_Type renames S.Tree.all;
+
+ L_Node : Count_Type := First (Left).Node;
+ R_Node : Count_Type := First (Right).Node;
+
+ L_Last : constant Count_Type :=
+ Next (Left.Tree.all, Last (Left).Node);
+ R_Last : constant Count_Type :=
+ Next (Right.Tree.all, Last (Right).Node);
+
+ Dst_Node : Count_Type;
+
+ begin
+ loop
+ if L_Node = L_Last then
+ while R_Node /= R_Last loop
+ Insert_With_Hint
+ (Dst_Set => Tree,
+ Dst_Hint => 0,
+ Src_Node => Right.Tree.Nodes (R_Node),
+ Dst_Node => Dst_Node);
+
+ R_Node := Next (Right.Tree.all, R_Node);
+ end loop;
+
+ return;
+ end if;
+
+ if R_Node = R_Last then
+ while L_Node /= L_Last loop
+ Insert_With_Hint
+ (Dst_Set => Tree,
+ Dst_Hint => 0,
+ Src_Node => Left.Tree.Nodes (L_Node),
+ Dst_Node => Dst_Node);
+
+ L_Node := Next (Left.Tree.all, L_Node);
+ end loop;
+
+ return;
+ end if;
+
+ if Left.Tree.Nodes (L_Node).Element <
+ Right.Tree.Nodes (R_Node).Element then
+ Insert_With_Hint
+ (Dst_Set => Tree,
+ Dst_Hint => 0,
+ Src_Node => Left.Tree.Nodes (L_Node),
+ Dst_Node => Dst_Node);
+
+ L_Node := Next (Left.Tree.all, L_Node);
+
+ elsif Right.Tree.Nodes (R_Node).Element <
+ Left.Tree.Nodes (L_Node).Element then
+ Insert_With_Hint
+ (Dst_Set => Tree,
+ Dst_Hint => 0,
+ Src_Node => Right.Tree.Nodes (R_Node),
+ Dst_Node => Dst_Node);
+
+ R_Node := Next (Right.Tree.all, R_Node);
+
+ else
+ L_Node := Next (Left.Tree.all, L_Node);
+ R_Node := Next (Right.Tree.all, R_Node);
+ end if;
+ end loop;
+ end;
+
+ 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.Tree.all, New_Item, Node, Inserted);
+ pragma Assert (Inserted);
+ end return;
+ end To_Set;
+
+ -----------
+ -- Union --
+ -----------
+
+ procedure Union (Target : in out Set; Source : Set) is
+ begin
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Source.K = Plain then
+ Set_Ops.Set_Union (Target.Tree.all, Source.Tree.all);
+ return;
+ end if;
+
+ if Source.Length = 0 then
+ return;
+ end if;
+
+ declare
+ Hint : Count_Type := 0;
+
+ procedure Process (Node : Count_Type);
+ pragma Inline (Process);
+
+ procedure Iterate is new Iterate_Between (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Node : Count_Type) is
+ begin
+ Insert_With_Hint
+ (Dst_Set => Target.Tree.all,
+ Dst_Hint => Hint,
+ Src_Node => Source.Tree.Nodes (Node),
+ Dst_Node => Hint);
+ end Process;
+
+ -- Start of processing for Union
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Tree.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (container is busy)";
+ end if;
+
+ Iterate (Source.Tree.all, Source.First, Source.Last);
+ end;
+ end Union;
+
+ function Union (Left, Right : Set) return Set is
+ begin
+ if Left'Address = Right'Address then
+ return Left.Copy;
+ end if;
+
+ if Length (Left) = 0 then
+ return Right.Copy;
+ end if;
+
+ if Length (Right) = 0 then
+ return Left.Copy;
+ end if;
+
+ return S : Set (Length (Left) + Length (Right)) do
+ S.Assign (Source => Left);
+ S.Union (Right);
+ end return;
+ end Union;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Set)
+ is
+ procedure Write_Element
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type);
+ pragma Inline (Write_Element);
+
+ procedure Write_Elements is
+ new Tree_Operations.Generic_Write (Write_Element);
+
+ -------------------
+ -- Write_Element --
+ -------------------
+
+ procedure Write_Element
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Type)
+ is
+ begin
+ Element_Type'Write (Stream, Node.Element);
+ end Write_Element;
+
+ -- Start of processing for Write
+
+ begin
+ Write_Elements (Stream, Container.Tree.all);
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream set cursor";
+ end Write;
+
+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 _ O R D E R E D _ S E T S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2010, 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/>. --
+------------------------------------------------------------------------------
+
+private with Ada.Containers.Red_Black_Trees;
+private with Ada.Streams;
+
+with Ada.Containers;
+use Ada.Containers;
+
+generic
+ type Element_Type is private;
+
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Formal_Ordered_Sets is
+ pragma Pure;
+
+ function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
+
+ type Set (Capacity : Count_Type) is tagged private;
+ -- pragma Preelaborable_Initialization (Set);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_Set : constant Set;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Set) return Boolean;
+
+ function Equivalent_Sets (Left, Right : Set) return Boolean;
+
+ function To_Set (New_Item : Element_Type) return Set;
+
+ function Length (Container : Set) return Count_Type;
+
+ function Is_Empty (Container : Set) return Boolean;
+
+ procedure Clear (Container : in out Set);
+
+ procedure Assign (Target : in out Set; Source : Set);
+
+ function Copy (Source : Set; Capacity : Count_Type := 0) return Set;
+
+ function Element (Container : Set; Position : Cursor) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Set;
+ Position : Cursor;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Move (Target : in out Set; Source : in out Set);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean);
+
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Include
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Replace
+ (Container : in out Set;
+ New_Item : Element_Type);
+
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Set;
+ Item : Element_Type);
+
+ procedure Delete
+ (Container : in out Set;
+ Position : in out Cursor);
+
+ procedure Delete_First (Container : in out Set);
+
+ procedure Delete_Last (Container : in out Set);
+
+ procedure Union (Target : in out Set; Source : Set);
+
+ function Union (Left, Right : Set) return Set;
+
+ function "or" (Left, Right : Set) return Set renames Union;
+
+ procedure Intersection (Target : in out Set; Source : Set);
+
+ function Intersection (Left, Right : Set) return Set;
+
+ function "and" (Left, Right : Set) return Set renames Intersection;
+
+ procedure Difference (Target : in out Set; Source : Set);
+
+ function Difference (Left, Right : Set) return Set;
+
+ function "-" (Left, Right : Set) return Set renames Difference;
+
+ procedure Symmetric_Difference (Target : in out Set; Source : Set);
+
+ function Symmetric_Difference (Left, Right : Set) return Set;
+
+ function "xor" (Left, Right : Set) return Set renames Symmetric_Difference;
+
+ function Overlap (Left, Right : Set) return Boolean;
+
+ function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
+
+ function First (Container : Set) return Cursor;
+
+ function First_Element (Container : Set) return Element_Type;
+
+ function Last (Container : Set) return Cursor;
+
+ function Last_Element (Container : Set) return Element_Type;
+
+ function Next (Container : Set; Position : Cursor) return Cursor;
+
+ procedure Next (Container : Set; Position : in out Cursor);
+
+ function Previous (Container : Set; Position : Cursor) return Cursor;
+
+ procedure Previous (Container : Set; Position : in out Cursor);
+
+ function Find (Container : Set; Item : Element_Type) return Cursor;
+
+ function Floor (Container : Set; Item : Element_Type) return Cursor;
+
+ function Ceiling (Container : Set; Item : Element_Type) return Cursor;
+
+ function Contains (Container : Set; Item : Element_Type) return Boolean;
+
+ function Has_Element (Container : Set; Position : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Set;
+ Process :
+ not null access procedure (Container : Set; Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Set;
+ Process :
+ not null access procedure (Container : Set; Position : Cursor));
+
+ 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 is
+
+ function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
+
+ function Key (Container : Set; Position : Cursor) return Key_Type;
+
+ function Element (Container : Set; Key : Key_Type) return Element_Type;
+
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type);
+
+ procedure Exclude (Container : in out Set; Key : Key_Type);
+
+ procedure Delete (Container : in out Set; Key : Key_Type);
+
+ function Find (Container : Set; Key : Key_Type) return Cursor;
+
+ function Floor (Container : Set; Key : Key_Type) return Cursor;
+
+ function Ceiling (Container : Set; Key : Key_Type) return Cursor;
+
+ function Contains (Container : Set; Key : Key_Type) return Boolean;
+
+ procedure Update_Element_Preserving_Key
+ (Container : in out Set;
+ Position : Cursor;
+ Process : not null access
+ procedure (Element : in out Element_Type));
+
+ end Generic_Keys;
+
+ function Strict_Equal (Left, Right : Set) return Boolean;
+
+ function Left (Container : Set; Position : Cursor) return Set;
+
+ function Right (Container : Set; Position : Cursor) return Set;
+
+private
+
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
+ type Node_Type is record
+ Has_Element : Boolean := False;
+ Parent : Count_Type;
+ Left : Count_Type;
+ Right : Count_Type;
+ Color : Red_Black_Trees.Color_Type;
+ Element : Element_Type;
+ end record;
+
+ type Kind is (Plain, Part);
+
+ package Tree_Types is
+ new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
+
+ type Tree_Type_Access is access all Tree_Types.Tree_Type;
+
+ type Set (Capacity : Count_Type) is tagged record
+ Tree : Tree_Type_Access := new Tree_Types.Tree_Type (Capacity);
+ K : Kind := Plain;
+ Length : Count_Type := 0;
+ First : Count_Type := 0;
+ Last : Count_Type := 0;
+ end record;
+
+ use Red_Black_Trees;
+ use Ada.Streams;
+
+ type Set_Access is access all Set;
+ for Set_Access'Storage_Size use 0;
+
+ type Cursor is record
+ Node : Count_Type;
+ end record;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor);
+
+ for Cursor'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor);
+
+ for Cursor'Read use Read;
+
+ No_Element : constant Cursor := (Node => 0);
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Set);
+
+ for Set'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Set);
+
+ for Set'Read use Read;
+
+ Empty_Set : constant Set :=
+ (Capacity => 0, others => <>);
+
+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, 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 is
+
+ type Int is range System.Min_Int .. System.Max_Int;
+ type UInt is mod System.Max_Binary_Modulus;
+
+ function Get_Element
+ (Container : Vector;
+ Position : Count_Type) return Element_Type;
+
+ ---------
+ -- "&" --
+ ---------
+
+ function "&" (Left, Right : Vector) return Vector is
+ LN : constant Count_Type := Length (Left);
+ RN : constant Count_Type := Length (Right);
+
+ RFst : Count_Type;
+ RLst : Count_Type;
+ LFst : Count_Type;
+ LLst : Count_Type;
+
+ begin
+
+ if Right.K = Plain then
+ RFst := 1;
+ RLst := RN;
+ else
+ RFst := Right.First;
+ RLst := Right.First + RN - 1;
+ end if;
+
+ if Left.K = Plain then
+ LFst := 1;
+ LLst := LN;
+ else
+ LFst := Left.First;
+ LLst := Left.First + LN - 1;
+ end if;
+
+ if LN = 0 then
+ if RN = 0 then
+ return Empty_Vector;
+ end if;
+
+ declare
+ E : constant Elements_Array (1 .. Length (Right)) :=
+ Right.Plain.Elements (RFst .. RLst);
+ begin
+ return (Length (Right),
+ new Plain_Vector'(Length (Right), E,
+ Last => Right.Plain.Last, others => <>),
+ others => <>);
+ end;
+ end if;
+
+ if RN = 0 then
+ declare
+ E : constant Elements_Array (1 .. Length (Left)) :=
+ Left.Plain.Elements (LFst .. LLst);
+ begin
+ return (Length (Left),
+ new Plain_Vector'(Length (Left), E,
+ Last => Left.Plain.Last, others => <>),
+ others => <>);
+ end;
+
+ end if;
+
+ declare
+ N : constant Int'Base := Int (LN) + Int (RN);
+ Last_As_Int : Int'Base;
+
+ begin
+ if Int (No_Index) > Int'Last - N then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ Last_As_Int := Int (No_Index) + N;
+
+ if Last_As_Int > Int (Index_Type'Last) then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ -- TODO: should check whether length > max capacity (cnt_t'last) ???
+
+ declare
+ Last : constant Index_Type := Index_Type (Last_As_Int);
+
+ LE : constant Elements_Array (1 .. Length (Left)) :=
+ Left.Plain.Elements (LFst .. LLst);
+
+ RE : Elements_Array renames Right.Plain.Elements (RFst .. RLst);
+
+ Capacity : constant Count_Type := Length (Left) + Length (Right);
+
+ begin
+ return (Capacity,
+ new Plain_Vector'(Capacity, LE & RE,
+ Last => Last, others => <>),
+ others => <>);
+ end;
+ end;
+ end "&";
+
+ function "&" (Left : Vector; Right : Element_Type) return Vector is
+ LN : constant Count_Type := Length (Left);
+ Last_As_Int : Int'Base;
+ LFst : Count_Type;
+ LLst : Count_Type;
+
+ begin
+ if LN = 0 then
+ return (1,
+ new Plain_Vector'(1, (1 .. 1 => Right),
+ Index_Type'First, others => <>),
+ others => <>);
+ end if;
+
+ if Int (Index_Type'First) > Int'Last - Int (LN) then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ Last_As_Int := Int (Index_Type'First) + Int (LN);
+
+ if Last_As_Int > Int (Index_Type'Last) then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ if Left.K = Plain then
+ LFst := 1;
+ LLst := LN;
+ else
+ LFst := Left.First;
+ LLst := Left.First + LN - 1;
+ end if;
+
+ declare
+ Last : constant Index_Type := Index_Type (Last_As_Int);
+
+ LE : constant Elements_Array (1 .. LN) :=
+ Left.Plain.Elements (LFst .. LLst);
+
+ Capacity : constant Count_Type := Length (Left) + 1;
+
+ begin
+ return (Capacity,
+ new Plain_Vector'(Capacity, LE & Right,
+ Last => Last, others => <>),
+ others => <>);
+ end;
+
+ end "&";
+
+ function "&" (Left : Element_Type; Right : Vector) return Vector is
+ RN : constant Count_Type := Length (Right);
+ Last_As_Int : Int'Base;
+
+ RFst : Count_Type;
+ RLst : Count_Type;
+
+ begin
+ if RN = 0 then
+ return (1,
+ new Plain_Vector'(1, (1 .. 1 => Left),
+ Index_Type'First, others => <>),
+ others => <>);
+ end if;
+
+ if Int (Index_Type'First) > Int'Last - Int (RN) then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ Last_As_Int := Int (Index_Type'First) + Int (RN);
+
+ if Last_As_Int > Int (Index_Type'Last) then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ if Right.K = Plain then
+ RFst := 1;
+ RLst := RN;
+ else
+ RFst := Right.First;
+ RLst := Right.First + RN - 1;
+ end if;
+
+ declare
+ Last : constant Index_Type := Index_Type (Last_As_Int);
+
+ RE : Elements_Array renames Right.Plain.Elements (RFst .. RLst);
+
+ Capacity : constant Count_Type := 1 + Length (Right);
+
+ begin
+ return (Capacity,
+ new Plain_Vector'(Capacity, Left & RE,
+ Last => Last, others => <>),
+ others => <>);
+ end;
+ end "&";
+
+ function "&" (Left, Right : Element_Type) return Vector is
+ begin
+ if Index_Type'First >= Index_Type'Last then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ declare
+ Last : constant Index_Type := Index_Type'First + 1;
+
+ begin
+ return (2,
+ new Plain_Vector'(2, (Left, Right),
+ Last => Last, others => <>),
+ others => <>);
+ end;
+ end "&";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, 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 Count_Type range 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 Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Is_Empty (New_Item) then
+ return;
+ end if;
+
+ if Container.Plain.Last = Index_Type'Last then
+ raise Constraint_Error with "vector is already at its maximum length";
+ end if;
+
+ Insert
+ (Container,
+ Container.Plain.Last + 1,
+ New_Item);
+ end Append;
+
+ procedure Append
+ (Container : in out Vector;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Container.Plain.Last = Index_Type'Last then
+ raise Constraint_Error with "vector is already at its maximum length";
+ end if;
+
+ -- TODO: should check whether length > max capacity (cnt_t'last) ???
+
+ Insert
+ (Container,
+ Container.Plain.Last + 1,
+ New_Item,
+ Count);
+ end Append;
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out Vector; Source : Vector) is
+ LS : constant Count_Type := Length (Source);
+ begin
+
+ if Target.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Capacity < LS then
+ raise Constraint_Error;
+ end if;
+
+ Target.Clear;
+
+ if Source.K = Plain then
+ Target.Plain.Elements (1 .. LS) :=
+ Source.Plain.Elements (1 .. LS);
+ Target.Plain.Last := Source.Plain.Last;
+ else
+ Target.Plain.Elements (1 .. LS) :=
+ Source.Plain.Elements (Source.First .. (Source.First + LS - 1));
+ Target.Plain.Last := Source.Last;
+ end if;
+
+ end Assign;
+
+ --------------
+ -- Capacity --
+ --------------
+
+ function Capacity (Container : Vector) return Capacity_Subtype is
+ begin
+ return Container.Plain.Elements'Length;
+ end Capacity;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Vector) is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (vector is busy)";
+ end if;
+
+ Container.Plain.Last := No_Index;
+ end Clear;
+
+ --------------
+ -- 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_Subtype := 0) return Vector
+ is
+ LS : constant Count_Type := Length (Source);
+ C : Capacity_Subtype;
+
+ begin
+ if Capacity = 0 then
+ C := LS;
+
+ elsif Capacity >= LS then
+ C := Capacity;
+
+ else
+ raise Constraint_Error;
+ end if;
+
+ return Target : Vector (C) do
+ if Source.K = Plain then
+ Target.Plain.Elements (1 .. LS) :=
+ Source.Plain.Elements (1 .. LS);
+ Target.Plain.Last := Source.Plain.Last;
+ else
+ Target.Plain.Elements (1 .. LS) :=
+ Source.Plain.Elements (Source.First .. (Source.First + LS - 1));
+ Target.Plain.Last := Source.Last;
+ end if;
+
+ end return;
+ end Copy;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete
+ (Container : in out Vector;
+ Index : Extended_Index;
+ Count : Count_Type := 1)
+ is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Index < Index_Type'First then
+ raise Constraint_Error with "Index is out of range (too small)";
+ end if;
+
+ if Index > Container.Plain.Last then
+ if Index > Container.Plain.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;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (vector is busy)";
+ end if;
+
+ declare
+ I_As_Int : constant Int := Int (Index);
+ Old_Last_As_Int : constant Int :=
+ Index_Type'Pos (Container.Plain.Last);
+
+ Count1 : constant Int'Base := Count_Type'Pos (Count);
+ Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
+ N : constant Int'Base := Int'Min (Count1, Count2);
+
+ J_As_Int : constant Int'Base := I_As_Int + N;
+
+ begin
+ if J_As_Int > Old_Last_As_Int then
+ Container.Plain.Last := Index - 1;
+
+ else
+ declare
+ EA : Elements_Array renames Container.Plain.Elements;
+
+ II : constant Int'Base := I_As_Int - Int (No_Index);
+ I : constant Count_Type := Count_Type (II);
+
+ JJ : constant Int'Base := J_As_Int - Int (No_Index);
+ J : constant Count_Type := Count_Type (JJ);
+
+ New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
+ New_Last : constant Index_Type :=
+ Index_Type (New_Last_As_Int);
+
+ KK : constant Int := New_Last_As_Int - Int (No_Index);
+ K : constant Count_Type := Count_Type (KK);
+
+ begin
+ EA (I .. K) := EA (J .. Length (Container));
+ Container.Plain.Last := New_Last;
+ end;
+ end if;
+ end;
+ end Delete;
+
+ procedure Delete
+ (Container : in out Vector;
+ Position : in out Cursor;
+ Count : Count_Type := 1)
+ is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Position.Valid then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Index > Container.Plain.Last then
+ raise Program_Error with "Position index is out of range";
+ end if;
+
+ Delete (Container, Position.Index, Count);
+ Position := No_Element;
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First
+ (Container : in out Vector;
+ Count : Count_Type := 1)
+ is
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Count >= Length (Container) then
+ Clear (Container);
+ return;
+ end if;
+
+ Delete (Container, Index_Type'First, Count);
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last
+ (Container : in out Vector;
+ Count : Count_Type := 1)
+ is
+ Index : Int'Base;
+
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (vector is busy)";
+ end if;
+
+ Index := Int'Base (Container.Plain.Last) - Int'Base (Count);
+
+ if Index < Index_Type'Pos (Index_Type'First) then
+ Container.Plain.Last := No_Index;
+ else
+ Container.Plain.Last := Index_Type (Index);
+ end if;
+ end Delete_Last;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element
+ (Container : Vector;
+ Index : Index_Type) return Element_Type
+ is
+ begin
+ if Index > Container.Plain.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 Count_Type := Count_Type (II);
+
+ begin
+
+ if Container.K = Part and then
+ (I > Length (Container)) then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ return Get_Element (Container, I);
+ end;
+ end Element;
+
+ function Element
+ (Container : Vector;
+ Position : Cursor) return Element_Type
+ is
+ Lst : constant Index_Type := Last_Index (Container);
+ begin
+ if not Position.Valid then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Index > Lst then
+ raise Constraint_Error with "Position cursor is out of range";
+ end if;
+
+ declare
+ II : constant Int'Base := Int (Position.Index) - Int (No_Index);
+ I : constant Count_Type := Count_Type (II);
+
+ begin
+
+ return Get_Element (Container, I);
+ end;
+ end Element;
+
+ ----------
+ -- Find --
+ ----------
+
+ function Find
+ (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor
+ is
+ K : Count_Type;
+ Last : constant Index_Type := Last_Index (Container);
+
+ begin
+
+ if Position.Valid then
+ if Position.Index > Last_Index (Container) then
+ raise Program_Error with "Position index is out of range";
+ end if;
+ end if;
+
+ K := Count_Type (Int (Position.Index) - Int (No_Index));
+
+ for J in Position.Index .. Last loop
+ if Get_Element (Container, K) = Item then
+ return Cursor'(Index => J, others => <>);
+ end if;
+ K := K + 1;
+ end loop;
+
+ return No_Element;
+
+ end Find;
+
+ ----------------
+ -- 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 Index_Type := Last_Index (Container);
+
+ begin
+
+ K := Count_Type (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 --
+ -----------
+
+ function First (Container : Vector) return Cursor is
+ begin
+ if Is_Empty (Container) then
+ return No_Element;
+ end if;
+
+ return (True, Index_Type'First);
+ end First;
+
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element (Container : Vector) return Element_Type is
+ begin
+ if Is_Empty (Container) then
+ raise Constraint_Error with "Container is empty";
+ end if;
+
+ return Get_Element (Container, 1);
+ 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;
+
+ ---------------------
+ -- Generic_Sorting --
+ ---------------------
+
+ package body Generic_Sorting is
+
+ ---------------
+ -- Is_Sorted --
+ ---------------
+
+ function Is_Sorted (Container : Vector) return Boolean is
+ Last : constant Index_Type := Last_Index (Container);
+ begin
+
+ if Container.Plain.Last <= Last then
+ return True;
+ end if;
+
+ declare
+ L : constant Capacity_Subtype := Length (Container);
+ begin
+
+ for J in Count_Type range 1 .. L - 1 loop
+ if Get_Element (Container, J + 1)
+ < Get_Element (Container, J) then
+ return False;
+ end if;
+ end loop;
+ end;
+
+ return True;
+ end Is_Sorted;
+
+ -----------
+ -- Merge --
+ -----------
+
+ procedure Merge (Target, Source : in out Vector) is
+ begin
+
+ if Target.K /= Plain or Source.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ declare
+ TA : Elements_Array renames Target.Plain.Elements;
+ SA : Elements_Array renames Source.Plain.Elements;
+
+ I, J : Count_Type;
+
+ begin
+ -- ???
+ -- if Target.Last < Index_Type'First then
+ -- Move (Target => Target, Source => Source);
+ -- return;
+ -- end if;
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.Plain.Last < Index_Type'First then
+ return;
+ end if;
+
+ -- I think we're missing this check in a-convec.adb... ???
+ if Target.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (vector is busy)";
+ end if;
+
+ if Source.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (vector is busy)";
+ end if;
+
+ I := Length (Target);
+ Target.Set_Length (I + Length (Source));
+
+ J := Length (Target);
+ while not Source.Is_Empty loop
+ pragma Assert (Length (Source) <= 1
+ or else not (SA (Length (Source)) <
+ SA (Length (Source) - 1)));
+
+ if I = 0 then
+ TA (1 .. J) := SA (1 .. Length (Source));
+ Source.Plain.Last := No_Index;
+ return;
+ end if;
+
+ pragma Assert (I <= 1
+ or else not (TA (I) < TA (I - 1)));
+
+ if SA (Length (Source)) < TA (I) then
+ TA (J) := TA (I);
+ I := I - 1;
+
+ else
+ TA (J) := SA (Length (Source));
+ Source.Plain.Last := Source.Plain.Last - 1;
+ end if;
+
+ J := J - 1;
+ end loop;
+ end;
+ end Merge;
+
+ ----------
+ -- Sort --
+ ----------
+
+ procedure Sort (Container : in out Vector)
+ is
+ procedure Sort is
+ new Generic_Array_Sort
+ (Index_Type => Count_Type,
+ Element_Type => Element_Type,
+ Array_Type => Elements_Array,
+ "<" => "<");
+
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Container.Plain.Last <= Index_Type'First then
+ return;
+ end if;
+
+ if Container.Plain.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is locked)";
+ end if;
+
+ Sort (Container.Plain.Elements (1 .. Length (Container)));
+ end Sort;
+
+ end Generic_Sorting;
+
+ -----------------
+ -- Get_Element --
+ -----------------
+
+ function Get_Element
+ (Container : Vector;
+ Position : Count_Type) return Element_Type is
+ begin
+ if Container.K = Plain then
+ return Container.Plain.Elements (Position);
+ end if;
+
+ return Container.Plain.Elements (Position + Container.First - 1);
+ end Get_Element;
+
+ -----------------
+ -- Has_Element --
+ -----------------
+
+ function Has_Element
+ (Container : Vector;
+ Position : Cursor) return Boolean is
+ begin
+ if not Position.Valid then
+ return False;
+ end if;
+
+ return Position.Index <= Last_Index (Container);
+ end Has_Element;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ N : constant Int := Count_Type'Pos (Count);
+
+ First : constant Int := Int (Index_Type'First);
+ New_Last_As_Int : Int'Base;
+ New_Last : Index_Type;
+ New_Length : UInt;
+ Max_Length : constant UInt := UInt (Container.Capacity);
+
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Before < Index_Type'First then
+ raise Constraint_Error with
+ "Before index is out of range (too small)";
+ end if;
+
+ if Before > Container.Plain.Last
+ and then Before > Container.Plain.Last + 1
+ then
+ raise Constraint_Error with
+ "Before index is out of range (too large)";
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ declare
+ Old_Last_As_Int : constant Int := Int (Container.Plain.Last);
+
+ begin
+ if Old_Last_As_Int > Int'Last - N then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ New_Last_As_Int := Old_Last_As_Int + N;
+
+ if New_Last_As_Int > Int (Index_Type'Last) then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ New_Length := UInt (New_Last_As_Int - First + Int'(1));
+
+ if New_Length > Max_Length then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ New_Last := Index_Type (New_Last_As_Int);
+
+ -- Resolve issue of capacity vs. max index ???
+ end;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (vector is busy)";
+ end if;
+
+ declare
+ EA : Elements_Array renames Container.Plain.Elements;
+
+ BB : constant Int'Base := Int (Before) - Int (No_Index);
+ B : constant Count_Type := Count_Type (BB);
+
+ LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
+ L : constant Count_Type := Count_Type (LL);
+
+ begin
+ if Before <= Container.Plain.Last then
+ declare
+ II : constant Int'Base := BB + N;
+ I : constant Count_Type := Count_Type (II);
+
+ begin
+ EA (I .. L) := EA (B .. Length (Container));
+ EA (B .. I - 1) := (others => New_Item);
+ end;
+
+ else
+ EA (B .. L) := (others => New_Item);
+ end if;
+ end;
+
+ Container.Plain.Last := New_Last;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Vector)
+ is
+ N : constant Count_Type := Length (New_Item);
+
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Before < Index_Type'First then
+ raise Constraint_Error with
+ "Before index is out of range (too small)";
+ end if;
+
+ if Before > Container.Plain.Last
+ and then Before > Container.Plain.Last + 1
+ then
+ raise Constraint_Error with
+ "Before index is out of range (too large)";
+ end if;
+
+ if N = 0 then
+ return;
+ end if;
+
+ Insert_Space (Container, Before, Count => N);
+
+ declare
+ Dst_Last_As_Int : constant Int'Base :=
+ Int (Before) + Int (N) - 1 - Int (No_Index);
+
+ Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int);
+
+ Src_Fst : Count_Type;
+ Src_Lst : Count_Type;
+
+ BB : constant Int'Base := Int (Before) - Int (No_Index);
+ B : constant Count_Type := Count_Type (BB);
+
+ begin
+
+ if Container.K = Plain then
+ Src_Fst := 1;
+ Src_Lst := N;
+ else
+ Src_Fst := New_Item.First;
+ Src_Lst := N + New_Item.First - 1;
+ end if;
+
+ if Container'Address /= New_Item'Address then
+ Container.Plain.Elements (B .. Dst_Last) :=
+ New_Item.Plain.Elements (Src_Fst .. Src_Lst);
+
+ return;
+ end if;
+
+ declare
+ Src : Elements_Array renames Container.Plain.Elements (1 .. B - 1);
+
+ Index_As_Int : constant Int'Base := BB + Src'Length - 1;
+
+ Index : constant Count_Type := Count_Type (Index_As_Int);
+
+ Dst : Elements_Array renames Container.Plain.Elements (B .. Index);
+
+ begin
+ Dst := Src;
+ end;
+
+ if Dst_Last = Length (Container) then
+ return;
+ end if;
+
+ declare
+ Src : Elements_Array renames
+ Container.Plain.Elements
+ (Dst_Last + 1 .. Length (Container));
+
+ Index_As_Int : constant Int'Base :=
+ Dst_Last_As_Int - Src'Length + 1;
+
+ Index : constant Count_Type := Count_Type (Index_As_Int);
+
+ Dst : Elements_Array renames
+ Container.Plain.Elements (Index .. Dst_Last);
+
+ begin
+ Dst := Src;
+ end;
+ end;
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector)
+ is
+ Index : Index_Type'Base;
+
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Is_Empty (New_Item) then
+ return;
+ end if;
+
+ if not Before.Valid
+ or else Before.Index > Container.Plain.Last
+ then
+ if Container.Plain.Last = Index_Type'Last then
+ raise Constraint_Error with
+ "vector is already at its maximum length";
+ end if;
+
+ Index := Container.Plain.Last + 1;
+
+ else
+ Index := Before.Index;
+ end if;
+
+ Insert (Container, Index, New_Item);
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector;
+ Position : out Cursor)
+ is
+ Index : Index_Type'Base;
+
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Is_Empty (New_Item) then
+ if not Before.Valid
+ or else Before.Index > Container.Plain.Last
+ then
+ Position := No_Element;
+ else
+ Position := (True, Before.Index);
+ end if;
+
+ return;
+ end if;
+
+ if not Before.Valid
+ or else Before.Index > Container.Plain.Last
+ then
+ if Container.Plain.Last = Index_Type'Last then
+ raise Constraint_Error with
+ "vector is already at its maximum length";
+ end if;
+
+ Index := Container.Plain.Last + 1;
+
+ else
+ Index := Before.Index;
+ end if;
+
+ Insert (Container, Index, New_Item);
+
+ Position := Cursor'(True, Index);
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1)
+ is
+ Index : Index_Type'Base;
+
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ if not Before.Valid
+ or else Before.Index > Container.Plain.Last
+ then
+ if Container.Plain.Last = Index_Type'Last then
+ raise Constraint_Error with
+ "vector is already at its maximum length";
+ end if;
+
+ Index := Container.Plain.Last + 1;
+
+ else
+ Index := Before.Index;
+ end if;
+
+ Insert (Container, Index, New_Item, Count);
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ Index : Index_Type'Base;
+
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Count = 0 then
+ if not Before.Valid
+ or else Before.Index > Container.Plain.Last
+ then
+ Position := No_Element;
+ else
+ Position := (True, Before.Index);
+ end if;
+
+ return;
+ end if;
+
+ if not Before.Valid
+ or else Before.Index > Container.Plain.Last
+ then
+ if Container.Plain.Last = Index_Type'Last then
+ raise Constraint_Error with
+ "vector is already at its maximum length";
+ end if;
+
+ Index := Container.Plain.Last + 1;
+
+ else
+ Index := Before.Index;
+ end if;
+
+ Insert (Container, Index, New_Item, Count);
+
+ Position := Cursor'(True, Index);
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ Count : Count_Type := 1)
+ is
+ New_Item : Element_Type; -- Default-initialized value
+ pragma Warnings (Off, New_Item);
+
+ begin
+ Insert (Container, Before, New_Item, Count);
+ end Insert;
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ New_Item : Element_Type; -- Default-initialized value
+ pragma Warnings (Off, New_Item);
+
+ begin
+ Insert (Container, Before, New_Item, Position, Count);
+ end Insert;
+
+ ------------------
+ -- Insert_Space --
+ ------------------
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Extended_Index;
+ Count : Count_Type := 1)
+ is
+ N : constant Int := Count_Type'Pos (Count);
+
+ First : constant Int := Int (Index_Type'First);
+ New_Last_As_Int : Int'Base;
+ New_Last : Index_Type;
+ New_Length : UInt;
+ Max_Length : constant UInt := UInt (Count_Type'Last);
+
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Before < Index_Type'First then
+ raise Constraint_Error with
+ "Before index is out of range (too small)";
+ end if;
+
+ if Before > Container.Plain.Last
+ and then Before > Container.Plain.Last + 1
+ then
+ raise Constraint_Error with
+ "Before index is out of range (too large)";
+ end if;
+
+ if Count = 0 then
+ return;
+ end if;
+
+ declare
+ Old_Last_As_Int : constant Int := Int (Container.Plain.Last);
+
+ begin
+ if Old_Last_As_Int > Int'Last - N then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ New_Last_As_Int := Old_Last_As_Int + N;
+
+ if New_Last_As_Int > Int (Index_Type'Last) then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ New_Length := UInt (New_Last_As_Int - First + Int'(1));
+
+ if New_Length > Max_Length then
+ raise Constraint_Error with "new length is out of range";
+ end if;
+
+ New_Last := Index_Type (New_Last_As_Int);
+
+ -- Resolve issue of capacity vs. max index ???
+ end;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (vector is busy)";
+ end if;
+
+ declare
+ EA : Elements_Array renames Container.Plain.Elements;
+
+ BB : constant Int'Base := Int (Before) - Int (No_Index);
+ B : constant Count_Type := Count_Type (BB);
+
+ LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
+ L : constant Count_Type := Count_Type (LL);
+
+ begin
+ if Before <= Container.Plain.Last then
+ declare
+ II : constant Int'Base := BB + N;
+ I : constant Count_Type := Count_Type (II);
+
+ begin
+ EA (I .. L) := EA (B .. Length (Container));
+ end;
+ end if;
+ end;
+
+ Container.Plain.Last := New_Last;
+ end Insert_Space;
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1)
+ is
+ Index : Index_Type'Base;
+
+ begin
+
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Count = 0 then
+ if not Before.Valid
+ or else Before.Index > Container.Plain.Last
+ then
+ Position := No_Element;
+ else
+ Position := (True, Before.Index);
+ end if;
+
+ return;
+ end if;
+
+ if not Before.Valid
+ or else Before.Index > Container.Plain.Last
+ then
+ if Container.Plain.Last = Index_Type'Last then
+ raise Constraint_Error with
+ "vector is already at its maximum length";
+ end if;
+
+ Index := Container.Plain.Last + 1;
+
+ else
+ Index := Before.Index;
+ end if;
+
+ Insert_Space (Container, Index, Count => Count);
+
+ Position := Cursor'(True, Index);
+ end Insert_Space;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Vector) return Boolean is
+ begin
+ return Last_Index (Container) < Index_Type'First;
+ end Is_Empty;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ procedure Iterate
+ (Container : Vector;
+ Process :
+ not null access procedure (Container : Vector; Position : Cursor))
+ is
+ V : Vector renames Container'Unrestricted_Access.all;
+ B : Natural renames V.Plain.Busy;
+
+ begin
+ B := B + 1;
+
+ begin
+ for Indx in Index_Type'First .. Last_Index (Container) loop
+ Process (Container, Cursor'(True, Indx));
+ end loop;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Iterate;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Container : Vector) return Cursor is
+ begin
+ if Is_Empty (Container) then
+ return No_Element;
+ end if;
+
+ return (True, Last_Index (Container));
+ end Last;
+
+ ------------------
+ -- Last_Element --
+ ------------------
+
+ function Last_Element (Container : Vector) return Element_Type is
+ begin
+ if Is_Empty (Container) then
+ raise Constraint_Error with "Container is empty";
+ end if;
+
+ return Get_Element (Container, Length (Container));
+ end Last_Element;
+
+ ----------------
+ -- Last_Index --
+ ----------------
+
+ function Last_Index (Container : Vector) return Extended_Index is
+ begin
+ if Container.K = Plain then
+ return Container.Plain.Last;
+ else
+ return Container.Last;
+ end if;
+ end Last_Index;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Container : Vector) return Capacity_Subtype is
+ L : constant Int := Int (Last_Index (Container));
+ F : constant Int := Int (Index_Type'First);
+ N : constant Int'Base := L - F + 1;
+
+ begin
+ return Capacity_Subtype (N);
+ end Length;
+
+ ----------
+ -- Left --
+ ----------
+
+ function Left (Container : Vector; Position : Cursor) return Vector is
+ Fst : Count_Type;
+ begin
+ if Container.K = Plain then
+ Fst := 1;
+ else
+ Fst := Container.First;
+ end if;
+
+ if not Position.Valid then
+ return (Container.Capacity, Container.Plain, Part, Fst,
+ Last_Index (Container));
+ end if;
+
+ if Position.Index > Last_Index (Container) then
+ raise Constraint_Error with
+ "Before index is out of range (too large)";
+ end if;
+
+ return (Container.Capacity, Container.Plain, Part, Fst,
+ (Position.Index - 1));
+ end Left;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move
+ (Target : in out Vector;
+ Source : in out Vector)
+ is
+ N : constant Count_Type := Length (Source);
+
+ begin
+
+ if Target.K /= Plain or Source.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Target.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (Target is busy)";
+ end if;
+
+ if Source.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (Source is busy)";
+ end if;
+
+ if N > Target.Capacity then
+ raise Constraint_Error with -- correct exception here???
+ "length of Source is greater than capacity of Target";
+ end if;
+
+ -- We could also write this as a loop, and incrementally
+ -- copy elements from source to target.
+
+ Target.Plain.Last := No_Index; -- in case array assignment files
+ Target.Plain.Elements (1 .. N) := Source.Plain.Elements (1 .. N);
+
+ Target.Plain.Last := Source.Plain.Last;
+ Source.Plain.Last := No_Index;
+ end Move;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (Container : Vector; Position : Cursor) return Cursor is
+ begin
+ if not Position.Valid then
+ return No_Element;
+ end if;
+
+ if Position.Index < Last_Index (Container) then
+ return (True, Position.Index + 1);
+ end if;
+
+ return No_Element;
+ end Next;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next (Container : Vector; Position : in out Cursor) is
+ begin
+ if not Position.Valid then
+ return;
+ end if;
+
+ if Position.Index < Last_Index (Container) then
+ Position.Index := Position.Index + 1;
+ else
+ Position := No_Element;
+ end if;
+ end Next;
+
+ -------------
+ -- 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;
+ Count : Count_Type := 1)
+ is
+ begin
+ Insert (Container,
+ Index_Type'First,
+ New_Item,
+ Count);
+ end Prepend;
+
+ --------------
+ -- Previous --
+ --------------
+
+ procedure Previous (Container : Vector; Position : in out Cursor) is
+ begin
+ if not Position.Valid then
+ return;
+ end if;
+
+ if Position.Index > Index_Type'First and
+ Position.Index <= Last_Index (Container) then
+ Position.Index := Position.Index - 1;
+ else
+ Position := No_Element;
+ end if;
+ end Previous;
+
+ function Previous (Container : Vector; Position : Cursor) return Cursor is
+ begin
+ if not Position.Valid then
+ return No_Element;
+ end if;
+
+ if Position.Index > Index_Type'First and
+ Position.Index <= Last_Index (Container) then
+ return (True, Position.Index - 1);
+ end if;
+
+ return No_Element;
+ end Previous;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Container : Vector;
+ Index : Index_Type;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ V : Vector renames Container'Unrestricted_Access.all;
+ B : Natural renames V.Plain.Busy;
+ L : Natural renames V.Plain.Lock;
+
+ begin
+ if Index > Last_Index (Container) then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ B := B + 1;
+ L := L + 1;
+
+ declare
+ II : constant Int'Base := Int (Index) - Int (No_Index);
+ I : constant Count_Type := Count_Type (II);
+
+ begin
+ Process (Get_Element (V, I));
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end Query_Element;
+
+ procedure Query_Element
+ (Container : Vector;
+ Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ if not Position.Valid then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ Query_Element (Container, Position.Index, Process);
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Vector)
+ is
+ Length : Count_Type'Base;
+ Last : Index_Type'Base := No_Index;
+
+ begin
+ Clear (Container);
+
+ Count_Type'Base'Read (Stream, Length);
+
+ if Length < 0 then
+ raise Program_Error with "stream appears to be corrupt";
+ end if;
+
+ if Length > Container.Capacity then
+ raise Storage_Error with "not enough capacity"; -- ???
+ end if;
+
+ for J in Count_Type range 1 .. Length loop
+ Last := Last + 1;
+ Element_Type'Read (Stream, Container.Plain.Elements (J));
+ Container.Plain.Last := Last;
+ end loop;
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : out Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream vector cursor";
+ end Read;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Container : in out Vector;
+ Index : Index_Type;
+ New_Item : Element_Type)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Index > Container.Plain.Last then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ if Container.Plain.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is locked)";
+ end if;
+
+ declare
+ II : constant Int'Base := Int (Index) - Int (No_Index);
+ I : constant Count_Type := Count_Type (II);
+
+ begin
+ Container.Plain.Elements (I) := New_Item;
+ end;
+ end Replace_Element;
+
+ procedure Replace_Element
+ (Container : in out Vector;
+ Position : Cursor;
+ New_Item : Element_Type)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not Position.Valid then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Index > Container.Plain.Last then
+ raise Constraint_Error with "Position cursor is out of range";
+ end if;
+
+ if Container.Plain.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is locked)";
+ end if;
+
+ declare
+ II : constant Int'Base := Int (Position.Index) - Int (No_Index);
+ I : constant Count_Type := Count_Type (II);
+
+ begin
+ Container.Plain.Elements (I) := New_Item;
+ end;
+ end Replace_Element;
+
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+
+ procedure Reserve_Capacity
+ (Container : in out Vector;
+ Capacity : Capacity_Subtype)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Capacity > Container.Capacity then
+ raise Constraint_Error; -- ???
+ end if;
+ end Reserve_Capacity;
+
+ ----------------------
+ -- Reverse_Elements --
+ ----------------------
+
+ procedure Reverse_Elements (Container : in out Vector) is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Length (Container) <= 1 then
+ return;
+ end if;
+
+ if Container.Plain.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is locked)";
+ end if;
+
+ declare
+ I, J : Count_Type;
+ E : Elements_Array renames Container.Plain.Elements;
+
+ 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 --
+ ------------------
+
+ function Reverse_Find
+ (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor
+ is
+ Last : Index_Type'Base;
+ K : Count_Type;
+
+ begin
+
+ if not Position.Valid
+ or else Position.Index > Last_Index (Container)
+ then
+ Last := Last_Index (Container);
+ else
+ Last := Position.Index;
+ end if;
+
+ K := Count_Type (Int (Last) - Int (No_Index));
+ for Indx in reverse Index_Type'First .. Last loop
+ if Get_Element (Container, K) = Item then
+ return (True, Indx);
+ end if;
+ K := K - 1;
+ end loop;
+
+ return No_Element;
+ end Reverse_Find;
+
+ ------------------------
+ -- 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;
+
+ begin
+ if Index > Last_Index (Container) then
+ Last := Last_Index (Container);
+ else
+ Last := Index;
+ end if;
+
+ K := Count_Type (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;
+
+ ---------------------
+ -- Reverse_Iterate --
+ ---------------------
+
+ procedure Reverse_Iterate
+ (Container : Vector;
+ Process :
+ not null access procedure (Container : Vector; Position : Cursor))
+ is
+ V : Vector renames Container'Unrestricted_Access.all;
+ B : Natural renames V.Plain.Busy;
+
+ begin
+ B := B + 1;
+
+ begin
+ for Indx in reverse Index_Type'First .. Last_Index (Container) loop
+ Process (Container, Cursor'(True, Indx));
+ end loop;
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Reverse_Iterate;
+
+ -----------
+ -- Right --
+ -----------
+
+ function Right (Container : Vector; Position : Cursor) return Vector is
+ Fst : Count_Type;
+ begin
+ if Container.K = Plain then
+ Fst := 1;
+ else
+ Fst := Container.First;
+ end if;
+
+ if not Position.Valid then
+ return (Container.Capacity, Container.Plain, Part, Fst, No_Index);
+ end if;
+
+ if Position.Index > Last_Index (Container) then
+ raise Constraint_Error with
+ "Position index is out of range (too large)";
+ end if;
+
+ Fst := Fst + Count_Type (Int (Position.Index) - Int (No_Index)) - 1;
+
+ return (Container.Capacity, Container.Plain, Part, Fst,
+ (Last_Index (Container) - Position.Index + 1));
+ end Right;
+
+ ----------------
+ -- Set_Length --
+ ----------------
+
+ procedure Set_Length
+ (Container : in out Vector;
+ Length : Capacity_Subtype)
+ is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Length = Formal_Vectors.Length (Container) then
+ return;
+ end if;
+
+ if Container.Plain.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (vector is busy)";
+ end if;
+
+ if Length > Container.Capacity then
+ raise Constraint_Error; -- ???
+ end if;
+
+ declare
+ Last_As_Int : constant Int'Base :=
+ Int (Index_Type'First) + Int (Length) - 1;
+ begin
+ Container.Plain.Last := Index_Type'Base (Last_As_Int);
+ end;
+ end Set_Length;
+
+ ----------
+ -- Swap --
+ ----------
+
+ procedure Swap (Container : in out Vector; I, J : Index_Type) is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if I > Container.Plain.Last then
+ raise Constraint_Error with "I index is out of range";
+ end if;
+
+ if J > Container.Plain.Last then
+ raise Constraint_Error with "J index is out of range";
+ end if;
+
+ if I = J then
+ return;
+ end if;
+
+ if Container.Plain.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (vector is locked)";
+ 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.Plain.Elements (Count_Type (II));
+ EJ : Element_Type renames Container.Plain.Elements (Count_Type (JJ));
+
+ EI_Copy : constant Element_Type := EI;
+
+ begin
+ EI := EJ;
+ EJ := EI_Copy;
+ end;
+ end Swap;
+
+ procedure Swap (Container : in out Vector; I, J : Cursor) is
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if not I.Valid then
+ raise Constraint_Error with "I cursor has no element";
+ end if;
+
+ if not J.Valid then
+ raise Constraint_Error with "J cursor has no element";
+ end if;
+
+ Swap (Container, I.Index, J.Index);
+ end Swap;
+
+ ---------------
+ -- To_Cursor --
+ ---------------
+
+ function To_Cursor
+ (Container : Vector;
+ Index : Extended_Index) return Cursor
+ is
+ begin
+ if Index not in Index_Type'First .. Last_Index (Container) then
+ return No_Element;
+ end if;
+
+ return Cursor'(True, Index);
+ end To_Cursor;
+
+ --------------
+ -- To_Index --
+ --------------
+
+ function To_Index (Position : Cursor) return Extended_Index is
+ begin
+ if not Position.Valid then
+ return No_Index;
+ end if;
+
+ return Position.Index;
+ end To_Index;
+
+ ---------------
+ -- To_Vector --
+ ---------------
+
+ function To_Vector (Length : Capacity_Subtype) 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 (Length,
+ new Plain_Vector'(Length, (others => <>), Last => Last,
+ others => <>),
+ others => <>);
+ end;
+ end To_Vector;
+
+ function To_Vector
+ (New_Item : Element_Type;
+ Length : Capacity_Subtype) 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 (Length,
+ new Plain_Vector'(Length, (others => New_Item), Last => Last,
+ others => <>),
+ others => <>);
+ end;
+ end To_Vector;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Container : in out Vector;
+ Index : Index_Type;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ B : Natural renames Container.Plain.Busy;
+ L : Natural renames Container.Plain.Lock;
+
+ begin
+ if Container.K /= Plain then
+ raise Constraint_Error
+ with "Can't modify part of container";
+ end if;
+
+ if Index > Container.Plain.Last then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ B := B + 1;
+ L := L + 1;
+
+ declare
+ II : constant Int'Base := Int (Index) - Int (No_Index);
+ I : constant Count_Type := Count_Type (II);
+
+ begin
+ Process (Container.Plain.Elements (I));
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
+
+ L := L - 1;
+ B := B - 1;
+ end Update_Element;
+
+ procedure Update_Element
+ (Container : in out Vector;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ begin
+ if not Position.Valid then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ Update_Element (Container, Position.Index, Process);
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Vector)
+ is
+ begin
+ Count_Type'Base'Write (Stream, Length (Container));
+
+ for J in 1 .. Length (Container) loop
+ Element_Type'Write (Stream, Container.Plain.Elements (J));
+ end loop;
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : Cursor)
+ is
+ begin
+ raise Program_Error with "attempt to stream vector cursor";
+ end Write;
+
+end Ada.Containers.Formal_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 _ V E C T O R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2010, 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/>. --
+------------------------------------------------------------------------------
+
+private with Ada.Streams;
+with Ada.Containers;
+use Ada.Containers;
+
+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 is
+ pragma Pure;
+
+ subtype Extended_Index is Index_Type'Base
+ range Index_Type'First - 1 ..
+ Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
+
+ -- ??? i don't think we can do this...
+ -- TODO: we need the ARG to either figure out how to declare this subtype,
+ -- or eliminate the requirement that it be present.
+ -- subtype Capacity_Subtype is Count_Type -- correct name???
+ -- range 0 .. Count_Type'Max (0,
+ -- Index_Type'Pos (Index_Type'Last) -
+ -- Index_Type'Pos (Index_Type'First) + 1);
+ --
+ -- so for now:
+ subtype Capacity_Subtype is Count_Type;
+
+ No_Index : constant Extended_Index := Extended_Index'First;
+
+ type Vector (Capacity : Capacity_Subtype) is tagged private;
+ -- pragma Preelaborable_Initialization (Vector);
+
+ type Cursor is private;
+ pragma Preelaborable_Initialization (Cursor);
+
+ Empty_Vector : constant Vector;
+
+ No_Element : constant Cursor;
+
+ function "=" (Left, Right : Vector) return Boolean;
+
+ function To_Vector (Length : Capacity_Subtype) return Vector;
+
+ function To_Vector
+ (New_Item : Element_Type;
+ Length : Capacity_Subtype) return Vector;
+
+ function "&" (Left, Right : Vector) return Vector;
+
+ function "&" (Left : Vector; Right : Element_Type) return Vector;
+
+ function "&" (Left : Element_Type; Right : Vector) return Vector;
+
+ function "&" (Left, Right : Element_Type) return Vector;
+
+ function Capacity (Container : Vector) return Capacity_Subtype;
+
+ procedure Reserve_Capacity
+ (Container : in out Vector;
+ Capacity : Capacity_Subtype);
+
+ function Length (Container : Vector) return Capacity_Subtype;
+
+ procedure Set_Length
+ (Container : in out Vector;
+ Length : Capacity_Subtype);
+
+ function Is_Empty (Container : Vector) return Boolean;
+
+ procedure Clear (Container : in out Vector);
+
+ procedure Assign (Target : in out Vector; Source : Vector);
+
+ function Copy
+ (Source : Vector;
+ Capacity : Capacity_Subtype := 0) return Vector;
+
+ function To_Cursor
+ (Container : Vector;
+ Index : Extended_Index) return Cursor;
+
+ function To_Index (Position : Cursor) return Extended_Index;
+
+ function Element
+ (Container : Vector;
+ Index : Index_Type) return Element_Type;
+
+ function Element (Container : Vector; Position : Cursor)
+ return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Vector;
+ Index : Index_Type;
+ New_Item : Element_Type);
+
+ procedure Replace_Element
+ (Container : in out Vector;
+ Position : Cursor;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Container : Vector;
+ Index : Index_Type;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Query_Element
+ (Container : Vector;
+ Position : Cursor;
+ Process : not null access procedure (Element : Element_Type));
+
+ procedure Update_Element
+ (Container : in out Vector;
+ Index : Index_Type;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Update_Element
+ (Container : in out Vector;
+ Position : Cursor;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ procedure Move (Target : in out Vector; Source : in out Vector);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Vector);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Vector;
+ Position : out Cursor);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Extended_Index;
+ Count : Count_Type := 1);
+
+ procedure Insert
+ (Container : in out Vector;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Prepend
+ (Container : in out Vector;
+ New_Item : Vector);
+
+ procedure Prepend
+ (Container : in out Vector;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Append
+ (Container : in out Vector;
+ New_Item : Vector);
+
+ procedure Append
+ (Container : in out Vector;
+ New_Item : Element_Type;
+ Count : Count_Type := 1);
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Extended_Index;
+ Count : Count_Type := 1);
+
+ procedure Insert_Space
+ (Container : in out Vector;
+ Before : Cursor;
+ Position : out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Delete
+ (Container : in out Vector;
+ Index : Extended_Index;
+ Count : Count_Type := 1);
+
+ procedure Delete
+ (Container : in out Vector;
+ Position : in out Cursor;
+ Count : Count_Type := 1);
+
+ procedure Delete_First
+ (Container : in out Vector;
+ Count : Count_Type := 1);
+
+ procedure Delete_Last
+ (Container : in out Vector;
+ Count : Count_Type := 1);
+
+ procedure Reverse_Elements (Container : in out Vector);
+
+ procedure Swap (Container : in out Vector; I, J : Index_Type);
+
+ procedure Swap (Container : in out Vector; I, J : Cursor);
+
+ function First_Index (Container : Vector) return Index_Type;
+
+ function First (Container : Vector) return Cursor;
+
+ function First_Element (Container : Vector) return Element_Type;
+
+ function Last_Index (Container : Vector) return Extended_Index;
+
+ function Last (Container : Vector) return Cursor;
+
+ function Last_Element (Container : Vector) return Element_Type;
+
+ function Next (Container : Vector; Position : Cursor) return Cursor;
+
+ procedure Next (Container : Vector; Position : in out Cursor);
+
+ function Previous (Container : Vector; Position : Cursor) return Cursor;
+
+ procedure Previous (Container : Vector; Position : in out Cursor);
+
+ function Find_Index
+ (Container : Vector;
+ Item : Element_Type;
+ Index : Index_Type := Index_Type'First) return Extended_Index;
+
+ function Find
+ (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor;
+
+ function Reverse_Find_Index
+ (Container : Vector;
+ Item : Element_Type;
+ Index : Index_Type := Index_Type'Last) return Extended_Index;
+
+ function Reverse_Find
+ (Container : Vector;
+ Item : Element_Type;
+ Position : Cursor := No_Element) return Cursor;
+
+ function Contains
+ (Container : Vector;
+ Item : Element_Type) return Boolean;
+
+ function Has_Element (Container : Vector; Position : Cursor) return Boolean;
+
+ procedure Iterate
+ (Container : Vector;
+ Process :
+ not null access procedure (Container : Vector; Position : Cursor));
+
+ procedure Reverse_Iterate
+ (Container : Vector;
+ Process :
+ not null access procedure (Container : Vector; Position : Cursor));
+
+ generic
+ with function "<" (Left, Right : Element_Type) return Boolean is <>;
+ package Generic_Sorting is
+
+ function Is_Sorted (Container : Vector) return Boolean;
+
+ procedure Sort (Container : in out Vector);
+
+ procedure Merge (Target : in out Vector; Source : in out Vector);
+
+ end Generic_Sorting;
+
+ function Left (Container : Vector; Position : Cursor) return Vector;
+
+ function Right (Container : Vector; Position : Cursor) return Vector;
+
+private
+
+ pragma Inline (First_Index);
+ pragma Inline (Last_Index);
+ pragma Inline (Element);
+ pragma Inline (First_Element);
+ pragma Inline (Last_Element);
+ pragma Inline (Query_Element);
+ pragma Inline (Update_Element);
+ pragma Inline (Replace_Element);
+ pragma Inline (Contains);
+ pragma Inline (Next);
+ pragma Inline (Previous);
+
+ type Elements_Array is array (Count_Type range <>) of Element_Type;
+ function "=" (L, R : Elements_Array) return Boolean is abstract;
+
+ type Kind is (Plain, Part);
+
+ type Plain_Vector (Capacity : Capacity_Subtype) is record
+ Elements : Elements_Array (1 .. Capacity);
+ Last : Extended_Index := No_Index;
+ Busy : Natural := 0;
+ Lock : Natural := 0;
+ end record;
+
+ type Plain_Access is access all Plain_Vector;
+
+ type Vector (Capacity : Capacity_Subtype) is tagged record
+ Plain : Plain_Access := new Plain_Vector (Capacity);
+ K : Kind := Formal_Vectors.Plain;
+ First : Count_Type := 0;
+ Last : Index_Type'Base := No_Index;
+ end record;
+
+ use Ada.Streams;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Vector);
+
+ for Vector'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Vector);
+
+ for Vector'Read use Read;
+
+ type Cursor is record
+ Valid : Boolean := True;
+ Index : Index_Type := Index_Type'First;
+ end record;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : Cursor);
+
+ for Cursor'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : out Cursor);
+
+ for Cursor'Read use Read;
+
+ Empty_Vector : constant Vector := (Capacity => 0, others => <>);
+
+ No_Element : constant Cursor := (Valid => False, Index => Index_Type'First);
+
+end Ada.Containers.Formal_Vectors;
end if;
end Change_Error_Text;
- ------------------------------
- -- Check_Formal_Restriction --
- ------------------------------
-
- procedure Check_Formal_Restriction (Msg : String; N : Node_Id) is
- begin
- if Formal_Verification_Mode
- and then Comes_From_Source (Original_Node (N))
- then
- Error_Msg_F ("|~~" & Msg, N);
- end if;
- end Check_Formal_Restriction;
-
------------------------
-- Compilation_Errors --
------------------------
-- the given text. This text may contain insertion characters in the
-- usual manner, and need not be the same length as the original text.
- procedure Check_Formal_Restriction (Msg : String; N : Node_Id);
- -- Provides a wrappper on Error_Msg_F which prepends the special characters
- -- "|~~" (error not serious, language prepended) provided:
- -- * the current mode is formal verification.
- -- * the node N comes originally from source.
- -- Otherwise, does nothing.
-
function First_Node (C : Node_Id) return Node_Id;
-- Given a construct C, finds the first node in the construct, i.e. the
-- one with the lowest Sloc value. This is useful in placing error msgs.
"a-cborse", -- Ada.Containers.Bounded_Ordered_Sets
"a-cborma", -- Ada.Containers.Bounded_Ordered_Maps
"a-cbhase", -- Ada.Containers.Bounded_Hashed_Sets
- "a-cbhama"); -- Ada.Containers.Bounded_Hashed_Maps
+ "a-cbhama", -- Ada.Containers.Bounded_Hashed_Maps
+ "a-cofove", -- Ada.Containers.Formal_Vectors
+ "a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists
+ "a-cforse", -- Ada.Containers.Formal_Ordered_Sets
+ "a-cforma", -- Ada.Containers.Formal_Ordered_Maps
+ "a-cfhase", -- Ada.Containers.Formal_Hashed_Sets
+ "a-cfhama"); -- Ada.Containers.Formal_Hashed_Maps
-----------------------
-- Alternative Units --
Check_Restriction (No_Elaboration_Code, N);
end Check_Elaboration_Code_Allowed;
+ ------------------------------
+ -- Check_Formal_Restriction --
+ ------------------------------
+
+ procedure Check_Formal_Restriction (Msg : String; N : Node_Id) is
+ begin
+ if Formal_Verification_Mode
+ and then Comes_From_Source (Original_Node (N))
+ then
+ Error_Msg_F ("|~~" & Msg, N);
+ end if;
+ end Check_Formal_Restriction;
+
-----------------------------------------
-- Check_Implicit_Dynamic_Code_Allowed --
-----------------------------------------
-- an elaboration routine. If elaboration code is not allowed, an error
-- message is posted on the node given as argument.
+ procedure Check_Formal_Restriction (Msg : String; N : Node_Id);
+ -- Provides a wrappper on Error_Msg_F which prepends the special characters
+ -- "|~~" (error not serious, language prepended) provided the current mode
+ -- is formal verification and the node N comes originally from source.
+ -- Otherwise, does nothing.
+
procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id);
-- Tests to see if dynamic code generation (dynamically generated
-- trampolines, in particular) is allowed by the current restrictions
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
+with Restrict; use Restrict;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
end if;
-- An unqualified aggregate is restricted in SPARK or ALFA to:
- -- * an 'aggregate item' inside an aggregate for a multi-dimensional
- -- array.
- -- * an expression being assigned to an unconstrained array, but only
- -- if the aggregate specifies a value for OTHERS only.
+
+ -- An aggregate item inside an aggregate for a multi-dimensional array
+
+ -- An expression being assigned to an unconstrained array, but only if
+ -- the aggregate specifies a value for OTHERS only.
if Nkind (Parent (N)) /= N_Qualified_Expression then
if Is_Array_Type (Etype (N)) then
end if;
-- The following check is disabled until a proper place is
- -- found where the type of the parent node can be inspected.
+ -- found where the type of the parent node can be inspected???
-- elsif not (Nkind (Parent (N)) = N_Aggregate
-- and then Is_Array_Type (Etype (Parent (N)))
Check_Formal_Restriction
("record aggregate should be qualified", N);
- -- The type of aggregate is neither array nor record, so an error
- -- must have occurred during resolution. Do not report an
- -- additional message here.
+ -- The type of aggregate is neither array nor record, so an error
+ -- must have occurred during resolution. Do not report an additional
+ -- message here.
+ else
+ null;
end if;
end if;
if Raises_Constraint_Error (N) then
Aggr_Subtyp := Etype (N);
Rewrite (N,
- Make_Raise_Constraint_Error (Loc,
- Reason => CE_Range_Check_Failed));
+ Make_Raise_Constraint_Error (Loc, Reason => CE_Range_Check_Failed));
Set_Raises_Constraint_Error (N);
Set_Etype (N, Aggr_Subtyp);
Set_Analyzed (N);
begin
-- A record aggregate is restricted in SPARK or ALFA:
- -- * each named association can have only a single choice.
- -- * OTHERS cannot be used.
- -- * positional and named associations cannot be mixed.
+ -- Each named association can have only a single choice.
+ -- OTHERS cannot be used.
+ -- Positional and named associations cannot be mixed.
if Present (Component_Associations (N))
and then Present (First (Component_Associations (N)))
declare
Assoc : Node_Id;
+
begin
Assoc := First (Component_Associations (N));
-
while Present (Assoc) loop
if List_Length (Choices (Assoc)) > 1 then
Check_Formal_Restriction
("component association in record aggregate must "
& "contain a single choice", Assoc);
end if;
+
if Nkind (First (Choices (Assoc))) = N_Others_Choice then
Check_Formal_Restriction
("record aggregate cannot contain OTHERS", Assoc);
end if;
+
Assoc := Next (Assoc);
end loop;
end;
else
Check_Private_View (Subtype_Indication (Parent (E)));
end if;
+
Set_Is_Generic_Actual_Type (E, True);
Set_Is_Hidden (E, False);
Set_Is_Potentially_Use_Visible (E,
Set_Is_Hidden (E, False);
end if;
+ if Ekind (E) = E_Constant then
+
+ -- If the type of the actual is a private type declared in the
+ -- enclosing scope of the generic unit, the body of the generic
+ -- sees the full view of the type (because it has to appear in
+ -- the corresponding package body). If the type is private now,
+ -- exchange views to restore the proper visiblity in the instance.
+
+ declare
+ Typ : constant Entity_Id := Base_Type (Etype (E));
+ -- The type of the actual
+
+ Gen_Id : Entity_Id;
+ -- The generic unit
+
+ Parent_Scope : Entity_Id;
+ -- The enclosing scope of the generic unit
+
+ begin
+ if Is_Wrapper_Package (Instance) then
+ Gen_Id :=
+ Generic_Parent
+ (Specification
+ (Unit_Declaration_Node
+ (Related_Instance (Instance))));
+ else
+ Gen_Id :=
+ Generic_Parent
+ (Specification (Unit_Declaration_Node (Instance)));
+ end if;
+
+ Parent_Scope := Scope (Gen_Id);
+
+ -- The exchange is only needed if the generic is defined
+ -- within a package which is not a common ancestor of the
+ -- scope of the instance, and is not already in scope.
+
+ if Is_Private_Type (Typ)
+ and then Scope (Typ) = Parent_Scope
+ and then Scope (Instance) /= Parent_Scope
+ and then Ekind (Parent_Scope) = E_Package
+ and then not Is_Child_Unit (Gen_Id)
+ then
+ Switch_View (Typ);
+
+ -- If the type of the entity is a subtype, it may also
+ -- have to be made visible, together with the base type
+ -- of its full view, after exchange.
+
+ if Is_Private_Type (Etype (E)) then
+ Switch_View (Etype (E));
+ Switch_View (Base_Type (Etype (E)));
+ end if;
+ end if;
+ end;
+ end if;
+
Next_Entity (E);
end loop;
end Check_Generic_Actuals;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
-- SPARK or ALFA.
if Nkind (DS) = N_Range then
- Check_Formal_Restriction ("loop parameter specification "
- & "must include subtype mark", N);
+ Check_Formal_Restriction
+ ("loop parameter specification must include subtype mark",
+ N);
end if;
-- Now analyze the subtype definition. If it is a range, create
with Nlists; use Nlists;
with Output; use Output;
with Opt; use Opt;
+with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
projects / gcc.git / commitdiff