1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_HASHED_SETS --
9 -- Copyright (C) 2004 Free Software Foundation, Inc. --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the contents of the part following the private keyword. --
15 -- GNAT is free software; you can redistribute it and/or modify it under --
16 -- terms of the GNU General Public License as published by the Free Soft- --
17 -- ware Foundation; either version 2, or (at your option) any later ver- --
18 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
21 -- for more details. You should have received a copy of the GNU General --
22 -- Public License distributed with GNAT; see file COPYING. If not, write --
23 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
24 -- MA 02111-1307, USA. --
26 -- As a special exception, if other files instantiate generics from this --
27 -- unit, or you link this unit with other files to produce an executable, --
28 -- this unit does not by itself cause the resulting executable to be --
29 -- covered by the GNU General Public License. This exception does not --
30 -- however invalidate any other reasons why the executable file might be --
31 -- covered by the GNU Public License. --
33 -- This unit has originally being developed by Matthew J Heaney. --
34 ------------------------------------------------------------------------------
36 with Ada
.Unchecked_Deallocation
;
38 with Ada
.Containers
.Hash_Tables
.Generic_Operations
;
39 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Operations
);
41 with Ada
.Containers
.Hash_Tables
.Generic_Keys
;
42 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Keys
);
44 with System
; use type System
.Address
;
46 with Ada
.Containers
.Prime_Numbers
;
48 with Ada
.Finalization
; use Ada
.Finalization
;
50 package body Ada
.Containers
.Indefinite_Hashed_Sets
is
52 type Element_Access
is access Element_Type
;
56 Element
: Element_Access
;
61 (Node
: Node_Access
) return Hash_Type
;
62 pragma Inline
(Hash_Node
);
65 (Node
: Node_Access
) return Hash_Type
is
67 return Hash
(Node
.Element
.all);
71 (Node
: Node_Access
) return Node_Access
;
75 (Node
: Node_Access
) return Node_Access
is
83 pragma Inline
(Set_Next
);
87 Next
: Node_Access
) is
92 function Equivalent_Keys
94 Node
: Node_Access
) return Boolean;
95 pragma Inline
(Equivalent_Keys
);
97 function Equivalent_Keys
99 Node
: Node_Access
) return Boolean is
101 return Equivalent_Keys
(Key
, Node
.Element
.all);
105 (Source
: Node_Access
) return Node_Access
;
106 pragma Inline
(Copy_Node
);
109 (Source
: Node_Access
) return Node_Access
is
111 Target
: constant Node_Access
:=
112 new Node_Type
'(Element => Source.Element,
119 procedure Free_Element is
120 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
122 procedure Free (X : in out Node_Access);
124 procedure Free (X : in out Node_Access) is
125 procedure Deallocate is
126 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
129 Free_Element (X.Element);
135 new Hash_Tables.Generic_Operations
136 (HT_Types => HT_Types,
137 Hash_Table_Type => Set,
139 Hash_Node => Hash_Node,
141 Set_Next => Set_Next,
142 Copy_Node => Copy_Node,
145 package Element_Keys is
146 new Hash_Tables.Generic_Keys
147 (HT_Types => HT_Types,
151 Set_Next => Set_Next,
152 Key_Type => Element_Type,
154 Equivalent_Keys => Equivalent_Keys);
157 procedure Adjust (Container : in out Set) renames HT_Ops.Adjust;
159 procedure Finalize (Container : in out Set) renames HT_Ops.Finalize;
162 function Find_Equal_Key
164 L_Node : Node_Access) return Boolean;
166 function Find_Equal_Key
168 L_Node : Node_Access) return Boolean is
170 R_Index : constant Hash_Type :=
171 Element_Keys.Index (R_Set, L_Node.Element.all);
173 R_Node : Node_Access := R_Set.Buckets (R_Index);
179 if R_Node = null then
183 if L_Node.Element.all = R_Node.Element.all then
187 R_Node := Next (R_Node);
194 new HT_Ops.Generic_Equal (Find_Equal_Key);
196 function "=" (Left, Right : Set) return Boolean renames Is_Equal;
199 function Length (Container : Set) return Count_Type is
201 return Container.Length;
205 function Is_Empty (Container : Set) return Boolean is
207 return Container.Length = 0;
211 procedure Clear (Container : in out Set) renames HT_Ops.Clear;
214 function Element (Position : Cursor) return Element_Type is
216 return Position.Node.Element.all;
220 procedure Query_Element
221 (Position : in Cursor;
222 Process : not null access procedure (Element : in Element_Type)) is
224 Process (Position.Node.Element.all);
229 -- procedure Replace_Element (Container : in out Set;
230 -- Position : in Node_Access;
231 -- By : in Element_Type);
233 -- procedure Replace_Element (Container : in out Set;
234 -- Position : in Node_Access;
235 -- By : in Element_Type) is
237 -- Node : Node_Access := Position;
241 -- if Equivalent_Keys (Node.Element.all, By) then
244 -- X : Element_Access := Node.Element;
246 -- Node.Element := new Element_Type'(By
);
248 -- -- NOTE: If there's an exception here, then just
249 -- -- let it propagate. We haven't modified the
250 -- -- state of the container, so there's nothing else
260 -- HT_Ops.Delete_Node_Sans_Free (Container, Node);
263 -- Free_Element (Node.Element);
266 -- Node.Element := null; -- don't attempt to dealloc X.E again
272 -- Node.Element := new Element_Type'(By);
280 -- function New_Node (Next : Node_Access) return Node_Access;
281 -- pragma Inline (New_Node);
283 -- function New_Node (Next : Node_Access) return Node_Access is
285 -- Node.Next := Next;
289 -- procedure Insert is
290 -- new Element_Keys.Generic_Conditional_Insert (New_Node);
292 -- Result : Node_Access;
293 -- Success : Boolean;
297 -- Key => Node.Element.all,
299 -- Success => Success);
301 -- if not Success then
303 -- raise Program_Error;
306 -- pragma Assert (Result = Node);
309 -- end Replace_Element;
312 -- procedure Replace_Element (Container : in out Set;
313 -- Position : in Cursor;
314 -- By : in Element_Type) is
317 -- if Position.Container = null then
318 -- raise Constraint_Error;
321 -- if Position.Container /= Set_Access'(Container'Unchecked_Access) then
322 -- raise Program_Error;
325 -- Replace_Element (Container, Position.Node, By);
327 -- end Replace_Element;
330 procedure Move
(Target
: in out Set
;
331 Source
: in out Set
) renames HT_Ops
.Move
;
334 procedure Insert
(Container
: in out Set
;
335 New_Item
: in Element_Type
;
336 Position
: out Cursor
;
337 Inserted
: out Boolean) is
339 function New_Node
(Next
: Node_Access
) return Node_Access
;
340 pragma Inline
(New_Node
);
342 function New_Node
(Next
: Node_Access
) return Node_Access
is
343 Element
: Element_Access
:= new Element_Type
'(New_Item);
345 return new Node_Type'(Element
, Next
);
348 Free_Element
(Element
);
353 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
357 HT_Ops
.Ensure_Capacity
(Container
, Container
.Length
+ 1);
358 Insert
(Container
, New_Item
, Position
.Node
, Inserted
);
359 Position
.Container
:= Container
'Unchecked_Access;
364 procedure Insert
(Container
: in out Set
;
365 New_Item
: in Element_Type
) is
372 Insert
(Container
, New_Item
, Position
, Inserted
);
375 raise Constraint_Error
;
381 procedure Replace
(Container
: in out Set
;
382 New_Item
: in Element_Type
) is
384 Node
: constant Node_Access
:=
385 Element_Keys
.Find
(Container
, New_Item
);
392 raise Constraint_Error
;
397 Node
.Element
:= new Element_Type
'(New_Item);
404 procedure Include (Container : in out Set;
405 New_Item : in Element_Type) is
414 Insert (Container, New_Item, Position, Inserted);
418 X := Position.Node.Element;
420 Position.Node.Element := new Element_Type'(New_Item
);
429 procedure Delete
(Container
: in out Set
;
430 Item
: in Element_Type
) is
436 Element_Keys
.Delete_Key_Sans_Free
(Container
, Item
, X
);
439 raise Constraint_Error
;
447 procedure Exclude
(Container
: in out Set
;
448 Item
: in Element_Type
) is
454 Element_Keys
.Delete_Key_Sans_Free
(Container
, Item
, X
);
460 procedure Delete
(Container
: in out Set
;
461 Position
: in out Cursor
) is
464 if Position
= No_Element
then
468 if Position
.Container
/= Set_Access
'(Container'Unchecked_Access) then
472 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
473 Free (Position.Node);
475 Position.Container := null;
481 procedure Union (Target : in out Set;
484 procedure Process (Src_Node : in Node_Access);
486 procedure Process (Src_Node : in Node_Access) is
488 Src : Element_Type renames Src_Node.Element.all;
490 function New_Node (Next : Node_Access) return Node_Access;
491 pragma Inline (New_Node);
493 function New_Node (Next : Node_Access) return Node_Access is
494 Tgt : Element_Access := new Element_Type'(Src
);
496 return new Node_Type
'(Tgt, Next);
504 new Element_Keys.Generic_Conditional_Insert (New_Node);
506 Tgt_Node : Node_Access;
511 Insert (Target, Src, Tgt_Node, Success);
516 new HT_Ops.Generic_Iteration (Process);
520 if Target'Address = Source'Address then
524 HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
532 function Union (Left, Right : Set) return Set is
534 Buckets : HT_Types.Buckets_Access;
539 if Left'Address = Right'Address then
543 if Right.Length = 0 then
547 if Left.Length = 0 then
552 Size : constant Hash_Type :=
553 Prime_Numbers.To_Prime (Left.Length + Right.Length);
555 Buckets := new Buckets_Type (0 .. Size - 1);
559 procedure Process (L_Node : Node_Access);
561 procedure Process (L_Node : Node_Access) is
562 I : constant Hash_Type :=
563 Hash (L_Node.Element.all) mod Buckets'Length;
565 Buckets (I) := new Node_Type'(L_Node
.Element
, Buckets
(I
));
569 new HT_Ops
.Generic_Iteration
(Process
);
574 HT_Ops
.Free_Hash_Table
(Buckets
);
578 Length
:= Left
.Length
;
581 procedure Process
(Src_Node
: Node_Access
);
583 procedure Process
(Src_Node
: Node_Access
) is
585 Src
: Element_Type
renames Src_Node
.Element
.all;
587 I
: constant Hash_Type
:=
588 Hash
(Src
) mod Buckets
'Length;
590 Tgt_Node
: Node_Access
:= Buckets
(I
);
594 while Tgt_Node
/= null loop
596 if Equivalent_Keys
(Src
, Tgt_Node
.Element
.all) then
600 Tgt_Node
:= Next
(Tgt_Node
);
605 Tgt
: Element_Access
:= new Element_Type
'(Src);
607 Buckets (I) := new Node_Type'(Tgt
, Buckets
(I
));
614 Length
:= Length
+ 1;
619 new HT_Ops
.Generic_Iteration
(Process
);
624 HT_Ops
.Free_Hash_Table
(Buckets
);
628 return (Controlled
with Buckets
, Length
);
635 Key
: Node_Access
) return Boolean;
636 pragma Inline
(Is_In
);
640 Key
: Node_Access
) return Boolean is
642 return Element_Keys
.Find
(HT
, Key
.Element
.all) /= null;
646 procedure Intersection
(Target
: in out Set
;
649 Tgt_Node
: Node_Access
;
653 if Target
'Address = Source
'Address then
657 if Source
.Length
= 0 then
662 -- TODO: optimize this to use an explicit
663 -- loop instead of an active iterator
664 -- (similar to how a passive iterator is
667 -- Another possibility is to test which
668 -- set is smaller, and iterate over the
671 Tgt_Node
:= HT_Ops
.First
(Target
);
673 while Tgt_Node
/= null loop
675 if Is_In
(Source
, Tgt_Node
) then
677 Tgt_Node
:= HT_Ops
.Next
(Target
, Tgt_Node
);
682 X
: Node_Access
:= Tgt_Node
;
684 Tgt_Node
:= HT_Ops
.Next
(Target
, Tgt_Node
);
685 HT_Ops
.Delete_Node_Sans_Free
(Target
, X
);
696 function Intersection
(Left
, Right
: Set
) return Set
is
698 Buckets
: HT_Types
.Buckets_Access
;
703 if Left
'Address = Right
'Address then
707 Length
:= Count_Type
'Min (Left
.Length
, Right
.Length
);
714 Size
: constant Hash_Type
:= Prime_Numbers
.To_Prime
(Length
);
716 Buckets
:= new Buckets_Type
(0 .. Size
- 1);
722 procedure Process
(L_Node
: Node_Access
);
724 procedure Process
(L_Node
: Node_Access
) is
726 if Is_In
(Right
, L_Node
) then
729 I
: constant Hash_Type
:=
730 Hash
(L_Node
.Element
.all) mod Buckets
'Length;
732 Buckets
(I
) := new Node_Type
'(L_Node.Element, Buckets (I));
735 Length := Length + 1;
741 new HT_Ops.Generic_Iteration (Process);
746 HT_Ops.Free_Hash_Table (Buckets);
750 return (Controlled with Buckets, Length);
755 procedure Difference (Target : in out Set;
759 Tgt_Node : Node_Access;
763 if Target'Address = Source'Address then
768 if Source.Length = 0 then
772 -- TODO: As I noted above, this can be
773 -- written in terms of a loop instead as
774 -- active-iterator style, sort of like a
777 Tgt_Node := HT_Ops.First (Target);
779 while Tgt_Node /= null loop
781 if Is_In (Source, Tgt_Node) then
784 X : Node_Access := Tgt_Node;
786 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
787 HT_Ops.Delete_Node_Sans_Free (Target, X);
793 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
803 function Difference (Left, Right : Set) return Set is
805 Buckets : HT_Types.Buckets_Access;
810 if Left'Address = Right'Address then
814 if Left.Length = 0 then
818 if Right.Length = 0 then
823 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
825 Buckets := new Buckets_Type (0 .. Size - 1);
831 procedure Process (L_Node : Node_Access);
833 procedure Process (L_Node : Node_Access) is
835 if not Is_In (Right, L_Node) then
838 I : constant Hash_Type :=
839 Hash (L_Node.Element.all) mod Buckets'Length;
841 Buckets (I) := new Node_Type'(L_Node
.Element
, Buckets
(I
));
844 Length
:= Length
+ 1;
850 new HT_Ops
.Generic_Iteration
(Process
);
855 HT_Ops
.Free_Hash_Table
(Buckets
);
859 return (Controlled
with Buckets
, Length
);
865 procedure Symmetric_Difference
(Target
: in out Set
;
869 if Target
'Address = Source
'Address then
874 HT_Ops
.Ensure_Capacity
(Target
, Target
.Length
+ Source
.Length
);
876 if Target
.Length
= 0 then
879 procedure Process
(Src_Node
: Node_Access
);
881 procedure Process
(Src_Node
: Node_Access
) is
882 E
: Element_Type
renames Src_Node
.Element
.all;
883 B
: Buckets_Type
renames Target
.Buckets
.all;
884 I
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
885 N
: Count_Type
renames Target
.Length
;
888 X
: Element_Access
:= new Element_Type
'(E);
890 B (I) := new Node_Type'(X
, B
(I
));
901 new HT_Ops
.Generic_Iteration
(Process
);
909 procedure Process
(Src_Node
: Node_Access
);
911 procedure Process
(Src_Node
: Node_Access
) is
912 E
: Element_Type
renames Src_Node
.Element
.all;
913 B
: Buckets_Type
renames Target
.Buckets
.all;
914 I
: constant Hash_Type
:= Hash
(E
) mod B
'Length;
915 N
: Count_Type
renames Target
.Length
;
920 X
: Element_Access
:= new Element_Type
'(E);
922 B (I) := new Node_Type'(X
, null);
931 elsif Equivalent_Keys
(E
, B
(I
).Element
.all) then
934 X
: Node_Access
:= B
(I
);
944 Prev
: Node_Access
:= B
(I
);
945 Curr
: Node_Access
:= Prev
.Next
;
947 while Curr
/= null loop
948 if Equivalent_Keys
(E
, Curr
.Element
.all) then
949 Prev
.Next
:= Curr
.Next
;
960 X
: Element_Access
:= new Element_Type
'(E);
962 B (I) := new Node_Type'(X
, B
(I
));
976 new HT_Ops
.Generic_Iteration
(Process
);
983 end Symmetric_Difference
;
986 function Symmetric_Difference
(Left
, Right
: Set
) return Set
is
988 Buckets
: HT_Types
.Buckets_Access
;
993 if Left
'Address = Right
'Address then
997 if Right
.Length
= 0 then
1001 if Left
.Length
= 0 then
1006 Size
: constant Hash_Type
:=
1007 Prime_Numbers
.To_Prime
(Left
.Length
+ Right
.Length
);
1009 Buckets
:= new Buckets_Type
(0 .. Size
- 1);
1015 procedure Process
(L_Node
: Node_Access
);
1017 procedure Process
(L_Node
: Node_Access
) is
1019 if not Is_In
(Right
, L_Node
) then
1021 E
: Element_Type
renames L_Node
.Element
.all;
1022 I
: constant Hash_Type
:= Hash
(E
) mod Buckets
'Length;
1026 X
: Element_Access
:= new Element_Type
'(E);
1028 Buckets (I) := new Node_Type'(X
, Buckets
(I
));
1035 Length
:= Length
+ 1;
1040 procedure Iterate
is
1041 new HT_Ops
.Generic_Iteration
(Process
);
1046 HT_Ops
.Free_Hash_Table
(Buckets
);
1051 procedure Process
(R_Node
: Node_Access
);
1053 procedure Process
(R_Node
: Node_Access
) is
1055 if not Is_In
(Left
, R_Node
) then
1057 E
: Element_Type
renames R_Node
.Element
.all;
1058 I
: constant Hash_Type
:= Hash
(E
) mod Buckets
'Length;
1062 X
: Element_Access
:= new Element_Type
'(E);
1064 Buckets (I) := new Node_Type'(X
, Buckets
(I
));
1071 Length
:= Length
+ 1;
1077 procedure Iterate
is
1078 new HT_Ops
.Generic_Iteration
(Process
);
1083 HT_Ops
.Free_Hash_Table
(Buckets
);
1087 return (Controlled
with Buckets
, Length
);
1089 end Symmetric_Difference
;
1092 function Is_Subset
(Subset
: Set
;
1093 Of_Set
: Set
) return Boolean is
1095 Subset_Node
: Node_Access
;
1099 if Subset
'Address = Of_Set
'Address then
1103 if Subset
.Length
> Of_Set
.Length
then
1107 -- TODO: rewrite this to loop in the
1108 -- style of a passive iterator.
1110 Subset_Node
:= HT_Ops
.First
(Subset
);
1112 while Subset_Node
/= null loop
1113 if not Is_In
(Of_Set
, Subset_Node
) then
1117 Subset_Node
:= HT_Ops
.Next
(Subset
, Subset_Node
);
1125 function Overlap
(Left
, Right
: Set
) return Boolean is
1127 Left_Node
: Node_Access
;
1131 if Right
.Length
= 0 then
1135 if Left
'Address = Right
'Address then
1139 Left_Node
:= HT_Ops
.First
(Left
);
1141 while Left_Node
/= null loop
1142 if Is_In
(Right
, Left_Node
) then
1146 Left_Node
:= HT_Ops
.Next
(Left
, Left_Node
);
1154 function Find
(Container
: Set
;
1155 Item
: Element_Type
) return Cursor
is
1157 Node
: constant Node_Access
:= Element_Keys
.Find
(Container
, Item
);
1165 return Cursor
'(Container'Unchecked_Access, Node);
1170 function Contains (Container : Set;
1171 Item : Element_Type) return Boolean is
1173 return Find (Container, Item) /= No_Element;
1178 function First (Container : Set) return Cursor is
1179 Node : constant Node_Access := HT_Ops.First (Container);
1185 return Cursor'(Container
'Unchecked_Access, Node
);
1189 -- function First_Element (Container : Set) return Element_Type is
1190 -- Node : constant Node_Access := HT_Ops.First (Container);
1192 -- return Node.Element;
1193 -- end First_Element;
1196 function Next
(Position
: Cursor
) return Cursor
is
1198 if Position
.Container
= null
1199 or else Position
.Node
= null
1205 S
: Set
renames Position
.Container
.all;
1206 Node
: constant Node_Access
:= HT_Ops
.Next
(S
, Position
.Node
);
1212 return Cursor
'(Position.Container, Node);
1217 procedure Next (Position : in out Cursor) is
1219 Position := Next (Position);
1223 function Has_Element (Position : Cursor) return Boolean is
1225 if Position.Container = null then
1229 if Position.Node = null then
1237 function Equivalent_Keys (Left, Right : Cursor)
1240 return Equivalent_Keys (Left.Node.Element.all, Right.Node.Element.all);
1241 end Equivalent_Keys;
1244 function Equivalent_Keys (Left : Cursor;
1245 Right : Element_Type)
1248 return Equivalent_Keys (Left.Node.Element.all, Right);
1249 end Equivalent_Keys;
1252 function Equivalent_Keys (Left : Element_Type;
1256 return Equivalent_Keys (Left, Right.Node.Element.all);
1257 end Equivalent_Keys;
1261 (Container : in Set;
1262 Process : not null access procedure (Position : in Cursor)) is
1264 procedure Process_Node (Node : in Node_Access);
1265 pragma Inline (Process_Node);
1267 procedure Process_Node (Node : in Node_Access) is
1269 Process (Cursor'(Container
'Unchecked_Access, Node
));
1272 procedure Iterate
is
1273 new HT_Ops
.Generic_Iteration
(Process_Node
);
1275 Iterate
(Container
);
1279 function Capacity
(Container
: Set
) return Count_Type
1280 renames HT_Ops
.Capacity
;
1282 procedure Reserve_Capacity
1283 (Container
: in out Set
;
1284 Capacity
: in Count_Type
)
1285 renames HT_Ops
.Ensure_Capacity
;
1288 procedure Write_Node
1289 (Stream
: access Root_Stream_Type
'Class;
1290 Node
: in Node_Access
);
1291 pragma Inline
(Write_Node
);
1293 procedure Write_Node
1294 (Stream
: access Root_Stream_Type
'Class;
1295 Node
: in Node_Access
) is
1297 Element_Type
'Output (Stream
, Node
.Element
.all);
1300 procedure Write_Nodes
is
1301 new HT_Ops
.Generic_Write
(Write_Node
);
1304 (Stream
: access Root_Stream_Type
'Class;
1305 Container
: in Set
) renames Write_Nodes
;
1308 function Read_Node
(Stream
: access Root_Stream_Type
'Class)
1310 pragma Inline
(Read_Node
);
1312 function Read_Node
(Stream
: access Root_Stream_Type
'Class)
1313 return Node_Access
is
1315 X
: Element_Access
:= new Element_Type
'(Element_Type'Input (Stream));
1317 return new Node_Type'(X
, null);
1324 procedure Read_Nodes
is
1325 new HT_Ops
.Generic_Read
(Read_Node
);
1328 (Stream
: access Root_Stream_Type
'Class;
1329 Container
: out Set
) renames Read_Nodes
;
1332 package body Generic_Keys
is
1334 function Equivalent_Keys
(Left
: Cursor
;
1338 return Equivalent_Keys
(Right
, Left
.Node
.Element
.all);
1339 end Equivalent_Keys
;
1341 function Equivalent_Keys
(Left
: Key_Type
;
1345 return Equivalent_Keys
(Left
, Right
.Node
.Element
.all);
1346 end Equivalent_Keys
;
1348 function Equivalent_Keys
1350 Node
: Node_Access
) return Boolean;
1351 pragma Inline
(Equivalent_Keys
);
1353 function Equivalent_Keys
1355 Node
: Node_Access
) return Boolean is
1357 return Equivalent_Keys
(Key
, Node
.Element
.all);
1358 end Equivalent_Keys
;
1361 new Hash_Tables
.Generic_Keys
1362 (HT_Types
=> HT_Types
,
1366 Set_Next
=> Set_Next
,
1367 Key_Type
=> Key_Type
,
1369 Equivalent_Keys
=> Equivalent_Keys
);
1372 function Find
(Container
: Set
;
1376 Node
: constant Node_Access
:=
1377 Key_Keys
.Find
(Container
, Key
);
1385 return Cursor
'(Container'Unchecked_Access, Node);
1390 function Contains (Container : Set;
1391 Key : Key_Type) return Boolean is
1393 return Find (Container, Key) /= No_Element;
1397 function Element (Container : Set;
1399 return Element_Type is
1401 Node : constant Node_Access := Key_Keys.Find (Container, Key);
1403 return Node.Element.all;
1407 function Key (Position : Cursor) return Key_Type is
1409 return Key (Position.Node.Element.all);
1414 -- procedure Replace (Container : in out Set;
1415 -- Key : in Key_Type;
1416 -- New_Item : in Element_Type) is
1418 -- Node : constant Node_Access :=
1419 -- Key_Keys.Find (Container, Key);
1423 -- if Node = null then
1424 -- raise Constraint_Error;
1427 -- Replace_Element (Container, Node, New_Item);
1432 procedure Delete (Container : in out Set;
1433 Key : in Key_Type) is
1439 Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1442 raise Constraint_Error;
1450 procedure Exclude (Container : in out Set;
1451 Key : in Key_Type) is
1457 Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1463 procedure Checked_Update_Element
1464 (Container : in out Set;
1465 Position : in Cursor;
1466 Process : not null access
1467 procedure (Element : in out Element_Type)) is
1471 if Position.Container = null then
1472 raise Constraint_Error;
1475 if Position.Container /= Set_Access'(Container
'Unchecked_Access) then
1476 raise Program_Error
;
1480 Old_Key
: Key_Type
renames Key
(Position
.Node
.Element
.all);
1482 Process
(Position
.Node
.Element
.all);
1484 if Equivalent_Keys
(Old_Key
, Position
.Node
.Element
.all) then
1490 function New_Node
(Next
: Node_Access
) return Node_Access
;
1491 pragma Inline
(New_Node
);
1493 function New_Node
(Next
: Node_Access
) return Node_Access
is
1495 Position
.Node
.Next
:= Next
;
1496 return Position
.Node
;
1500 new Key_Keys
.Generic_Conditional_Insert
(New_Node
);
1502 Result
: Node_Access
;
1505 HT_Ops
.Delete_Node_Sans_Free
(Container
, Position
.Node
);
1509 Key
=> Key
(Position
.Node
.Element
.all),
1511 Success
=> Success
);
1515 X
: Node_Access
:= Position
.Node
;
1520 raise Program_Error
;
1523 pragma Assert
(Result
= Position
.Node
);
1526 end Checked_Update_Element
;
1530 end Ada
.Containers
.Indefinite_Hashed_Sets
;