-- --
-- B o d y --
-- --
--- Copyright (C) 2004 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. --
+-- Copyright (C) 2004-2009, 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 2, or (at your option) any later ver- --
+-- 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. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
-- --
--- This unit has originally being developed by Matthew J Heaney. --
+-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Ada.Containers.Hash_Tables.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
-with System; use type System.Address;
-
with Ada.Containers.Prime_Numbers;
-with Ada.Finalization; use Ada.Finalization;
+with System; use type System.Address;
package body Ada.Containers.Indefinite_Hashed_Sets is
- type Element_Access is access Element_Type;
-
- type Node_Type is
- limited record
- Element : Element_Access;
- Next : Node_Access;
- end record;
-
- function Hash_Node
- (Node : Node_Access) return Hash_Type;
- pragma Inline (Hash_Node);
-
- function Hash_Node
- (Node : Node_Access) return Hash_Type is
- begin
- return Hash (Node.Element.all);
- end Hash_Node;
-
- function Next
- (Node : Node_Access) return Node_Access;
- pragma Inline (Next);
-
- function Next
- (Node : Node_Access) return Node_Access is
- begin
- return Node.Next;
- end Next;
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- procedure Set_Next
- (Node : Node_Access;
- Next : Node_Access);
- pragma Inline (Set_Next);
+ procedure Assign (Node : Node_Access; Item : Element_Type);
+ pragma Inline (Assign);
- procedure Set_Next
- (Node : Node_Access;
- Next : Node_Access) is
- begin
- Node.Next := Next;
- end Set_Next;
+ function Copy_Node (Source : Node_Access) return Node_Access;
+ pragma Inline (Copy_Node);
function Equivalent_Keys
(Key : Element_Type;
Node : Node_Access) return Boolean;
pragma Inline (Equivalent_Keys);
- function Equivalent_Keys
- (Key : Element_Type;
- Node : Node_Access) return Boolean is
- begin
- return Equivalent_Keys (Key, Node.Element.all);
- end Equivalent_Keys;
+ function Find_Equal_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean;
- function Copy_Node
- (Source : Node_Access) return Node_Access;
- pragma Inline (Copy_Node);
+ function Find_Equivalent_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean;
+
+ procedure Free (X : in out Node_Access);
- function Copy_Node
- (Source : Node_Access) return Node_Access is
+ function Hash_Node (Node : Node_Access) return Hash_Type;
+ pragma Inline (Hash_Node);
- Target : constant Node_Access :=
- new Node_Type'(Element => Source.Element,
- Next => null);
- begin
- return Target;
- end Copy_Node;
+ procedure Insert
+ (HT : in out Hash_Table_Type;
+ New_Item : Element_Type;
+ Node : out Node_Access;
+ Inserted : out Boolean);
+ function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean;
+ pragma Inline (Is_In);
- procedure Free_Element is
- new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+ function Next (Node : Node_Access) return Node_Access;
+ pragma Inline (Next);
- procedure Free (X : in out Node_Access);
+ function Read_Node (Stream : not null access Root_Stream_Type'Class)
+ return Node_Access;
+ pragma Inline (Read_Node);
- procedure Free (X : in out Node_Access) is
- procedure Deallocate is
- new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
- begin
- if X /= null then
- Free_Element (X.Element);
- Deallocate (X);
- end if;
- end Free;
+ procedure Set_Next (Node : Node_Access; Next : Node_Access);
+ pragma Inline (Set_Next);
- package HT_Ops is
- new Hash_Tables.Generic_Operations
- (HT_Types => HT_Types,
- Hash_Table_Type => Set,
- Null_Node => null,
- Hash_Node => Hash_Node,
- Next => Next,
- Set_Next => Set_Next,
- Copy_Node => Copy_Node,
- Free => Free);
+ function Vet (Position : Cursor) return Boolean;
- package Element_Keys is
- new Hash_Tables.Generic_Keys
- (HT_Types => HT_Types,
- HT_Type => Set,
- Null_Node => null,
- Next => Next,
- Set_Next => Set_Next,
- Key_Type => Element_Type,
- Hash => Hash,
- Equivalent_Keys => Equivalent_Keys);
+ procedure Write_Node
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Access);
+ pragma Inline (Write_Node);
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
- procedure Adjust (Container : in out Set) renames HT_Ops.Adjust;
+ procedure Free_Element is
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+
+ package HT_Ops is new Hash_Tables.Generic_Operations
+ (HT_Types => HT_Types,
+ Hash_Node => Hash_Node,
+ Next => Next,
+ Set_Next => Set_Next,
+ Copy_Node => Copy_Node,
+ Free => Free);
+
+ package Element_Keys is new Hash_Tables.Generic_Keys
+ (HT_Types => HT_Types,
+ Next => Next,
+ Set_Next => Set_Next,
+ Key_Type => Element_Type,
+ Hash => Hash,
+ Equivalent_Keys => Equivalent_Keys);
- procedure Finalize (Container : in out Set) renames HT_Ops.Finalize;
+ function Is_Equal is
+ new HT_Ops.Generic_Equal (Find_Equal_Key);
+ function Is_Equivalent is
+ new HT_Ops.Generic_Equal (Find_Equivalent_Key);
- function Find_Equal_Key
- (R_Set : Set;
- L_Node : Node_Access) return Boolean;
+ procedure Read_Nodes is
+ new HT_Ops.Generic_Read (Read_Node);
- function Find_Equal_Key
- (R_Set : Set;
- L_Node : Node_Access) return Boolean is
+ procedure Replace_Element is
+ new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
- R_Index : constant Hash_Type :=
- Element_Keys.Index (R_Set, L_Node.Element.all);
+ procedure Write_Nodes is
+ new HT_Ops.Generic_Write (Write_Node);
- R_Node : Node_Access := R_Set.Buckets (R_Index);
+ ---------
+ -- "=" --
+ ---------
+ function "=" (Left, Right : Set) return Boolean is
begin
+ return Is_Equal (Left.HT, Right.HT);
+ end "=";
- loop
+ ------------
+ -- Adjust --
+ ------------
- if R_Node = null then
- return False;
- end if;
+ procedure Adjust (Container : in out Set) is
+ begin
+ HT_Ops.Adjust (Container.HT);
+ end Adjust;
- if L_Node.Element.all = R_Node.Element.all then
- return True;
- end if;
+ ------------
+ -- Assign --
+ ------------
- R_Node := Next (R_Node);
+ procedure Assign (Node : Node_Access; Item : Element_Type) is
+ X : Element_Access := Node.Element;
+ begin
+ Node.Element := new Element_Type'(Item);
+ Free_Element (X);
+ end Assign;
- end loop;
+ --------------
+ -- Capacity --
+ --------------
- end Find_Equal_Key;
+ function Capacity (Container : Set) return Count_Type is
+ begin
+ return HT_Ops.Capacity (Container.HT);
+ end Capacity;
- function Is_Equal is
- new HT_Ops.Generic_Equal (Find_Equal_Key);
+ -----------
+ -- Clear --
+ -----------
- function "=" (Left, Right : Set) return Boolean renames Is_Equal;
+ procedure Clear (Container : in out Set) is
+ begin
+ HT_Ops.Clear (Container.HT);
+ end Clear;
+ --------------
+ -- Contains --
+ --------------
- function Length (Container : Set) return Count_Type is
+ function Contains (Container : Set; Item : Element_Type) return Boolean is
begin
- return Container.Length;
- end Length;
+ return Find (Container, Item) /= No_Element;
+ end Contains;
+ ---------------
+ -- Copy_Node --
+ ---------------
- function Is_Empty (Container : Set) return Boolean is
+ function Copy_Node (Source : Node_Access) return Node_Access is
+ E : Element_Access := new Element_Type'(Source.Element.all);
begin
- return Container.Length = 0;
- end Is_Empty;
-
+ return new Node_Type'(Element => E, Next => null);
+ exception
+ when others =>
+ Free_Element (E);
+ raise;
+ end Copy_Node;
- procedure Clear (Container : in out Set) renames HT_Ops.Clear;
+ ------------
+ -- Delete --
+ ------------
+ procedure Delete
+ (Container : in out Set;
+ Item : Element_Type)
+ is
+ X : Node_Access;
- function Element (Position : Cursor) return Element_Type is
begin
- return Position.Node.Element.all;
- end Element;
-
+ Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
- procedure Query_Element
- (Position : in Cursor;
- Process : not null access procedure (Element : in Element_Type)) is
- begin
- Process (Position.Node.Element.all);
- end Query_Element;
+ if X = null then
+ raise Constraint_Error with "attempt to delete element not in set";
+ end if;
+ Free (X);
+ end Delete;
--- TODO:
--- procedure Replace_Element (Container : in out Set;
--- Position : in Node_Access;
--- By : in Element_Type);
+ procedure Delete
+ (Container : in out Set;
+ Position : in out Cursor)
+ is
+ begin
+ if Position.Node = null then
+ raise Constraint_Error with "Position cursor equals No_Element";
+ end if;
--- procedure Replace_Element (Container : in out Set;
--- Position : in Node_Access;
--- By : in Element_Type) is
+ if Position.Node.Element = null then
+ raise Program_Error with "Position cursor is bad";
+ end if;
--- Node : Node_Access := Position;
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with "Position cursor designates wrong set";
+ end if;
--- begin
+ if Container.HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
+ end if;
--- if Equivalent_Keys (Node.Element.all, By) then
+ pragma Assert (Vet (Position), "Position cursor is bad");
--- declare
--- X : Element_Access := Node.Element;
--- begin
--- Node.Element := new Element_Type'(By);
--- --
--- -- NOTE: If there's an exception here, then just
--- -- let it propagate. We haven't modified the
--- -- state of the container, so there's nothing else
--- -- we need to do.
+ HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
--- Free_Element (X);
--- end;
+ Free (Position.Node);
+ Position.Container := null;
+ end Delete;
--- return;
+ ----------------
+ -- Difference --
+ ----------------
--- end if;
+ procedure Difference
+ (Target : in out Set;
+ Source : Set)
+ is
+ Tgt_Node : Node_Access;
--- HT_Ops.Delete_Node_Sans_Free (Container, Node);
+ begin
+ if Target'Address = Source'Address then
+ Clear (Target);
+ return;
+ end if;
--- begin
--- Free_Element (Node.Element);
--- exception
--- when others =>
--- Node.Element := null; -- don't attempt to dealloc X.E again
--- Free (Node);
--- raise;
--- end;
+ if Source.HT.Length = 0 then
+ return;
+ end if;
--- begin
--- Node.Element := new Element_Type'(By);
--- exception
--- when others =>
--- Free (Node);
--- raise;
--- end;
+ if Target.HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
+ end if;
--- declare
--- function New_Node (Next : Node_Access) return Node_Access;
--- pragma Inline (New_Node);
+ if Source.HT.Length < Target.HT.Length then
+ declare
+ Src_Node : Node_Access;
--- function New_Node (Next : Node_Access) return Node_Access is
--- begin
--- Node.Next := Next;
--- return Node;
--- end New_Node;
+ begin
+ Src_Node := HT_Ops.First (Source.HT);
+ while Src_Node /= null loop
+ Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
--- procedure Insert is
--- new Element_Keys.Generic_Conditional_Insert (New_Node);
+ if Tgt_Node /= null then
+ HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
+ Free (Tgt_Node);
+ end if;
--- Result : Node_Access;
--- Success : Boolean;
--- begin
--- Insert
--- (HT => Container,
--- Key => Node.Element.all,
--- Node => Result,
--- Success => Success);
+ Src_Node := HT_Ops.Next (Source.HT, Src_Node);
+ end loop;
+ end;
--- if not Success then
--- Free (Node);
--- raise Program_Error;
--- end if;
+ else
+ Tgt_Node := HT_Ops.First (Target.HT);
+ while Tgt_Node /= null loop
+ if Is_In (Source.HT, Tgt_Node) then
+ declare
+ X : Node_Access := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
+ Free (X);
+ end;
--- pragma Assert (Result = Node);
--- end;
+ else
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+ end if;
+ end loop;
+ end if;
+ end Difference;
--- end Replace_Element;
+ function Difference (Left, Right : Set) return Set is
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
+ begin
+ if Left'Address = Right'Address then
+ return Empty_Set;
+ end if;
--- procedure Replace_Element (Container : in out Set;
--- Position : in Cursor;
--- By : in Element_Type) is
--- begin
+ if Left.Length = 0 then
+ return Empty_Set;
+ end if;
--- if Position.Container = null then
--- raise Constraint_Error;
--- end if;
+ if Right.Length = 0 then
+ return Left;
+ end if;
--- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
--- raise Program_Error;
--- end if;
+ declare
+ Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
+ begin
+ Buckets := HT_Ops.New_Buckets (Length => Size);
+ end;
--- Replace_Element (Container, Position.Node, By);
+ Length := 0;
--- end Replace_Element;
+ Iterate_Left : declare
+ procedure Process (L_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
- procedure Move (Target : in out Set;
- Source : in out Set) renames HT_Ops.Move;
+ -------------
+ -- Process --
+ -------------
+ procedure Process (L_Node : Node_Access) is
+ begin
+ if not Is_In (Right.HT, L_Node) then
+ declare
+ Src : Element_Type renames L_Node.Element.all;
+ Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
+ Bucket : Node_Access renames Buckets (Indx);
+ Tgt : Element_Access := new Element_Type'(Src);
+ begin
+ Bucket := new Node_Type'(Tgt, Bucket);
+ exception
+ when others =>
+ Free_Element (Tgt);
+ raise;
+ end;
- procedure Insert (Container : in out Set;
- New_Item : in Element_Type;
- Position : out Cursor;
- Inserted : out Boolean) is
+ Length := Length + 1;
+ end if;
+ end Process;
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
+ -- Start of processing for Iterate_Left
- function New_Node (Next : Node_Access) return Node_Access is
- Element : Element_Access := new Element_Type'(New_Item);
begin
- return new Node_Type'(Element, Next);
+ Iterate (Left.HT);
exception
when others =>
- Free_Element (Element);
+ HT_Ops.Free_Hash_Table (Buckets);
raise;
- end New_Node;
+ end Iterate_Left;
+
+ return (Controlled with HT => (Buckets, Length, 0, 0));
+ end Difference;
- procedure Insert is
- new Element_Keys.Generic_Conditional_Insert (New_Node);
+ -------------
+ -- Element --
+ -------------
+ function Element (Position : Cursor) return Element_Type is
begin
+ if Position.Node = null then
+ raise Constraint_Error with "Position cursor of equals No_Element";
+ end if;
- HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
- Insert (Container, New_Item, Position.Node, Inserted);
- Position.Container := Container'Unchecked_Access;
-
- end Insert;
+ if Position.Node.Element = null then -- handle dangling reference
+ raise Program_Error with "Position cursor is bad";
+ end if;
+ pragma Assert (Vet (Position), "bad cursor in function Element");
- procedure Insert (Container : in out Set;
- New_Item : in Element_Type) is
+ return Position.Node.Element.all;
+ end Element;
- Position : Cursor;
- Inserted : Boolean;
+ ---------------------
+ -- Equivalent_Sets --
+ ---------------------
+ function Equivalent_Sets (Left, Right : Set) return Boolean is
begin
+ return Is_Equivalent (Left.HT, Right.HT);
+ end Equivalent_Sets;
- Insert (Container, New_Item, Position, Inserted);
+ -------------------------
+ -- Equivalent_Elements --
+ -------------------------
- if not Inserted then
- raise Constraint_Error;
+ function Equivalent_Elements (Left, Right : Cursor)
+ return Boolean is
+ begin
+ if Left.Node = null then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Elements equals No_Element";
end if;
- end Insert;
+ if Right.Node = null then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Elements equals No_Element";
+ end if;
+ if Left.Node.Element = null then
+ raise Program_Error with
+ "Left cursor of Equivalent_Elements is bad";
+ end if;
- procedure Replace (Container : in out Set;
- New_Item : in Element_Type) is
+ if Right.Node.Element = null then
+ raise Program_Error with
+ "Right cursor of Equivalent_Elements is bad";
+ end if;
- Node : constant Node_Access :=
- Element_Keys.Find (Container, New_Item);
+ pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
+ pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
- X : Element_Access;
+ return Equivalent_Elements
+ (Left.Node.Element.all,
+ Right.Node.Element.all);
+ end Equivalent_Elements;
+ function Equivalent_Elements (Left : Cursor; Right : Element_Type)
+ return Boolean is
begin
-
- if Node = null then
- raise Constraint_Error;
+ if Left.Node = null then
+ raise Constraint_Error with
+ "Left cursor of Equivalent_Elements equals No_Element";
end if;
- X := Node.Element;
+ if Left.Node.Element = null then
+ raise Program_Error with
+ "Left cursor of Equivalent_Elements is bad";
+ end if;
- Node.Element := new Element_Type'(New_Item);
+ pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
- Free_Element (X);
+ return Equivalent_Elements (Left.Node.Element.all, Right);
+ end Equivalent_Elements;
- end Replace;
+ function Equivalent_Elements (Left : Element_Type; Right : Cursor)
+ return Boolean is
+ begin
+ if Right.Node = null then
+ raise Constraint_Error with
+ "Right cursor of Equivalent_Elements equals No_Element";
+ end if;
+ if Right.Node.Element = null then
+ raise Program_Error with
+ "Right cursor of Equivalent_Elements is bad";
+ end if;
- procedure Include (Container : in out Set;
- New_Item : in Element_Type) is
+ pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
- Position : Cursor;
- Inserted : Boolean;
+ return Equivalent_Elements (Left, Right.Node.Element.all);
+ end Equivalent_Elements;
- X : Element_Access;
+ ---------------------
+ -- Equivalent_Keys --
+ ---------------------
+ function Equivalent_Keys (Key : Element_Type; Node : Node_Access)
+ return Boolean is
begin
+ return Equivalent_Elements (Key, Node.Element.all);
+ end Equivalent_Keys;
- Insert (Container, New_Item, Position, Inserted);
+ -------------
+ -- Exclude --
+ -------------
- if not Inserted then
+ procedure Exclude
+ (Container : in out Set;
+ Item : Element_Type)
+ is
+ X : Node_Access;
+ begin
+ Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
+ Free (X);
+ end Exclude;
- X := Position.Node.Element;
+ --------------
+ -- Finalize --
+ --------------
- Position.Node.Element := new Element_Type'(New_Item);
+ procedure Finalize (Container : in out Set) is
+ begin
+ HT_Ops.Finalize (Container.HT);
+ end Finalize;
- Free_Element (X);
+ ----------
+ -- Find --
+ ----------
+ function Find
+ (Container : Set;
+ Item : Element_Type) return Cursor
+ is
+ Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
+
+ begin
+ if Node = null then
+ return No_Element;
end if;
- end Include;
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
+ --------------------
+ -- Find_Equal_Key --
+ --------------------
- procedure Delete (Container : in out Set;
- Item : in Element_Type) is
+ function Find_Equal_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean
+ is
+ R_Index : constant Hash_Type :=
+ Element_Keys.Index (R_HT, L_Node.Element.all);
- X : Node_Access;
+ R_Node : Node_Access := R_HT.Buckets (R_Index);
begin
+ loop
+ if R_Node = null then
+ return False;
+ end if;
- Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
-
- if X = null then
- raise Constraint_Error;
- end if;
-
- Free (X);
+ if L_Node.Element.all = R_Node.Element.all then
+ return True;
+ end if;
- end Delete;
+ R_Node := Next (R_Node);
+ end loop;
+ end Find_Equal_Key;
+ -------------------------
+ -- Find_Equivalent_Key --
+ -------------------------
- procedure Exclude (Container : in out Set;
- Item : in Element_Type) is
+ function Find_Equivalent_Key
+ (R_HT : Hash_Table_Type;
+ L_Node : Node_Access) return Boolean
+ is
+ R_Index : constant Hash_Type :=
+ Element_Keys.Index (R_HT, L_Node.Element.all);
- X : Node_Access;
+ R_Node : Node_Access := R_HT.Buckets (R_Index);
begin
+ loop
+ if R_Node = null then
+ return False;
+ end if;
+
+ if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
+ return True;
+ end if;
+
+ R_Node := Next (R_Node);
+ end loop;
+ end Find_Equivalent_Key;
- Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
- Free (X);
-
- end Exclude;
-
+ -----------
+ -- First --
+ -----------
+
+ function First (Container : Set) return Cursor is
+ Node : constant Node_Access := HT_Ops.First (Container.HT);
- procedure Delete (Container : in out Set;
- Position : in out Cursor) is
begin
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end First;
- if Position = No_Element then
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Node_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
+
+ begin
+ if X = null then
return;
end if;
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
- raise Program_Error;
- end if;
+ X.Next := X; -- detect mischief (in Vet)
- HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
- Free (Position.Node);
+ begin
+ Free_Element (X.Element);
+ exception
+ when others =>
+ X.Element := null;
+ Deallocate (X);
+ raise;
+ end;
- Position.Container := null;
+ Deallocate (X);
+ end Free;
- end Delete;
+ -----------------
+ -- Has_Element --
+ -----------------
+ function Has_Element (Position : Cursor) return Boolean is
+ begin
+ pragma Assert (Vet (Position), "bad cursor in Has_Element");
+ return Position.Node /= null;
+ end Has_Element;
+ ---------------
+ -- Hash_Node --
+ ---------------
- procedure Union (Target : in out Set;
- Source : in Set) is
+ function Hash_Node (Node : Node_Access) return Hash_Type is
+ begin
+ return Hash (Node.Element.all);
+ end Hash_Node;
- procedure Process (Src_Node : in Node_Access);
+ -------------
+ -- Include --
+ -------------
- procedure Process (Src_Node : in Node_Access) is
+ procedure Include
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ Inserted : Boolean;
- Src : Element_Type renames Src_Node.Element.all;
+ X : Element_Access;
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
+ begin
+ Insert (Container, New_Item, Position, Inserted);
- function New_Node (Next : Node_Access) return Node_Access is
- Tgt : Element_Access := new Element_Type'(Src);
- begin
- return new Node_Type'(Tgt, Next);
- exception
- when others =>
- Free_Element (Tgt);
- raise;
- end New_Node;
+ if not Inserted then
+ if Container.HT.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
+ end if;
- procedure Insert is
- new Element_Keys.Generic_Conditional_Insert (New_Node);
+ X := Position.Node.Element;
- Tgt_Node : Node_Access;
- Success : Boolean;
+ Position.Node.Element := new Element_Type'(New_Item);
- begin
+ Free_Element (X);
+ end if;
+ end Include;
- Insert (Target, Src, Tgt_Node, Success);
+ ------------
+ -- Insert --
+ ------------
- end Process;
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type;
+ Position : out Cursor;
+ Inserted : out Boolean)
+ is
+ begin
+ Insert (Container.HT, New_Item, Position.Node, Inserted);
+ Position.Container := Container'Unchecked_Access;
+ end Insert;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ procedure Insert
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Position : Cursor;
+ pragma Unreferenced (Position);
+
+ Inserted : Boolean;
begin
+ Insert (Container, New_Item, Position, Inserted);
- if Target'Address = Source'Address then
- return;
+ if not Inserted then
+ raise Constraint_Error with
+ "attempt to insert element already in set";
end if;
+ end Insert;
+
+ procedure Insert
+ (HT : in out Hash_Table_Type;
+ New_Item : Element_Type;
+ Node : out Node_Access;
+ Inserted : out Boolean)
+ is
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
- HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
+ procedure Local_Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
- Iterate (Source);
+ --------------
+ -- New_Node --
+ --------------
- end Union;
+ function New_Node (Next : Node_Access) return Node_Access is
+ Element : Element_Access := new Element_Type'(New_Item);
+
+ begin
+ return new Node_Type'(Element, Next);
+ exception
+ when others =>
+ Free_Element (Element);
+ raise;
+ end New_Node;
+ -- Start of processing for Insert
+ begin
+ if HT_Ops.Capacity (HT) = 0 then
+ HT_Ops.Reserve_Capacity (HT, 1);
+ end if;
- function Union (Left, Right : Set) return Set is
+ Local_Insert (HT, New_Item, Node, Inserted);
+ if Inserted
+ and then HT.Length > HT_Ops.Capacity (HT)
+ then
+ HT_Ops.Reserve_Capacity (HT, HT.Length);
+ end if;
+ end Insert;
+
+ ------------------
+ -- Intersection --
+ ------------------
+
+ procedure Intersection
+ (Target : in out Set;
+ Source : Set)
+ is
+ Tgt_Node : Node_Access;
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ if Source.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);
+ while Tgt_Node /= null loop
+ if Is_In (Source.HT, Tgt_Node) then
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+
+ else
+ declare
+ X : Node_Access := Tgt_Node;
+ begin
+ Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
+ HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
+ Free (X);
+ end;
+ end if;
+ end loop;
+ end Intersection;
+
+ function Intersection (Left, Right : Set) return Set is
Buckets : HT_Types.Buckets_Access;
Length : Count_Type;
begin
-
if Left'Address = Right'Address then
return Left;
end if;
- if Right.Length = 0 then
- return Left;
- end if;
+ Length := Count_Type'Min (Left.Length, Right.Length);
- if Left.Length = 0 then
- return Right;
+ if Length = 0 then
+ return Empty_Set;
end if;
declare
- Size : constant Hash_Type :=
- Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
+ Buckets := HT_Ops.New_Buckets (Length => Size);
end;
- declare
- procedure Process (L_Node : Node_Access);
+ Length := 0;
- procedure Process (L_Node : Node_Access) is
- I : constant Hash_Type :=
- Hash (L_Node.Element.all) mod Buckets'Length;
- begin
- Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
- end Process;
+ Iterate_Left : declare
+ procedure Process (L_Node : Node_Access);
procedure Iterate is
new HT_Ops.Generic_Iteration (Process);
- begin
- Iterate (Left);
- exception
- when others =>
- HT_Ops.Free_Hash_Table (Buckets);
- raise;
- end;
- Length := Left.Length;
-
- declare
- procedure Process (Src_Node : Node_Access);
-
- procedure Process (Src_Node : Node_Access) is
-
- Src : Element_Type renames Src_Node.Element.all;
-
- I : constant Hash_Type :=
- Hash (Src) mod Buckets'Length;
-
- Tgt_Node : Node_Access := Buckets (I);
+ -------------
+ -- Process --
+ -------------
+ procedure Process (L_Node : Node_Access) is
begin
+ if Is_In (Right.HT, L_Node) then
+ declare
+ Src : Element_Type renames L_Node.Element.all;
- while Tgt_Node /= null loop
+ Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
- if Equivalent_Keys (Src, Tgt_Node.Element.all) then
- return;
- end if;
-
- Tgt_Node := Next (Tgt_Node);
+ Bucket : Node_Access renames Buckets (Indx);
- end loop;
+ Tgt : Element_Access := new Element_Type'(Src);
- declare
- Tgt : Element_Access := new Element_Type'(Src);
- begin
- Buckets (I) := new Node_Type'(Tgt, Buckets (I));
- exception
- when others =>
- Free_Element (Tgt);
- raise;
- end;
-
- Length := Length + 1;
+ begin
+ Bucket := new Node_Type'(Tgt, Bucket);
+ exception
+ when others =>
+ Free_Element (Tgt);
+ raise;
+ end;
+ Length := Length + 1;
+ end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ -- Start of processing for Iterate_Left
+
begin
- Iterate (Right);
+ Iterate (Left.HT);
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
raise;
- end;
+ end Iterate_Left;
- return (Controlled with Buckets, Length);
+ return (Controlled with HT => (Buckets, Length, 0, 0));
+ end Intersection;
- end Union;
+ --------------
+ -- Is_Empty --
+ --------------
+ function Is_Empty (Container : Set) return Boolean is
+ begin
+ return Container.HT.Length = 0;
+ end Is_Empty;
- function Is_In
- (HT : Set;
- Key : Node_Access) return Boolean;
- pragma Inline (Is_In);
+ -----------
+ -- Is_In --
+ -----------
- function Is_In
- (HT : Set;
- Key : Node_Access) return Boolean is
+ function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
begin
return Element_Keys.Find (HT, Key.Element.all) /= null;
end Is_In;
+ ---------------
+ -- Is_Subset --
+ ---------------
- procedure Intersection (Target : in out Set;
- Source : in Set) is
-
- Tgt_Node : Node_Access;
+ function Is_Subset
+ (Subset : Set;
+ Of_Set : Set) return Boolean
+ is
+ Subset_Node : Node_Access;
begin
-
- if Target'Address = Source'Address then
- return;
+ if Subset'Address = Of_Set'Address then
+ return True;
end if;
- if Source.Length = 0 then
- Clear (Target);
- return;
+ if Subset.Length > Of_Set.Length then
+ return False;
end if;
- -- TODO: optimize this to use an explicit
- -- loop instead of an active iterator
- -- (similar to how a passive iterator is
- -- implemented).
- --
- -- Another possibility is to test which
- -- set is smaller, and iterate over the
- -- smaller set.
-
- Tgt_Node := HT_Ops.First (Target);
+ Subset_Node := HT_Ops.First (Subset.HT);
+ while Subset_Node /= null loop
+ if not Is_In (Of_Set.HT, Subset_Node) then
+ return False;
+ end if;
- while Tgt_Node /= null loop
+ Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
+ end loop;
- if Is_In (Source, Tgt_Node) then
+ return True;
+ end Is_Subset;
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ -------------
+ -- Iterate --
+ -------------
- else
+ procedure Iterate
+ (Container : Set;
+ Process : not null access procedure (Position : Cursor))
+ is
+ procedure Process_Node (Node : Node_Access);
+ pragma Inline (Process_Node);
- declare
- X : Node_Access := Tgt_Node;
- begin
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target, X);
- Free (X);
- end;
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process_Node);
- end if;
+ ------------------
+ -- Process_Node --
+ ------------------
- end loop;
+ procedure Process_Node (Node : Node_Access) is
+ begin
+ Process (Cursor'(Container'Unrestricted_Access, Node));
+ end Process_Node;
- end Intersection;
+ B : Natural renames Container'Unrestricted_Access.HT.Busy;
+ -- Start of processing for Iterate
- function Intersection (Left, Right : Set) return Set is
+ begin
+ B := B + 1;
- Buckets : HT_Types.Buckets_Access;
- Length : Count_Type;
+ begin
+ Iterate (Container.HT);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
- begin
+ B := B - 1;
+ end Iterate;
- if Left'Address = Right'Address then
- return Left;
- end if;
+ ------------
+ -- Length --
+ ------------
- Length := Count_Type'Min (Left.Length, Right.Length);
+ function Length (Container : Set) return Count_Type is
+ begin
+ return Container.HT.Length;
+ end Length;
- if Length = 0 then
- return Empty_Set;
- end if;
+ ----------
+ -- Move --
+ ----------
- declare
- Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
- begin
- Buckets := new Buckets_Type (0 .. Size - 1);
- end;
+ procedure Move (Target : in out Set; Source : in out Set) is
+ begin
+ HT_Ops.Move (Target => Target.HT, Source => Source.HT);
+ end Move;
- Length := 0;
+ ----------
+ -- Next --
+ ----------
- declare
- procedure Process (L_Node : Node_Access);
+ function Next (Node : Node_Access) return Node_Access is
+ begin
+ return Node.Next;
+ end Next;
- procedure Process (L_Node : Node_Access) is
- begin
- if Is_In (Right, L_Node) then
+ function Next (Position : Cursor) return Cursor is
+ begin
+ if Position.Node = null then
+ return No_Element;
+ end if;
- declare
- I : constant Hash_Type :=
- Hash (L_Node.Element.all) mod Buckets'Length;
- begin
- Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
- end;
+ if Position.Node.Element = null then
+ raise Program_Error with "bad cursor in Next";
+ end if;
- Length := Length + 1;
+ pragma Assert (Vet (Position), "bad cursor in Next");
- end if;
- end Process;
+ declare
+ HT : Hash_Table_Type renames Position.Container.HT;
+ Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
begin
- Iterate (Left);
- exception
- when others =>
- HT_Ops.Free_Hash_Table (Buckets);
- raise;
+ if Node = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Position.Container, Node);
end;
+ end Next;
- return (Controlled with Buckets, Length);
+ procedure Next (Position : in out Cursor) is
+ begin
+ Position := Next (Position);
+ end Next;
- end Intersection;
+ -------------
+ -- Overlap --
+ -------------
+ function Overlap (Left, Right : Set) return Boolean is
+ Left_Node : Node_Access;
- procedure Difference (Target : in out Set;
- Source : in Set) is
+ begin
+ if Right.Length = 0 then
+ return False;
+ end if;
+ if Left'Address = Right'Address then
+ return True;
+ end if;
- Tgt_Node : Node_Access;
+ Left_Node := HT_Ops.First (Left.HT);
+ while Left_Node /= null loop
+ if Is_In (Right.HT, Left_Node) then
+ return True;
+ end if;
- begin
+ Left_Node := HT_Ops.Next (Left.HT, Left_Node);
+ end loop;
- if Target'Address = Source'Address then
- Clear (Target);
- return;
- end if;
+ return False;
+ end Overlap;
- if Source.Length = 0 then
- return;
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Position : Cursor;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ begin
+ if Position.Node = null then
+ raise Constraint_Error with
+ "Position cursor of Query_Element equals No_Element";
end if;
- -- TODO: As I noted above, this can be
- -- written in terms of a loop instead as
- -- active-iterator style, sort of like a
- -- passive iterator.
+ if Position.Node.Element = null then
+ raise Program_Error with "bad cursor in Query_Element";
+ end if;
- Tgt_Node := HT_Ops.First (Target);
+ pragma Assert (Vet (Position), "bad cursor in Query_Element");
- while Tgt_Node /= null loop
+ declare
+ HT : Hash_Table_Type renames
+ Position.Container'Unrestricted_Access.all.HT;
- if Is_In (Source, Tgt_Node) then
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
- declare
- X : Node_Access := Tgt_Node;
- begin
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
- HT_Ops.Delete_Node_Sans_Free (Target, X);
- Free (X);
- end;
+ begin
+ B := B + 1;
+ L := L + 1;
- else
+ begin
+ Process (Position.Node.Element.all);
+ exception
+ when others =>
+ L := L - 1;
+ B := B - 1;
+ raise;
+ end;
- Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
+ L := L - 1;
+ B := B - 1;
+ end;
+ end Query_Element;
- end if;
+ ----------
+ -- Read --
+ ----------
- end loop;
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : out Set)
+ is
+ begin
+ Read_Nodes (Stream, Container.HT);
+ end Read;
- end Difference;
+ 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;
+ ---------------
+ -- Read_Node --
+ ---------------
+ function Read_Node
+ (Stream : not null access Root_Stream_Type'Class) return Node_Access
+ is
+ X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
- function Difference (Left, Right : Set) return Set is
+ begin
+ return new Node_Type'(X, null);
+ exception
+ when others =>
+ Free_Element (X);
+ raise;
+ end Read_Node;
- Buckets : HT_Types.Buckets_Access;
- Length : Count_Type;
+ -------------
+ -- Replace --
+ -------------
- begin
+ procedure Replace
+ (Container : in out Set;
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access :=
+ Element_Keys.Find (Container.HT, New_Item);
- if Left'Address = Right'Address then
- return Empty_Set;
- end if;
+ X : Element_Access;
+ pragma Warnings (Off, X);
- if Left.Length = 0 then
- return Empty_Set;
+ begin
+ if Node = null then
+ raise Constraint_Error with
+ "attempt to replace element not in set";
end if;
- if Right.Length = 0 then
- return Left;
+ if Container.HT.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with cursors (set is locked)";
end if;
- declare
- Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
- begin
- Buckets := new Buckets_Type (0 .. Size - 1);
- end;
+ X := Node.Element;
- Length := 0;
+ Node.Element := new Element_Type'(New_Item);
- declare
- procedure Process (L_Node : Node_Access);
+ Free_Element (X);
+ end Replace;
- procedure Process (L_Node : Node_Access) is
- begin
- if not Is_In (Right, L_Node) then
+ ---------------------
+ -- Replace_Element --
+ ---------------------
- declare
- I : constant Hash_Type :=
- Hash (L_Node.Element.all) mod Buckets'Length;
- begin
- Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
- end;
+ procedure Replace_Element
+ (Container : in out Set;
+ Position : Cursor;
+ New_Item : Element_Type)
+ is
+ begin
+ if Position.Node = null then
+ raise Constraint_Error with "Position cursor equals No_Element";
+ end if;
- Length := Length + 1;
+ if Position.Node.Element = null then
+ raise Program_Error with "bad cursor in Replace_Element";
+ end if;
- end if;
- end Process;
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor designates wrong set";
+ end if;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
- begin
- Iterate (Left);
- exception
- when others =>
- HT_Ops.Free_Hash_Table (Buckets);
- raise;
- end;
+ pragma Assert (Vet (Position), "bad cursor in Replace_Element");
- return (Controlled with Buckets, Length);
+ Replace_Element (Container.HT, Position.Node, New_Item);
+ end Replace_Element;
- end Difference;
+ ----------------------
+ -- Reserve_Capacity --
+ ----------------------
+ procedure Reserve_Capacity
+ (Container : in out Set;
+ Capacity : Count_Type)
+ is
+ begin
+ HT_Ops.Reserve_Capacity (Container.HT, Capacity);
+ end Reserve_Capacity;
+ --------------
+ -- Set_Next --
+ --------------
- procedure Symmetric_Difference (Target : in out Set;
- Source : in Set) is
+ procedure Set_Next (Node : Node_Access; Next : Node_Access) is
begin
+ Node.Next := Next;
+ end Set_Next;
+ --------------------------
+ -- Symmetric_Difference --
+ --------------------------
+
+ procedure Symmetric_Difference
+ (Target : in out Set;
+ Source : Set)
+ is
+ begin
if Target'Address = Source'Address then
Clear (Target);
return;
end if;
- HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
+ if Target.HT.Busy > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (set is busy)";
+ end if;
- if Target.Length = 0 then
+ declare
+ N : constant Count_Type := Target.Length + Source.Length;
+ begin
+ if N > HT_Ops.Capacity (Target.HT) then
+ HT_Ops.Reserve_Capacity (Target.HT, N);
+ end if;
+ end;
- declare
+ if Target.Length = 0 then
+ Iterate_Source_When_Empty_Target : declare
procedure Process (Src_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (Src_Node : Node_Access) is
E : Element_Type renames Src_Node.Element.all;
- B : Buckets_Type renames Target.Buckets.all;
- I : constant Hash_Type := Hash (E) mod B'Length;
- N : Count_Type renames Target.Length;
+ B : Buckets_Type renames Target.HT.Buckets.all;
+ J : constant Hash_Type := Hash (E) mod B'Length;
+ N : Count_Type renames Target.HT.Length;
+
begin
declare
X : Element_Access := new Element_Type'(E);
begin
- B (I) := new Node_Type'(X, B (I));
+ B (J) := new Node_Type'(X, B (J));
exception
when others =>
Free_Element (X);
N := N + 1;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ -- Start of processing for Iterate_Source_When_Empty_Target
+
begin
- Iterate (Source);
- end;
+ Iterate (Source.HT);
+ end Iterate_Source_When_Empty_Target;
else
-
- declare
+ Iterate_Source : declare
procedure Process (Src_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (Src_Node : Node_Access) is
E : Element_Type renames Src_Node.Element.all;
- B : Buckets_Type renames Target.Buckets.all;
- I : constant Hash_Type := Hash (E) mod B'Length;
- N : Count_Type renames Target.Length;
- begin
- if B (I) = null then
+ B : Buckets_Type renames Target.HT.Buckets.all;
+ J : constant Hash_Type := Hash (E) mod B'Length;
+ N : Count_Type renames Target.HT.Length;
+ begin
+ if B (J) = null then
declare
X : Element_Access := new Element_Type'(E);
begin
- B (I) := new Node_Type'(X, null);
+ B (J) := new Node_Type'(X, null);
exception
when others =>
Free_Element (X);
N := N + 1;
- elsif Equivalent_Keys (E, B (I).Element.all) then
-
+ elsif Equivalent_Elements (E, B (J).Element.all) then
declare
- X : Node_Access := B (I);
+ X : Node_Access := B (J);
begin
- B (I) := B (I).Next;
+ B (J) := B (J).Next;
N := N - 1;
Free (X);
end;
else
-
declare
- Prev : Node_Access := B (I);
+ Prev : Node_Access := B (J);
Curr : Node_Access := Prev.Next;
+
begin
while Curr /= null loop
- if Equivalent_Keys (E, Curr.Element.all) then
+ if Equivalent_Elements (E, Curr.Element.all) then
Prev.Next := Curr.Next;
N := N - 1;
Free (Curr);
declare
X : Element_Access := new Element_Type'(E);
begin
- B (I) := new Node_Type'(X, B (I));
+ B (J) := new Node_Type'(X, B (J));
exception
when others =>
Free_Element (X);
N := N + 1;
end;
-
end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
- begin
- Iterate (Source);
- end;
+ -- Start of processing for Iterate_Source
+ begin
+ Iterate (Source.HT);
+ end Iterate_Source;
end if;
-
end Symmetric_Difference;
-
function Symmetric_Difference (Left, Right : Set) return Set is
-
Buckets : HT_Types.Buckets_Access;
Length : Count_Type;
begin
-
if Left'Address = Right'Address then
return Empty_Set;
end if;
declare
Size : constant Hash_Type :=
- Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ Prime_Numbers.To_Prime (Left.Length + Right.Length);
begin
- Buckets := new Buckets_Type (0 .. Size - 1);
+ Buckets := HT_Ops.New_Buckets (Length => Size);
end;
Length := 0;
- declare
+ Iterate_Left : declare
procedure Process (L_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (L_Node : Node_Access) is
begin
- if not Is_In (Right, L_Node) then
+ if not Is_In (Right.HT, L_Node) then
declare
E : Element_Type renames L_Node.Element.all;
- I : constant Hash_Type := Hash (E) mod Buckets'Length;
- begin
+ J : constant Hash_Type := Hash (E) mod Buckets'Length;
+ begin
declare
X : Element_Access := new Element_Type'(E);
begin
- Buckets (I) := new Node_Type'(X, Buckets (I));
+ Buckets (J) := new Node_Type'(X, Buckets (J));
exception
when others =>
Free_Element (X);
end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ -- Start of processing for Iterate_Left
+
begin
- Iterate (Left);
+ Iterate (Left.HT);
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
raise;
- end;
+ end Iterate_Left;
- declare
+ Iterate_Right : declare
procedure Process (R_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+
+ -------------
+ -- Process --
+ -------------
+
procedure Process (R_Node : Node_Access) is
begin
- if not Is_In (Left, R_Node) then
+ if not Is_In (Left.HT, R_Node) then
declare
E : Element_Type renames R_Node.Element.all;
- I : constant Hash_Type := Hash (E) mod Buckets'Length;
- begin
+ J : constant Hash_Type := Hash (E) mod Buckets'Length;
+ begin
declare
X : Element_Access := new Element_Type'(E);
begin
- Buckets (I) := new Node_Type'(X, Buckets (I));
+ Buckets (J) := new Node_Type'(X, Buckets (J));
exception
when others =>
Free_Element (X);
end;
Length := Length + 1;
-
end;
end if;
end Process;
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process);
+ -- Start of processing for Iterate_Right
+
begin
- Iterate (Right);
+ Iterate (Right.HT);
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
raise;
- end;
-
- return (Controlled with Buckets, Length);
+ end Iterate_Right;
+ return (Controlled with HT => (Buckets, Length, 0, 0));
end Symmetric_Difference;
+ ------------
+ -- To_Set --
+ ------------
- function Is_Subset (Subset : Set;
- Of_Set : Set) return Boolean is
+ function To_Set (New_Item : Element_Type) return Set is
+ HT : Hash_Table_Type;
- Subset_Node : Node_Access;
+ Node : Node_Access;
+ Inserted : Boolean;
+ pragma Unreferenced (Node, Inserted);
begin
+ Insert (HT, New_Item, Node, Inserted);
+ return Set'(Controlled with HT);
+ end To_Set;
- if Subset'Address = Of_Set'Address then
- return True;
- end if;
+ -----------
+ -- Union --
+ -----------
- if Subset.Length > Of_Set.Length then
- return False;
- end if;
+ procedure Union
+ (Target : in out Set;
+ Source : Set)
+ is
+ procedure Process (Src_Node : Node_Access);
- -- TODO: rewrite this to loop in the
- -- style of a passive iterator.
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
- Subset_Node := HT_Ops.First (Subset);
+ -------------
+ -- Process --
+ -------------
- while Subset_Node /= null loop
- if not Is_In (Of_Set, Subset_Node) then
- return False;
- end if;
+ procedure Process (Src_Node : Node_Access) is
+ Src : Element_Type renames Src_Node.Element.all;
- Subset_Node := HT_Ops.Next (Subset, Subset_Node);
- end loop;
+ function New_Node (Next : Node_Access) return Node_Access;
+ pragma Inline (New_Node);
- return True;
+ procedure Insert is
+ new Element_Keys.Generic_Conditional_Insert (New_Node);
- end Is_Subset;
+ --------------
+ -- New_Node --
+ --------------
+ function New_Node (Next : Node_Access) return Node_Access is
+ Tgt : Element_Access := new Element_Type'(Src);
- function Overlap (Left, Right : Set) return Boolean is
+ begin
+ return new Node_Type'(Tgt, Next);
+ exception
+ when others =>
+ Free_Element (Tgt);
+ raise;
+ end New_Node;
- Left_Node : Node_Access;
+ Tgt_Node : Node_Access;
+ Success : Boolean;
+ pragma Unreferenced (Tgt_Node, Success);
+
+ -- Start of processing for Process
+
+ begin
+ Insert (Target.HT, Src, Tgt_Node, Success);
+ end Process;
+
+ -- Start of processing for Union
+
+ begin
+ 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;
+
+ declare
+ N : constant Count_Type := Target.Length + Source.Length;
+ begin
+ if N > HT_Ops.Capacity (Target.HT) then
+ HT_Ops.Reserve_Capacity (Target.HT, N);
+ end if;
+ end;
+
+ Iterate (Source.HT);
+ end Union;
+
+ function Union (Left, Right : Set) return Set is
+ Buckets : HT_Types.Buckets_Access;
+ Length : Count_Type;
begin
+ if Left'Address = Right'Address then
+ return Left;
+ end if;
if Right.Length = 0 then
- return False;
+ return Left;
end if;
- if Left'Address = Right'Address then
- return True;
+ if Left.Length = 0 then
+ return Right;
end if;
- Left_Node := HT_Ops.First (Left);
-
- while Left_Node /= null loop
- if Is_In (Right, Left_Node) then
- return True;
- end if;
+ declare
+ Size : constant Hash_Type :=
+ Prime_Numbers.To_Prime (Left.Length + Right.Length);
+ begin
+ Buckets := HT_Ops.New_Buckets (Length => Size);
+ end;
- Left_Node := HT_Ops.Next (Left, Left_Node);
- end loop;
+ Iterate_Left : declare
+ procedure Process (L_Node : Node_Access);
- return False;
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
- end Overlap;
+ -------------
+ -- Process --
+ -------------
+ procedure Process (L_Node : Node_Access) is
+ Src : Element_Type renames L_Node.Element.all;
- function Find (Container : Set;
- Item : Element_Type) return Cursor is
+ J : constant Hash_Type := Hash (Src) mod Buckets'Length;
- Node : constant Node_Access := Element_Keys.Find (Container, Item);
+ Bucket : Node_Access renames Buckets (J);
- begin
+ Tgt : Element_Access := new Element_Type'(Src);
- if Node = null then
- return No_Element;
- end if;
+ begin
+ Bucket := new Node_Type'(Tgt, Bucket);
+ exception
+ when others =>
+ Free_Element (Tgt);
+ raise;
+ end Process;
- return Cursor'(Container'Unchecked_Access, Node);
+ -- Start of processing for Process
- end Find;
+ begin
+ Iterate (Left.HT);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end Iterate_Left;
+ Length := Left.Length;
- function Contains (Container : Set;
- Item : Element_Type) return Boolean is
- begin
- return Find (Container, Item) /= No_Element;
- end Contains;
+ Iterate_Right : declare
+ procedure Process (Src_Node : Node_Access);
+ procedure Iterate is
+ new HT_Ops.Generic_Iteration (Process);
+ -------------
+ -- Process --
+ -------------
- function First (Container : Set) return Cursor is
- Node : constant Node_Access := HT_Ops.First (Container);
- begin
- if Node = null then
- return No_Element;
- end if;
+ procedure Process (Src_Node : Node_Access) is
+ Src : Element_Type renames Src_Node.Element.all;
+ Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
- return Cursor'(Container'Unchecked_Access, Node);
- end First;
+ Tgt_Node : Node_Access := Buckets (Idx);
+ begin
+ while Tgt_Node /= null loop
+ if Equivalent_Elements (Src, Tgt_Node.Element.all) then
+ return;
+ end if;
+ Tgt_Node := Next (Tgt_Node);
+ end loop;
--- function First_Element (Container : Set) return Element_Type is
--- Node : constant Node_Access := HT_Ops.First (Container);
--- begin
--- return Node.Element;
--- end First_Element;
+ declare
+ Tgt : Element_Access := new Element_Type'(Src);
+ begin
+ Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx));
+ exception
+ when others =>
+ Free_Element (Tgt);
+ raise;
+ end;
+ Length := Length + 1;
+ end Process;
- function Next (Position : Cursor) return Cursor is
- begin
- if Position.Container = null
- or else Position.Node = null
- then
- return No_Element;
- end if;
+ -- Start of processing for Iterate_Right
- declare
- S : Set renames Position.Container.all;
- Node : constant Node_Access := HT_Ops.Next (S, Position.Node);
begin
- if Node = null then
- return No_Element;
- end if;
+ Iterate (Right.HT);
+ exception
+ when others =>
+ HT_Ops.Free_Hash_Table (Buckets);
+ raise;
+ end Iterate_Right;
- return Cursor'(Position.Container, Node);
- end;
- end Next;
+ return (Controlled with HT => (Buckets, Length, 0, 0));
+ end Union;
+ ---------
+ -- Vet --
+ ---------
- procedure Next (Position : in out Cursor) is
+ function Vet (Position : Cursor) return Boolean is
begin
- Position := Next (Position);
- end Next;
-
+ if Position.Node = null then
+ return Position.Container = null;
+ end if;
- function Has_Element (Position : Cursor) return Boolean is
- begin
if Position.Container = null then
return False;
end if;
- if Position.Node = null then
+ if Position.Node.Next = Position.Node then
return False;
end if;
- return True;
- end Has_Element;
+ if Position.Node.Element = null then
+ return False;
+ end if;
+ declare
+ HT : Hash_Table_Type renames Position.Container.HT;
+ X : Node_Access;
- function Equivalent_Keys (Left, Right : Cursor)
- return Boolean is
- begin
- return Equivalent_Keys (Left.Node.Element.all, Right.Node.Element.all);
- end Equivalent_Keys;
+ begin
+ if HT.Length = 0 then
+ return False;
+ end if;
+ if HT.Buckets = null
+ or else HT.Buckets'Length = 0
+ then
+ return False;
+ end if;
- function Equivalent_Keys (Left : Cursor;
- Right : Element_Type)
- return Boolean is
- begin
- return Equivalent_Keys (Left.Node.Element.all, Right);
- end Equivalent_Keys;
+ X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
+ for J in 1 .. HT.Length loop
+ if X = Position.Node then
+ return True;
+ end if;
- function Equivalent_Keys (Left : Element_Type;
- Right : Cursor)
- return Boolean is
- begin
- return Equivalent_Keys (Left, Right.Node.Element.all);
- end Equivalent_Keys;
+ if X = null then
+ return False;
+ end if;
+ if X = X.Next then -- to prevent unnecessary looping
+ return False;
+ end if;
- procedure Iterate
- (Container : in Set;
- Process : not null access procedure (Position : in Cursor)) is
+ X := X.Next;
+ end loop;
- procedure Process_Node (Node : in Node_Access);
- pragma Inline (Process_Node);
+ return False;
+ end;
+ end Vet;
- procedure Process_Node (Node : in Node_Access) is
- begin
- Process (Cursor'(Container'Unchecked_Access, Node));
- end Process_Node;
+ -----------
+ -- Write --
+ -----------
- procedure Iterate is
- new HT_Ops.Generic_Iteration (Process_Node);
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Container : Set)
+ is
begin
- Iterate (Container);
- end Iterate;
-
-
- function Capacity (Container : Set) return Count_Type
- renames HT_Ops.Capacity;
-
- procedure Reserve_Capacity
- (Container : in out Set;
- Capacity : in Count_Type)
- renames HT_Ops.Ensure_Capacity;
+ Write_Nodes (Stream, Container.HT);
+ 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;
- procedure Write_Node
- (Stream : access Root_Stream_Type'Class;
- Node : in Node_Access);
- pragma Inline (Write_Node);
+ ----------------
+ -- Write_Node --
+ ----------------
procedure Write_Node
- (Stream : access Root_Stream_Type'Class;
- Node : in Node_Access) is
+ (Stream : not null access Root_Stream_Type'Class;
+ Node : Node_Access)
+ is
begin
Element_Type'Output (Stream, Node.Element.all);
end Write_Node;
- procedure Write_Nodes is
- new HT_Ops.Generic_Write (Write_Node);
-
- procedure Write
- (Stream : access Root_Stream_Type'Class;
- Container : in Set) renames Write_Nodes;
-
-
- function Read_Node (Stream : access Root_Stream_Type'Class)
- return Node_Access;
- pragma Inline (Read_Node);
-
- function Read_Node (Stream : access Root_Stream_Type'Class)
- return Node_Access is
-
- X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
- begin
- return new Node_Type'(X, null);
- exception
- when others =>
- Free_Element (X);
- raise;
- end Read_Node;
-
- procedure Read_Nodes is
- new HT_Ops.Generic_Read (Read_Node);
-
- procedure Read
- (Stream : access Root_Stream_Type'Class;
- Container : out Set) renames Read_Nodes;
-
-
package body Generic_Keys is
- function Equivalent_Keys (Left : Cursor;
- Right : Key_Type)
- return Boolean is
- begin
- return Equivalent_Keys (Right, Left.Node.Element.all);
- end Equivalent_Keys;
-
- function Equivalent_Keys (Left : Key_Type;
- Right : Cursor)
- return Boolean is
- begin
- return Equivalent_Keys (Left, Right.Node.Element.all);
- end Equivalent_Keys;
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- function Equivalent_Keys
+ function Equivalent_Key_Node
(Key : Key_Type;
Node : Node_Access) return Boolean;
- pragma Inline (Equivalent_Keys);
+ pragma Inline (Equivalent_Key_Node);
- function Equivalent_Keys
- (Key : Key_Type;
- Node : Node_Access) return Boolean is
- begin
- return Equivalent_Keys (Key, Node.Element.all);
- end Equivalent_Keys;
+ --------------------------
+ -- Local Instantiations --
+ --------------------------
package Key_Keys is
new Hash_Tables.Generic_Keys
(HT_Types => HT_Types,
- HT_Type => Set,
- Null_Node => null,
Next => Next,
Set_Next => Set_Next,
Key_Type => Key_Type,
Hash => Hash,
- Equivalent_Keys => Equivalent_Keys);
+ Equivalent_Keys => Equivalent_Key_Node);
+ --------------
+ -- Contains --
+ --------------
- function Find (Container : Set;
- Key : Key_Type)
- return Cursor is
+ function Contains
+ (Container : Set;
+ Key : Key_Type) return Boolean
+ is
+ begin
+ return Find (Container, Key) /= No_Element;
+ end Contains;
- Node : constant Node_Access :=
- Key_Keys.Find (Container, Key);
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete
+ (Container : in out Set;
+ Key : Key_Type)
+ is
+ X : Node_Access;
begin
+ Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
- if Node = null then
- return No_Element;
+ if X = null then
+ raise Constraint_Error with "key not in map";
end if;
- return Cursor'(Container'Unchecked_Access, Node);
+ Free (X);
+ end Delete;
- end Find;
+ -------------
+ -- Element --
+ -------------
+ function Element
+ (Container : Set;
+ Key : Key_Type) return Element_Type
+ is
+ Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
- function Contains (Container : Set;
- Key : Key_Type) return Boolean is
begin
- return Find (Container, Key) /= No_Element;
- end Contains;
-
-
- function Element (Container : Set;
- Key : Key_Type)
- return Element_Type is
+ if Node = null then
+ raise Constraint_Error with "key not in map";
+ end if;
- Node : constant Node_Access := Key_Keys.Find (Container, Key);
- begin
return Node.Element.all;
end Element;
+ -------------------------
+ -- Equivalent_Key_Node --
+ -------------------------
- function Key (Position : Cursor) return Key_Type is
+ function Equivalent_Key_Node
+ (Key : Key_Type;
+ Node : Node_Access) return Boolean is
begin
- return Key (Position.Node.Element.all);
- end Key;
-
-
--- TODO:
--- procedure Replace (Container : in out Set;
--- Key : in Key_Type;
--- New_Item : in Element_Type) is
-
--- Node : constant Node_Access :=
--- Key_Keys.Find (Container, Key);
+ return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
+ end Equivalent_Key_Node;
--- begin
+ -------------
+ -- Exclude --
+ -------------
--- if Node = null then
--- raise Constraint_Error;
--- end if;
+ procedure Exclude
+ (Container : in out Set;
+ Key : Key_Type)
+ is
+ X : Node_Access;
+ begin
+ Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
+ Free (X);
+ end Exclude;
--- Replace_Element (Container, Node, New_Item);
+ ----------
+ -- Find --
+ ----------
--- end Replace;
+ function Find
+ (Container : Set;
+ Key : Key_Type) return Cursor
+ is
+ Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
+ begin
+ if Node = null then
+ return No_Element;
+ end if;
- procedure Delete (Container : in out Set;
- Key : in Key_Type) is
+ return Cursor'(Container'Unrestricted_Access, Node);
+ end Find;
- X : Node_Access;
+ ---------
+ -- Key --
+ ---------
+ function Key (Position : Cursor) return Key_Type is
begin
-
- Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
-
- if X = null then
- raise Constraint_Error;
+ if Position.Node = null then
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
end if;
- Free (X);
+ if Position.Node.Element = null then
+ raise Program_Error with "Position cursor is bad";
+ end if;
- end Delete;
+ pragma Assert (Vet (Position), "bad cursor in function Key");
+ return Key (Position.Node.Element.all);
+ end Key;
- procedure Exclude (Container : in out Set;
- Key : in Key_Type) is
+ -------------
+ -- Replace --
+ -------------
- X : Node_Access;
+ procedure Replace
+ (Container : in out Set;
+ Key : Key_Type;
+ New_Item : Element_Type)
+ is
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container.HT, Key);
begin
+ if Node = null then
+ raise Constraint_Error with
+ "attempt to replace key not in set";
+ end if;
- Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
- Free (X);
-
- end Exclude;
-
+ Replace_Element (Container.HT, Node, New_Item);
+ end Replace;
- procedure Checked_Update_Element
+ procedure Update_Element_Preserving_Key
(Container : in out Set;
- Position : in Cursor;
+ Position : Cursor;
Process : not null access
- procedure (Element : in out Element_Type)) is
+ procedure (Element : in out Element_Type))
+ is
+ HT : Hash_Table_Type renames Container.HT;
+ Indx : Hash_Type;
begin
+ if Position.Node = null then
+ raise Constraint_Error with
+ "Position cursor equals No_Element";
+ end if;
+
+ if Position.Node.Element = null
+ or else Position.Node.Next = Position.Node
+ then
+ raise Program_Error with "Position cursor is bad";
+ end if;
- if Position.Container = null then
- raise Constraint_Error;
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor designates wrong set";
end if;
- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
- raise Program_Error;
+ if HT.Buckets = null
+ or else HT.Buckets'Length = 0
+ or else HT.Length = 0
+ then
+ raise Program_Error with "Position cursor is bad (set is empty)";
end if;
+ pragma Assert
+ (Vet (Position),
+ "bad cursor in Update_Element_Preserving_Key");
+
+ Indx := HT_Ops.Index (HT, Position.Node);
+
declare
- Old_Key : Key_Type renames Key (Position.Node.Element.all);
+ E : Element_Type renames Position.Node.Element.all;
+ K : constant Key_Type := Key (E);
+
+ B : Natural renames HT.Busy;
+ L : Natural renames HT.Lock;
+
begin
- Process (Position.Node.Element.all);
+ 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 (Old_Key, Position.Node.Element.all) then
+ if Equivalent_Keys (K, Key (E)) then
+ pragma Assert (Hash (K) = Hash (E));
return;
end if;
end;
- declare
- function New_Node (Next : Node_Access) return Node_Access;
- pragma Inline (New_Node);
+ if HT.Buckets (Indx) = Position.Node then
+ HT.Buckets (Indx) := Position.Node.Next;
- function New_Node (Next : Node_Access) return Node_Access is
- begin
- Position.Node.Next := Next;
- return Position.Node;
- end New_Node;
+ else
+ declare
+ Prev : Node_Access := HT.Buckets (Indx);
- procedure Insert is
- new Key_Keys.Generic_Conditional_Insert (New_Node);
+ begin
+ while Prev.Next /= Position.Node loop
+ Prev := Prev.Next;
- Result : Node_Access;
- Success : Boolean;
- begin
- HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
+ if Prev = null then
+ raise Program_Error with
+ "Position cursor is bad (node not found)";
+ end if;
+ end loop;
- Insert
- (HT => Container,
- Key => Key (Position.Node.Element.all),
- Node => Result,
- Success => Success);
+ Prev.Next := Position.Node.Next;
+ end;
+ end if;
- if not Success then
- declare
- X : Node_Access := Position.Node;
- begin
- Free (X);
- end;
+ HT.Length := HT.Length - 1;
- raise Program_Error;
- end if;
+ declare
+ X : Node_Access := Position.Node;
- pragma Assert (Result = Position.Node);
+ begin
+ Free (X);
end;
- end Checked_Update_Element;
+ raise Program_Error with "key was modified";
+ end Update_Element_Preserving_Key;
end Generic_Keys;
end Ada.Containers.Indefinite_Hashed_Sets;
-
projects / thirdparty / gcc.git / blobdiff