1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ S E T S --
9 -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Containers
.Hash_Tables
.Generic_Bounded_Operations
;
31 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Bounded_Operations
);
33 with Ada
.Containers
.Hash_Tables
.Generic_Bounded_Keys
;
34 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Bounded_Keys
);
36 with Ada
.Containers
.Prime_Numbers
; use Ada
.Containers
.Prime_Numbers
;
37 with Ada
.Finalization
; use Ada
.Finalization
;
39 with System
; use type System
.Address
;
41 package body Ada
.Containers
.Bounded_Hashed_Sets
is
43 type Iterator
is new Limited_Controlled
and
44 Set_Iterator_Interfaces
.Forward_Iterator
with
46 Container
: Set_Access
;
49 overriding
procedure Finalize
(Object
: in out Iterator
);
51 overriding
function First
(Object
: Iterator
) return Cursor
;
53 overriding
function Next
55 Position
: Cursor
) return Cursor
;
57 -----------------------
58 -- Local Subprograms --
59 -----------------------
61 function Equivalent_Keys
63 Node
: Node_Type
) return Boolean;
64 pragma Inline
(Equivalent_Keys
);
66 function Hash_Node
(Node
: Node_Type
) return Hash_Type
;
67 pragma Inline
(Hash_Node
);
70 (Container
: in out Set
;
71 New_Item
: Element_Type
;
72 Node
: out Count_Type
;
73 Inserted
: out Boolean);
75 function Is_In
(HT
: Set
; Key
: Node_Type
) return Boolean;
76 pragma Inline
(Is_In
);
78 procedure Set_Element
(Node
: in out Node_Type
; Item
: Element_Type
);
79 pragma Inline
(Set_Element
);
81 function Next
(Node
: Node_Type
) return Count_Type
;
84 procedure Set_Next
(Node
: in out Node_Type
; Next
: Count_Type
);
85 pragma Inline
(Set_Next
);
87 function Vet
(Position
: Cursor
) return Boolean;
89 --------------------------
90 -- Local Instantiations --
91 --------------------------
93 package HT_Ops
is new Hash_Tables
.Generic_Bounded_Operations
94 (HT_Types
=> HT_Types
,
95 Hash_Node
=> Hash_Node
,
97 Set_Next
=> Set_Next
);
99 package Element_Keys
is new Hash_Tables
.Generic_Bounded_Keys
100 (HT_Types
=> HT_Types
,
102 Set_Next
=> Set_Next
,
103 Key_Type
=> Element_Type
,
105 Equivalent_Keys
=> Equivalent_Keys
);
107 procedure Replace_Element
is
108 new Element_Keys
.Generic_Replace_Element
(Hash_Node
, Set_Element
);
114 function "=" (Left
, Right
: Set
) return Boolean is
115 function Find_Equal_Key
116 (R_HT
: Hash_Table_Type
'Class;
117 L_Node
: Node_Type
) return Boolean;
118 pragma Inline
(Find_Equal_Key
);
121 new HT_Ops
.Generic_Equal
(Find_Equal_Key
);
127 function Find_Equal_Key
128 (R_HT
: Hash_Table_Type
'Class;
129 L_Node
: Node_Type
) return Boolean
131 R_Index
: constant Hash_Type
:=
132 Element_Keys
.Index
(R_HT
, L_Node
.Element
);
134 R_Node
: Count_Type
:= R_HT
.Buckets
(R_Index
);
142 if L_Node
.Element
= R_HT
.Nodes
(R_Node
).Element
then
146 R_Node
:= Next
(R_HT
.Nodes
(R_Node
));
150 -- Start of processing for "="
153 return Is_Equal
(Left
, Right
);
160 procedure Assign
(Target
: in out Set
; Source
: Set
) is
161 procedure Insert_Element
(Source_Node
: Count_Type
);
163 procedure Insert_Elements
is
164 new HT_Ops
.Generic_Iteration
(Insert_Element
);
170 procedure Insert_Element
(Source_Node
: Count_Type
) is
171 N
: Node_Type
renames Source
.Nodes
(Source_Node
);
175 Insert
(Target
, N
.Element
, X
, B
);
179 -- Start of processing for Assign
182 if Target
'Address = Source
'Address then
186 if Target
.Capacity
< Source
.Length
then
188 with "Target capacity is less than Source length";
191 HT_Ops
.Clear
(Target
);
192 Insert_Elements
(Source
);
199 function Capacity
(Container
: Set
) return Count_Type
is
201 return Container
.Capacity
;
208 procedure Clear
(Container
: in out Set
) is
210 HT_Ops
.Clear
(Container
);
213 ------------------------
214 -- Constant_Reference --
215 ------------------------
217 function Constant_Reference
218 (Container
: aliased Set
;
219 Position
: Cursor
) return Constant_Reference_Type
222 if Position
.Container
= null then
223 raise Constraint_Error
with "Position cursor has no element";
226 if Position
.Container
/= Container
'Unrestricted_Access then
227 raise Program_Error
with
228 "Position cursor designates wrong container";
231 pragma Assert
(Vet
(Position
), "bad cursor in Constant_Reference");
234 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
236 return (Element
=> N
.Element
'Access);
238 end Constant_Reference
;
244 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean is
246 return Find
(Container
, Item
) /= No_Element
;
255 Capacity
: Count_Type
:= 0;
256 Modulus
: Hash_Type
:= 0) return Set
264 elsif Capacity
>= Source
.Length
then
267 raise Capacity_Error
with "Capacity value too small";
271 M
:= Default_Modulus
(C
);
276 return Target
: Set
(Capacity
=> C
, Modulus
=> M
) do
277 Assign
(Target
=> Target
, Source
=> Source
);
281 ---------------------
282 -- Default_Modulus --
283 ---------------------
285 function Default_Modulus
(Capacity
: Count_Type
) return Hash_Type
is
287 return To_Prime
(Capacity
);
295 (Container
: in out Set
;
301 Element_Keys
.Delete_Key_Sans_Free
(Container
, Item
, X
);
304 raise Constraint_Error
with "attempt to delete element not in set";
307 HT_Ops
.Free
(Container
, X
);
311 (Container
: in out Set
;
312 Position
: in out Cursor
)
315 if Position
.Node
= 0 then
316 raise Constraint_Error
with "Position cursor equals No_Element";
319 if Position
.Container
/= Container
'Unrestricted_Access then
320 raise Program_Error
with "Position cursor designates wrong set";
323 if Container
.Busy
> 0 then
324 raise Program_Error
with
325 "attempt to tamper with cursors (set is busy)";
328 pragma Assert
(Vet
(Position
), "bad cursor in Delete");
330 HT_Ops
.Delete_Node_Sans_Free
(Container
, Position
.Node
);
331 HT_Ops
.Free
(Container
, Position
.Node
);
333 Position
:= No_Element
;
341 (Target
: in out Set
;
344 Tgt_Node
, Src_Node
: Count_Type
;
346 TN
: Nodes_Type
renames Target
.Nodes
;
347 SN
: Nodes_Type
renames Source
.Nodes
;
350 if Target
'Address = Source
'Address then
351 HT_Ops
.Clear
(Target
);
355 if Source
.Length
= 0 then
359 if Target
.Busy
> 0 then
360 raise Program_Error
with
361 "attempt to tamper with cursors (set is busy)";
364 if Source
.Length
< Target
.Length
then
365 Src_Node
:= HT_Ops
.First
(Source
);
366 while Src_Node
/= 0 loop
367 Tgt_Node
:= Element_Keys
.Find
(Target
, SN
(Src_Node
).Element
);
369 if Tgt_Node
/= 0 then
370 HT_Ops
.Delete_Node_Sans_Free
(Target
, Tgt_Node
);
371 HT_Ops
.Free
(Target
, Tgt_Node
);
374 Src_Node
:= HT_Ops
.Next
(Source
, Src_Node
);
378 Tgt_Node
:= HT_Ops
.First
(Target
);
379 while Tgt_Node
/= 0 loop
380 if Is_In
(Source
, TN
(Tgt_Node
)) then
382 X
: constant Count_Type
:= Tgt_Node
;
384 Tgt_Node
:= HT_Ops
.Next
(Target
, Tgt_Node
);
385 HT_Ops
.Delete_Node_Sans_Free
(Target
, X
);
386 HT_Ops
.Free
(Target
, X
);
390 Tgt_Node
:= HT_Ops
.Next
(Target
, Tgt_Node
);
396 function Difference
(Left
, Right
: Set
) return Set
is
398 if Left
'Address = Right
'Address then
402 if Left
.Length
= 0 then
406 if Right
.Length
= 0 then
410 return Result
: Set
(Left
.Length
, To_Prime
(Left
.Length
)) do
411 Iterate_Left
: declare
412 procedure Process
(L_Node
: Count_Type
);
415 new HT_Ops
.Generic_Iteration
(Process
);
421 procedure Process
(L_Node
: Count_Type
) is
422 N
: Node_Type
renames Left
.Nodes
(L_Node
);
426 if not Is_In
(Right
, N
) then
427 Insert
(Result
, N
.Element
, X
, B
); -- optimize this ???
429 pragma Assert
(X
> 0);
433 -- Start of processing for Iterate_Left
445 function Element
(Position
: Cursor
) return Element_Type
is
447 if Position
.Node
= 0 then
448 raise Constraint_Error
with "Position cursor equals No_Element";
451 pragma Assert
(Vet
(Position
), "bad cursor in function Element");
454 S
: Set
renames Position
.Container
.all;
455 N
: Node_Type
renames S
.Nodes
(Position
.Node
);
461 ---------------------
462 -- Equivalent_Sets --
463 ---------------------
465 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
466 function Find_Equivalent_Key
467 (R_HT
: Hash_Table_Type
'Class;
468 L_Node
: Node_Type
) return Boolean;
469 pragma Inline
(Find_Equivalent_Key
);
471 function Is_Equivalent
is
472 new HT_Ops
.Generic_Equal
(Find_Equivalent_Key
);
474 -------------------------
475 -- Find_Equivalent_Key --
476 -------------------------
478 function Find_Equivalent_Key
479 (R_HT
: Hash_Table_Type
'Class;
480 L_Node
: Node_Type
) return Boolean
482 R_Index
: constant Hash_Type
:=
483 Element_Keys
.Index
(R_HT
, L_Node
.Element
);
485 R_Node
: Count_Type
:= R_HT
.Buckets
(R_Index
);
487 RN
: Nodes_Type
renames R_HT
.Nodes
;
495 if Equivalent_Elements
(L_Node
.Element
, RN
(R_Node
).Element
) then
499 R_Node
:= HT_Ops
.Next
(R_HT
, R_Node
);
501 end Find_Equivalent_Key
;
503 -- Start of processing for Equivalent_Sets
506 return Is_Equivalent
(Left
, Right
);
509 -------------------------
510 -- Equivalent_Elements --
511 -------------------------
513 function Equivalent_Elements
(Left
, Right
: Cursor
)
517 if Left
.Node
= 0 then
518 raise Constraint_Error
with
519 "Left cursor of Equivalent_Elements equals No_Element";
522 if Right
.Node
= 0 then
523 raise Constraint_Error
with
524 "Right cursor of Equivalent_Elements equals No_Element";
527 pragma Assert
(Vet
(Left
), "bad Left cursor in Equivalent_Elements");
528 pragma Assert
(Vet
(Right
), "bad Right cursor in Equivalent_Elements");
531 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
532 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
534 return Equivalent_Elements
(LN
.Element
, RN
.Element
);
536 end Equivalent_Elements
;
538 function Equivalent_Elements
540 Right
: Element_Type
) return Boolean
543 if Left
.Node
= 0 then
544 raise Constraint_Error
with
545 "Left cursor of Equivalent_Elements equals No_Element";
548 pragma Assert
(Vet
(Left
), "Left cursor in Equivalent_Elements is bad");
551 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
553 return Equivalent_Elements
(LN
.Element
, Right
);
555 end Equivalent_Elements
;
557 function Equivalent_Elements
558 (Left
: Element_Type
;
559 Right
: Cursor
) return Boolean
562 if Right
.Node
= 0 then
563 raise Constraint_Error
with
564 "Right cursor of Equivalent_Elements equals No_Element";
569 "Right cursor of Equivalent_Elements is bad");
572 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
574 return Equivalent_Elements
(Left
, RN
.Element
);
576 end Equivalent_Elements
;
578 ---------------------
579 -- Equivalent_Keys --
580 ---------------------
582 function Equivalent_Keys
584 Node
: Node_Type
) return Boolean
587 return Equivalent_Elements
(Key
, Node
.Element
);
595 (Container
: in out Set
;
600 Element_Keys
.Delete_Key_Sans_Free
(Container
, Item
, X
);
601 HT_Ops
.Free
(Container
, X
);
608 procedure Finalize
(Object
: in out Iterator
) is
610 if Object
.Container
/= null then
612 B
: Natural renames Object
.Container
.all.Busy
;
625 Item
: Element_Type
) return Cursor
627 Node
: constant Count_Type
:= Element_Keys
.Find
(Container
, Item
);
629 return (if Node
= 0 then No_Element
630 else Cursor
'(Container'Unrestricted_Access, Node));
637 function First (Container : Set) return Cursor is
638 Node : constant Count_Type := HT_Ops.First (Container);
640 return (if Node = 0 then No_Element
641 else Cursor'(Container
'Unrestricted_Access, Node
));
644 overriding
function First
(Object
: Iterator
) return Cursor
is
646 return Object
.Container
.First
;
653 function Has_Element
(Position
: Cursor
) return Boolean is
655 pragma Assert
(Vet
(Position
), "bad cursor in Has_Element");
656 return Position
.Node
/= 0;
663 function Hash_Node
(Node
: Node_Type
) return Hash_Type
is
665 return Hash
(Node
.Element
);
673 (Container
: in out Set
;
674 New_Item
: Element_Type
)
680 Insert
(Container
, New_Item
, Position
, Inserted
);
683 if Container
.Lock
> 0 then
684 raise Program_Error
with
685 "attempt to tamper with elements (set is locked)";
688 Container
.Nodes
(Position
.Node
).Element
:= New_Item
;
697 (Container
: in out Set
;
698 New_Item
: Element_Type
;
699 Position
: out Cursor
;
700 Inserted
: out Boolean)
703 Insert
(Container
, New_Item
, Position
.Node
, Inserted
);
704 Position
.Container
:= Container
'Unchecked_Access;
708 (Container
: in out Set
;
709 New_Item
: Element_Type
)
712 pragma Unreferenced
(Position
);
717 Insert
(Container
, New_Item
, Position
, Inserted
);
720 raise Constraint_Error
with
721 "attempt to insert element already in set";
726 (Container
: in out Set
;
727 New_Item
: Element_Type
;
728 Node
: out Count_Type
;
729 Inserted
: out Boolean)
731 procedure Allocate_Set_Element
(Node
: in out Node_Type
);
732 pragma Inline
(Allocate_Set_Element
);
734 function New_Node
return Count_Type
;
735 pragma Inline
(New_Node
);
737 procedure Local_Insert
is
738 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
740 procedure Allocate
is
741 new HT_Ops
.Generic_Allocate
(Allocate_Set_Element
);
743 ---------------------------
744 -- Allocate_Set_Element --
745 ---------------------------
747 procedure Allocate_Set_Element
(Node
: in out Node_Type
) is
749 Node
.Element
:= New_Item
;
750 end Allocate_Set_Element
;
756 function New_Node
return Count_Type
is
759 Allocate
(Container
, Result
);
763 -- Start of processing for Insert
766 -- The buckets array length is specified by the user as a discriminant
767 -- of the container type, so it is possible for the buckets array to
768 -- have a length of zero. We must check for this case specifically, in
769 -- order to prevent divide-by-zero errors later, when we compute the
770 -- buckets array index value for an element, given its hash value.
772 if Container
.Buckets
'Length = 0 then
773 raise Capacity_Error
with "No capacity for insertion";
776 Local_Insert
(Container
, New_Item
, Node
, Inserted
);
783 procedure Intersection
784 (Target
: in out Set
;
787 Tgt_Node
: Count_Type
;
788 TN
: Nodes_Type
renames Target
.Nodes
;
791 if Target
'Address = Source
'Address then
795 if Source
.Length
= 0 then
796 HT_Ops
.Clear
(Target
);
800 if Target
.Busy
> 0 then
801 raise Program_Error
with
802 "attempt to tamper with cursors (set is busy)";
805 Tgt_Node
:= HT_Ops
.First
(Target
);
806 while Tgt_Node
/= 0 loop
807 if Is_In
(Source
, TN
(Tgt_Node
)) then
808 Tgt_Node
:= HT_Ops
.Next
(Target
, Tgt_Node
);
812 X
: constant Count_Type
:= Tgt_Node
;
814 Tgt_Node
:= HT_Ops
.Next
(Target
, Tgt_Node
);
815 HT_Ops
.Delete_Node_Sans_Free
(Target
, X
);
816 HT_Ops
.Free
(Target
, X
);
822 function Intersection
(Left
, Right
: Set
) return Set
is
826 if Left
'Address = Right
'Address then
830 C
:= Count_Type
'Min (Left
.Length
, Right
.Length
);
836 return Result
: Set
(C
, To_Prime
(C
)) do
837 Iterate_Left
: declare
838 procedure Process
(L_Node
: Count_Type
);
841 new HT_Ops
.Generic_Iteration
(Process
);
847 procedure Process
(L_Node
: Count_Type
) is
848 N
: Node_Type
renames Left
.Nodes
(L_Node
);
853 if Is_In
(Right
, N
) then
854 Insert
(Result
, N
.Element
, X
, B
); -- optimize ???
856 pragma Assert
(X
> 0);
860 -- Start of processing for Iterate_Left
872 function Is_Empty
(Container
: Set
) return Boolean is
874 return Container
.Length
= 0;
881 function Is_In
(HT
: Set
; Key
: Node_Type
) return Boolean is
883 return Element_Keys
.Find
(HT
, Key
.Element
) /= 0;
890 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
891 Subset_Node
: Count_Type
;
892 SN
: Nodes_Type
renames Subset
.Nodes
;
895 if Subset
'Address = Of_Set
'Address then
899 if Subset
.Length
> Of_Set
.Length
then
903 Subset_Node
:= HT_Ops
.First
(Subset
);
904 while Subset_Node
/= 0 loop
905 if not Is_In
(Of_Set
, SN
(Subset_Node
)) then
908 Subset_Node
:= HT_Ops
.Next
(Subset
, Subset_Node
);
920 Process
: not null access procedure (Position
: Cursor
))
922 procedure Process_Node
(Node
: Count_Type
);
923 pragma Inline
(Process_Node
);
926 new HT_Ops
.Generic_Iteration
(Process_Node
);
932 procedure Process_Node
(Node
: Count_Type
) is
934 Process
(Cursor
'(Container'Unrestricted_Access, Node));
937 B : Natural renames Container'Unrestricted_Access.all.Busy;
939 -- Start of processing for Iterate
955 function Iterate (Container : Set)
956 return Set_Iterator_Interfaces.Forward_Iterator'Class
958 B : Natural renames Container'Unrestricted_Access.all.Busy;
961 return It : constant Iterator :=
962 Iterator'(Limited_Controlled
with
963 Container
=> Container
'Unrestricted_Access);
970 function Length
(Container
: Set
) return Count_Type
is
972 return Container
.Length
;
979 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
981 if Target
'Address = Source
'Address then
985 if Source
.Busy
> 0 then
986 raise Program_Error
with
987 "attempt to tamper with cursors (container is busy)";
990 Target
.Assign
(Source
);
998 function Next
(Node
: Node_Type
) return Count_Type
is
1003 function Next
(Position
: Cursor
) return Cursor
is
1005 if Position
.Node
= 0 then
1009 pragma Assert
(Vet
(Position
), "bad cursor in Next");
1012 HT
: Set
renames Position
.Container
.all;
1013 Node
: constant Count_Type
:= HT_Ops
.Next
(HT
, Position
.Node
);
1020 return Cursor
'(Position.Container, Node);
1024 procedure Next (Position : in out Cursor) is
1026 Position := Next (Position);
1031 Position : Cursor) return Cursor
1034 if Position.Container = null then
1038 if Position.Container /= Object.Container then
1039 raise Program_Error with
1040 "Position cursor of Next designates wrong set";
1043 return Next (Position);
1050 function Overlap (Left, Right : Set) return Boolean is
1051 Left_Node : Count_Type;
1054 if Right.Length = 0 then
1058 if Left'Address = Right'Address then
1062 Left_Node := HT_Ops.First (Left);
1063 while Left_Node /= 0 loop
1064 if Is_In (Right, Left.Nodes (Left_Node)) then
1067 Left_Node := HT_Ops.Next (Left, Left_Node);
1077 procedure Query_Element
1079 Process : not null access procedure (Element : Element_Type))
1082 if Position.Node = 0 then
1083 raise Constraint_Error with
1084 "Position cursor of Query_Element equals No_Element";
1087 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1090 S : Set renames Position.Container.all;
1091 B : Natural renames S.Busy;
1092 L : Natural renames S.Lock;
1099 Process (S.Nodes (Position.Node).Element);
1117 (Stream : not null access Root_Stream_Type'Class;
1118 Container : out Set)
1120 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1123 procedure Read_Nodes is
1124 new HT_Ops.Generic_Read (Read_Node);
1130 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1133 procedure Read_Element (Node : in out Node_Type);
1134 pragma Inline (Read_Element);
1136 procedure Allocate is
1137 new HT_Ops.Generic_Allocate (Read_Element);
1139 procedure Read_Element (Node : in out Node_Type) is
1141 Element_Type'Read (Stream, Node.Element);
1146 -- Start of processing for Read_Node
1149 Allocate (Container, Node);
1153 -- Start of processing for Read
1156 Read_Nodes (Stream, Container);
1160 (Stream : not null access Root_Stream_Type'Class;
1164 raise Program_Error with "attempt to stream set cursor";
1168 (Stream : not null access Root_Stream_Type'Class;
1169 Item : out Constant_Reference_Type)
1172 raise Program_Error with "attempt to stream reference";
1180 (Container : in out Set;
1181 New_Item : Element_Type)
1183 Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
1187 raise Constraint_Error with
1188 "attempt to replace element not in set";
1191 if Container.Lock > 0 then
1192 raise Program_Error with
1193 "attempt to tamper with elements (set is locked)";
1196 Container.Nodes (Node).Element := New_Item;
1199 procedure Replace_Element
1200 (Container : in out Set;
1202 New_Item : Element_Type)
1205 if Position.Node = 0 then
1206 raise Constraint_Error with
1207 "Position cursor equals No_Element";
1210 if Position.Container /= Container'Unrestricted_Access then
1211 raise Program_Error with
1212 "Position cursor designates wrong set";
1215 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1217 Replace_Element (Container, Position.Node, New_Item);
1218 end Replace_Element;
1220 ----------------------
1221 -- Reserve_Capacity --
1222 ----------------------
1224 procedure Reserve_Capacity
1225 (Container : in out Set;
1226 Capacity : Count_Type)
1229 if Capacity > Container.Capacity then
1230 raise Capacity_Error with "requested capacity is too large";
1232 end Reserve_Capacity;
1238 procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is
1240 Node.Element := Item;
1247 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
1252 --------------------------
1253 -- Symmetric_Difference --
1254 --------------------------
1256 procedure Symmetric_Difference
1257 (Target : in out Set;
1260 procedure Process (Source_Node : Count_Type);
1261 pragma Inline (Process);
1263 procedure Iterate is
1264 new HT_Ops.Generic_Iteration (Process);
1270 procedure Process (Source_Node : Count_Type) is
1271 N : Node_Type renames Source.Nodes (Source_Node);
1276 if Is_In (Target, N) then
1277 Delete (Target, N.Element);
1279 Insert (Target, N.Element, X, B);
1284 -- Start of processing for Symmetric_Difference
1287 if Target'Address = Source'Address then
1288 HT_Ops.Clear (Target);
1292 if Target.Length = 0 then
1293 Assign (Target => Target, Source => Source);
1297 if Target.Busy > 0 then
1298 raise Program_Error with
1299 "attempt to tamper with cursors (set is busy)";
1303 end Symmetric_Difference;
1305 function Symmetric_Difference (Left, Right : Set) return Set is
1309 if Left'Address = Right'Address then
1313 if Right.Length = 0 then
1317 if Left.Length = 0 then
1321 C := Left.Length + Right.Length;
1323 return Result : Set (C, To_Prime (C)) do
1324 Iterate_Left : declare
1325 procedure Process (L_Node : Count_Type);
1327 procedure Iterate is
1328 new HT_Ops.Generic_Iteration (Process);
1334 procedure Process (L_Node : Count_Type) is
1335 N : Node_Type renames Left.Nodes (L_Node);
1339 if not Is_In (Right, N) then
1340 Insert (Result, N.Element, X, B);
1345 -- Start of processing for Iterate_Left
1351 Iterate_Right : declare
1352 procedure Process (R_Node : Count_Type);
1354 procedure Iterate is
1355 new HT_Ops.Generic_Iteration (Process);
1361 procedure Process (R_Node : Count_Type) is
1362 N : Node_Type renames Right.Nodes (R_Node);
1366 if not Is_In (Left, N) then
1367 Insert (Result, N.Element, X, B);
1372 -- Start of processing for Iterate_Right
1378 end Symmetric_Difference;
1384 function To_Set (New_Item : Element_Type) return Set is
1388 return Result : Set (1, 1) do
1389 Insert (Result, New_Item, X, B);
1399 (Target : in out Set;
1402 procedure Process (Src_Node : Count_Type);
1404 procedure Iterate is
1405 new HT_Ops.Generic_Iteration (Process);
1411 procedure Process (Src_Node : Count_Type) is
1412 N : Node_Type renames Source.Nodes (Src_Node);
1416 Insert (Target, N.Element, X, B);
1419 -- Start of processing for Union
1422 if Target'Address = Source'Address then
1426 if Target.Busy > 0 then
1427 raise Program_Error with
1428 "attempt to tamper with cursors (set is busy)";
1431 -- ??? why is this code commented out ???
1433 -- N : constant Count_Type := Target.Length + Source.Length;
1435 -- if N > HT_Ops.Capacity (Target.HT) then
1436 -- HT_Ops.Reserve_Capacity (Target.HT, N);
1443 function Union (Left, Right : Set) return Set is
1447 if Left'Address = Right'Address then
1451 if Right.Length = 0 then
1455 if Left.Length = 0 then
1459 C := Left.Length + Right.Length;
1461 return Result : Set (C, To_Prime (C)) do
1462 Assign (Target => Result, Source => Left);
1463 Union (Target => Result, Source => Right);
1471 function Vet (Position : Cursor) return Boolean is
1473 if Position.Node = 0 then
1474 return Position.Container = null;
1477 if Position.Container = null then
1482 S : Set renames Position.Container.all;
1483 N : Nodes_Type renames S.Nodes;
1487 if S.Length = 0 then
1491 if Position.Node > N'Last then
1495 if N (Position.Node).Next = Position.Node then
1499 X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element));
1501 for J in 1 .. S.Length loop
1502 if X = Position.Node then
1510 if X = N (X).Next then -- to prevent unnecessary looping
1526 (Stream : not null access Root_Stream_Type'Class;
1529 procedure Write_Node
1530 (Stream : not null access Root_Stream_Type'Class;
1532 pragma Inline (Write_Node);
1534 procedure Write_Nodes is
1535 new HT_Ops.Generic_Write (Write_Node);
1541 procedure Write_Node
1542 (Stream : not null access Root_Stream_Type'Class;
1546 Element_Type'Write (Stream, Node.Element);
1549 -- Start of processing for Write
1552 Write_Nodes (Stream, Container);
1556 (Stream : not null access Root_Stream_Type'Class;
1560 raise Program_Error with "attempt to stream set cursor";
1564 (Stream : not null access Root_Stream_Type'Class;
1565 Item : Constant_Reference_Type)
1568 raise Program_Error with "attempt to stream reference";
1571 package body Generic_Keys is
1573 -----------------------
1574 -- Local Subprograms --
1575 -----------------------
1577 function Equivalent_Key_Node
1579 Node : Node_Type) return Boolean;
1580 pragma Inline (Equivalent_Key_Node);
1582 --------------------------
1583 -- Local Instantiations --
1584 --------------------------
1587 new Hash_Tables.Generic_Bounded_Keys
1588 (HT_Types => HT_Types,
1590 Set_Next => Set_Next,
1591 Key_Type => Key_Type,
1593 Equivalent_Keys => Equivalent_Key_Node);
1595 ------------------------
1596 -- Constant_Reference --
1597 ------------------------
1599 function Constant_Reference
1600 (Container : aliased Set;
1601 Key : Key_Type) return Constant_Reference_Type
1603 Node : constant Count_Type := Key_Keys.Find (Container, Key);
1607 raise Constraint_Error with "key not in set";
1611 N : Node_Type renames Container.Nodes (Node);
1613 return (Element => N.Element'Access);
1615 end Constant_Reference;
1623 Key : Key_Type) return Boolean
1626 return Find (Container, Key) /= No_Element;
1634 (Container : in out Set;
1640 Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1643 raise Constraint_Error with "attempt to delete key not in set";
1646 HT_Ops.Free (Container, X);
1655 Key : Key_Type) return Element_Type
1657 Node : constant Count_Type := Key_Keys.Find (Container, Key);
1661 raise Constraint_Error with "key not in map"; -- ??? "set"
1664 return Container.Nodes (Node).Element;
1667 -------------------------
1668 -- Equivalent_Key_Node --
1669 -------------------------
1671 function Equivalent_Key_Node
1673 Node : Node_Type) return Boolean
1676 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1677 end Equivalent_Key_Node;
1684 (Container : in out Set;
1689 Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1690 HT_Ops.Free (Container, X);
1699 Key : Key_Type) return Cursor
1701 Node : constant Count_Type := Key_Keys.Find (Container, Key);
1703 return (if Node = 0 then No_Element
1704 else Cursor'(Container
'Unrestricted_Access, Node
));
1711 function Key
(Position
: Cursor
) return Key_Type
is
1713 if Position
.Node
= 0 then
1714 raise Constraint_Error
with
1715 "Position cursor equals No_Element";
1718 pragma Assert
(Vet
(Position
), "bad cursor in function Key");
1719 return Key
(Position
.Container
.Nodes
(Position
.Node
).Element
);
1727 (Stream
: not null access Root_Stream_Type
'Class;
1728 Item
: out Reference_Type
)
1731 raise Program_Error
with "attempt to stream reference";
1734 ------------------------------
1735 -- Reference_Preserving_Key --
1736 ------------------------------
1738 function Reference_Preserving_Key
1739 (Container
: aliased in out Set
;
1740 Position
: Cursor
) return Reference_Type
1743 if Position
.Container
= null then
1744 raise Constraint_Error
with "Position cursor has no element";
1747 if Position
.Container
/= Container
'Unrestricted_Access then
1748 raise Program_Error
with
1749 "Position cursor designates wrong container";
1754 "bad cursor in function Reference_Preserving_Key");
1756 -- Some form of finalization will be required in order to actually
1757 -- check that the key-part of the element designated by Position has
1761 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
1763 return (Element
=> N
.Element
'Access);
1765 end Reference_Preserving_Key
;
1767 function Reference_Preserving_Key
1768 (Container
: aliased in out Set
;
1769 Key
: Key_Type
) return Reference_Type
1771 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
1775 raise Constraint_Error
with "key not in set";
1779 N
: Node_Type
renames Container
.Nodes
(Node
);
1781 return (Element
=> N
.Element
'Access);
1783 end Reference_Preserving_Key
;
1790 (Container
: in out Set
;
1792 New_Item
: Element_Type
)
1794 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
1798 raise Constraint_Error
with
1799 "attempt to replace key not in set";
1802 Replace_Element
(Container
, Node
, New_Item
);
1805 -----------------------------------
1806 -- Update_Element_Preserving_Key --
1807 -----------------------------------
1809 procedure Update_Element_Preserving_Key
1810 (Container
: in out Set
;
1812 Process
: not null access
1813 procedure (Element
: in out Element_Type
))
1816 N
: Nodes_Type
renames Container
.Nodes
;
1819 if Position
.Node
= 0 then
1820 raise Constraint_Error
with
1821 "Position cursor equals No_Element";
1824 if Position
.Container
/= Container
'Unrestricted_Access then
1825 raise Program_Error
with
1826 "Position cursor designates wrong set";
1829 -- ??? why is this code commented out ???
1830 -- if HT.Buckets = null
1831 -- or else HT.Buckets'Length = 0
1832 -- or else HT.Length = 0
1833 -- or else Position.Node.Next = Position.Node
1835 -- raise Program_Error with
1836 -- "Position cursor is bad (set is empty)";
1841 "bad cursor in Update_Element_Preserving_Key");
1843 -- Record bucket now, in case key is changed
1845 Indx
:= HT_Ops
.Index
(Container
.Buckets
, N
(Position
.Node
));
1848 E
: Element_Type
renames N
(Position
.Node
).Element
;
1849 K
: constant Key_Type
:= Key
(E
);
1851 B
: Natural renames Container
.Busy
;
1852 L
: Natural renames Container
.Lock
;
1870 if Equivalent_Keys
(K
, Key
(E
)) then
1871 pragma Assert
(Hash
(K
) = Hash
(E
));
1876 -- Key was modified, so remove this node from set.
1878 if Container
.Buckets
(Indx
) = Position
.Node
then
1879 Container
.Buckets
(Indx
) := N
(Position
.Node
).Next
;
1883 Prev
: Count_Type
:= Container
.Buckets
(Indx
);
1886 while N
(Prev
).Next
/= Position
.Node
loop
1887 Prev
:= N
(Prev
).Next
;
1890 raise Program_Error
with
1891 "Position cursor is bad (node not found)";
1895 N
(Prev
).Next
:= N
(Position
.Node
).Next
;
1899 Container
.Length
:= Container
.Length
- 1;
1900 HT_Ops
.Free
(Container
, Position
.Node
);
1902 raise Program_Error
with "key was modified";
1903 end Update_Element_Preserving_Key
;
1910 (Stream
: not null access Root_Stream_Type
'Class;
1911 Item
: Reference_Type
)
1914 raise Program_Error
with "attempt to stream reference";
1919 end Ada
.Containers
.Bounded_Hashed_Sets
;