1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S --
9 -- Copyright (C) 2010-2018, 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/>. --
26 ------------------------------------------------------------------------------
28 with Ada
.Containers
.Hash_Tables
.Generic_Bounded_Operations
;
29 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Bounded_Operations
);
31 with Ada
.Containers
.Hash_Tables
.Generic_Bounded_Keys
;
32 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Bounded_Keys
);
34 with Ada
.Containers
.Prime_Numbers
; use Ada
.Containers
.Prime_Numbers
;
36 with System
; use type System
.Address
;
38 package body Ada
.Containers
.Formal_Hashed_Sets
with
41 -----------------------
42 -- Local Subprograms --
43 -----------------------
45 -- All need comments ???
47 procedure Difference
(Left
: Set
; Right
: Set
; Target
: in out Set
);
49 function Equivalent_Keys
51 Node
: Node_Type
) return Boolean;
52 pragma Inline
(Equivalent_Keys
);
59 with procedure Set_Element
(Node
: in out Node_Type
);
60 procedure Generic_Allocate
62 Node
: out Count_Type
);
64 function Hash_Node
(Node
: Node_Type
) return Hash_Type
;
65 pragma Inline
(Hash_Node
);
68 (Container
: in out Set
;
69 New_Item
: Element_Type
;
70 Node
: out Count_Type
;
71 Inserted
: out Boolean);
73 procedure Intersection
80 Key
: Node_Type
) return Boolean;
81 pragma Inline
(Is_In
);
83 procedure Set_Element
(Node
: in out Node_Type
; Item
: Element_Type
);
84 pragma Inline
(Set_Element
);
86 function Next
(Node
: Node_Type
) return Count_Type
;
89 procedure Set_Next
(Node
: in out Node_Type
; Next
: Count_Type
);
90 pragma Inline
(Set_Next
);
92 function Vet
(Container
: Set
; Position
: Cursor
) return Boolean;
94 --------------------------
95 -- Local Instantiations --
96 --------------------------
98 package HT_Ops
is new Hash_Tables
.Generic_Bounded_Operations
99 (HT_Types
=> HT_Types
,
100 Hash_Node
=> Hash_Node
,
102 Set_Next
=> Set_Next
);
104 package Element_Keys
is new Hash_Tables
.Generic_Bounded_Keys
105 (HT_Types
=> HT_Types
,
107 Set_Next
=> Set_Next
,
108 Key_Type
=> Element_Type
,
110 Equivalent_Keys
=> Equivalent_Keys
);
112 procedure Replace_Element
is
113 new Element_Keys
.Generic_Replace_Element
(Hash_Node
, Set_Element
);
119 function "=" (Left
, Right
: Set
) return Boolean is
121 if Length
(Left
) /= Length
(Right
) then
125 if Length
(Left
) = 0 then
134 Node
:= First
(Left
).Node
;
139 Item
=> Left
.Nodes
(Node
).Element
).Node
;
142 or else Right
.Nodes
(ENode
).Element
/= Left
.Nodes
(Node
).Element
147 Node
:= HT_Ops
.Next
(Left
, Node
);
158 procedure Assign
(Target
: in out Set
; Source
: Set
) is
159 procedure Insert_Element
(Source_Node
: Count_Type
);
161 procedure Insert_Elements
is
162 new HT_Ops
.Generic_Iteration
(Insert_Element
);
168 procedure Insert_Element
(Source_Node
: Count_Type
) is
169 N
: Node_Type
renames Source
.Nodes
(Source_Node
);
174 Insert
(Target
, N
.Element
, X
, B
);
178 -- Start of processing for Assign
181 if Target
'Address = Source
'Address then
185 if Target
.Capacity
< Length
(Source
) then
186 raise Storage_Error
with "not enough capacity"; -- SE or CE? ???
189 HT_Ops
.Clear
(Target
);
190 Insert_Elements
(Source
);
197 function Capacity
(Container
: Set
) return Count_Type
is
199 return Container
.Nodes
'Length;
206 procedure Clear
(Container
: in out Set
) is
208 HT_Ops
.Clear
(Container
);
215 function Contains
(Container
: Set
; Item
: Element_Type
) return Boolean is
217 return Find
(Container
, Item
) /= No_Element
;
226 Capacity
: Count_Type
:= 0) return Set
228 C
: constant Count_Type
:=
229 Count_Type
'Max (Capacity
, Source
.Capacity
);
233 Target
: Set
(C
, Source
.Modulus
);
236 if 0 < Capacity
and then Capacity
< Source
.Capacity
then
237 raise Capacity_Error
;
240 Target
.Length
:= Source
.Length
;
241 Target
.Free
:= Source
.Free
;
244 while H
<= Source
.Modulus
loop
245 Target
.Buckets
(H
) := Source
.Buckets
(H
);
250 while N
<= Source
.Capacity
loop
251 Target
.Nodes
(N
) := Source
.Nodes
(N
);
257 Free
(Target
, Cu
.Node
);
264 ---------------------
265 -- Default_Modulus --
266 ---------------------
268 function Default_Modulus
(Capacity
: Count_Type
) return Hash_Type
is
270 return To_Prime
(Capacity
);
277 procedure Delete
(Container
: in out Set
; Item
: Element_Type
) is
281 Element_Keys
.Delete_Key_Sans_Free
(Container
, Item
, X
);
284 raise Constraint_Error
with "attempt to delete element not in set";
290 procedure Delete
(Container
: in out Set
; Position
: in out Cursor
) is
292 if not Has_Element
(Container
, Position
) then
293 raise Constraint_Error
with "Position cursor has no element";
296 pragma Assert
(Vet
(Container
, Position
), "bad cursor in Delete");
298 HT_Ops
.Delete_Node_Sans_Free
(Container
, Position
.Node
);
299 Free
(Container
, Position
.Node
);
301 Position
:= No_Element
;
308 procedure Difference
(Target
: in out Set
; Source
: Set
) is
309 Src_Last
: Count_Type
;
310 Src_Length
: Count_Type
;
311 Src_Node
: Count_Type
;
312 Tgt_Node
: Count_Type
;
314 TN
: Nodes_Type
renames Target
.Nodes
;
315 SN
: Nodes_Type
renames Source
.Nodes
;
318 if Target
'Address = Source
'Address then
323 Src_Length
:= Source
.Length
;
325 if Src_Length
= 0 then
329 if Src_Length
>= Target
.Length
then
330 Tgt_Node
:= HT_Ops
.First
(Target
);
331 while Tgt_Node
/= 0 loop
332 if Element_Keys
.Find
(Source
, TN
(Tgt_Node
).Element
) /= 0 then
334 X
: constant Count_Type
:= Tgt_Node
;
336 Tgt_Node
:= HT_Ops
.Next
(Target
, Tgt_Node
);
337 HT_Ops
.Delete_Node_Sans_Free
(Target
, X
);
342 Tgt_Node
:= HT_Ops
.Next
(Target
, Tgt_Node
);
348 Src_Node
:= HT_Ops
.First
(Source
);
352 while Src_Node
/= Src_Last
loop
353 Tgt_Node
:= Element_Keys
.Find
(Target
, SN
(Src_Node
).Element
);
355 if Tgt_Node
/= 0 then
356 HT_Ops
.Delete_Node_Sans_Free
(Target
, Tgt_Node
);
357 Free
(Target
, Tgt_Node
);
360 Src_Node
:= HT_Ops
.Next
(Source
, Src_Node
);
364 procedure Difference
(Left
: Set
; Right
: Set
; Target
: in out Set
) is
365 procedure Process
(L_Node
: Count_Type
);
368 new HT_Ops
.Generic_Iteration
(Process
);
374 procedure Process
(L_Node
: Count_Type
) is
376 E
: Element_Type
renames Left
.Nodes
(L_Node
).Element
;
380 if Find
(Right
, E
).Node
= 0 then
381 Insert
(Target
, E
, X
, B
);
386 -- Start of processing for Difference
392 function Difference
(Left
: Set
; Right
: Set
) return Set
is
397 if Left
'Address = Right
'Address then
401 if Length
(Left
) = 0 then
405 if Length
(Right
) = 0 then
410 H
:= Default_Modulus
(C
);
412 return S
: Set
(C
, H
) do
413 Difference
(Left
, Right
, Target
=> S
);
423 Position
: Cursor
) return Element_Type
426 if not Has_Element
(Container
, Position
) then
427 raise Constraint_Error
with "Position cursor equals No_Element";
431 (Vet
(Container
, Position
), "bad cursor in function Element");
433 return Container
.Nodes
(Position
.Node
).Element
;
436 ---------------------
437 -- Equivalent_Sets --
438 ---------------------
440 function Equivalent_Sets
(Left
, Right
: Set
) return Boolean is
442 function Find_Equivalent_Key
443 (R_HT
: Hash_Table_Type
'Class;
444 L_Node
: Node_Type
) return Boolean;
445 pragma Inline
(Find_Equivalent_Key
);
447 function Is_Equivalent
is
448 new HT_Ops
.Generic_Equal
(Find_Equivalent_Key
);
450 -------------------------
451 -- Find_Equivalent_Key --
452 -------------------------
454 function Find_Equivalent_Key
455 (R_HT
: Hash_Table_Type
'Class;
456 L_Node
: Node_Type
) return Boolean
458 R_Index
: constant Hash_Type
:=
459 Element_Keys
.Index
(R_HT
, L_Node
.Element
);
460 R_Node
: Count_Type
:= R_HT
.Buckets
(R_Index
);
461 RN
: Nodes_Type
renames R_HT
.Nodes
;
469 if Equivalent_Elements
470 (L_Node
.Element
, RN
(R_Node
).Element
)
475 R_Node
:= HT_Ops
.Next
(R_HT
, R_Node
);
477 end Find_Equivalent_Key
;
479 -- Start of processing for Equivalent_Sets
482 return Is_Equivalent
(Left
, Right
);
485 ---------------------
486 -- Equivalent_Keys --
487 ---------------------
489 function Equivalent_Keys
491 Node
: Node_Type
) return Boolean
494 return Equivalent_Elements
(Key
, Node
.Element
);
501 procedure Exclude
(Container
: in out Set
; Item
: Element_Type
) is
504 Element_Keys
.Delete_Key_Sans_Free
(Container
, Item
, X
);
514 Item
: Element_Type
) return Cursor
516 Node
: constant Count_Type
:= Element_Keys
.Find
(Container
, Item
);
523 return (Node
=> Node
);
530 function First
(Container
: Set
) return Cursor
is
531 Node
: constant Count_Type
:= HT_Ops
.First
(Container
);
538 return (Node
=> Node
);
545 package body Formal_Model
is
547 -------------------------
548 -- E_Elements_Included --
549 -------------------------
551 function E_Elements_Included
553 Right
: E
.Sequence
) return Boolean
556 for I
in 1 .. E
.Length
(Left
) loop
557 if not E
.Contains
(Right
, 1, E
.Length
(Right
), E
.Get
(Left
, I
))
564 end E_Elements_Included
;
566 function E_Elements_Included
569 Right
: E
.Sequence
) return Boolean
572 for I
in 1 .. E
.Length
(Left
) loop
574 Item
: constant Element_Type
:= E
.Get
(Left
, I
);
576 if M
.Contains
(Model
, Item
) then
577 if not E
.Contains
(Right
, 1, E
.Length
(Right
), Item
) then
585 end E_Elements_Included
;
587 function E_Elements_Included
588 (Container
: E
.Sequence
;
591 Right
: E
.Sequence
) return Boolean
594 for I
in 1 .. E
.Length
(Container
) loop
596 Item
: constant Element_Type
:= E
.Get
(Container
, I
);
598 if M
.Contains
(Model
, Item
) then
599 if not E
.Contains
(Left
, 1, E
.Length
(Left
), Item
) then
603 if not E
.Contains
(Right
, 1, E
.Length
(Right
), Item
) then
611 end E_Elements_Included
;
618 (Container
: E
.Sequence
;
619 Item
: Element_Type
) return Count_Type
622 for I
in 1 .. E
.Length
(Container
) loop
623 if Equivalent_Elements
(Item
, E
.Get
(Container
, I
)) then
634 function Elements
(Container
: Set
) return E
.Sequence
is
635 Position
: Count_Type
:= HT_Ops
.First
(Container
);
639 -- Can't use First, Next or Element here, since they depend on models
640 -- for their postconditions.
642 while Position
/= 0 loop
643 R
:= E
.Add
(R
, Container
.Nodes
(Position
).Element
);
644 Position
:= HT_Ops
.Next
(Container
, Position
);
650 ----------------------------
651 -- Lift_Abstraction_Level --
652 ----------------------------
654 procedure Lift_Abstraction_Level
(Container
: Set
) is null;
656 -----------------------
657 -- Mapping_Preserved --
658 -----------------------
660 function Mapping_Preserved
661 (E_Left
: E
.Sequence
;
662 E_Right
: E
.Sequence
;
664 P_Right
: P
.Map
) return Boolean
668 if not P
.Has_Key
(P_Right
, C
)
669 or else P
.Get
(P_Left
, C
) > E
.Length
(E_Left
)
670 or else P
.Get
(P_Right
, C
) > E
.Length
(E_Right
)
671 or else E
.Get
(E_Left
, P
.Get
(P_Left
, C
)) /=
672 E
.Get
(E_Right
, P
.Get
(P_Right
, C
))
679 end Mapping_Preserved
;
681 ------------------------------
682 -- Mapping_Preserved_Except --
683 ------------------------------
685 function Mapping_Preserved_Except
686 (E_Left
: E
.Sequence
;
687 E_Right
: E
.Sequence
;
690 Position
: Cursor
) return Boolean
695 and (not P
.Has_Key
(P_Right
, C
)
696 or else P
.Get
(P_Left
, C
) > E
.Length
(E_Left
)
697 or else P
.Get
(P_Right
, C
) > E
.Length
(E_Right
)
698 or else E
.Get
(E_Left
, P
.Get
(P_Left
, C
)) /=
699 E
.Get
(E_Right
, P
.Get
(P_Right
, C
)))
706 end Mapping_Preserved_Except
;
712 function Model
(Container
: Set
) return M
.Set
is
713 Position
: Count_Type
:= HT_Ops
.First
(Container
);
717 -- Can't use First, Next or Element here, since they depend on models
718 -- for their postconditions.
720 while Position
/= 0 loop
724 Item
=> Container
.Nodes
(Position
).Element
);
726 Position
:= HT_Ops
.Next
(Container
, Position
);
736 function Positions
(Container
: Set
) return P
.Map
is
738 Position
: Count_Type
:= HT_Ops
.First
(Container
);
742 -- Can't use First, Next or Element here, since they depend on models
743 -- for their postconditions.
745 while Position
/= 0 loop
746 R
:= P
.Add
(R
, (Node
=> Position
), I
);
747 pragma Assert
(P
.Length
(R
) = I
);
748 Position
:= HT_Ops
.Next
(Container
, Position
);
761 procedure Free
(HT
: in out Set
; X
: Count_Type
) is
763 HT
.Nodes
(X
).Has_Element
:= False;
767 ----------------------
768 -- Generic_Allocate --
769 ----------------------
771 procedure Generic_Allocate
(HT
: in out Set
; Node
: out Count_Type
) is
772 procedure Allocate
is new HT_Ops
.Generic_Allocate
(Set_Element
);
775 HT
.Nodes
(Node
).Has_Element
:= True;
776 end Generic_Allocate
;
778 package body Generic_Keys
with SPARK_Mode
=> Off
is
780 -----------------------
781 -- Local Subprograms --
782 -----------------------
784 function Equivalent_Key_Node
786 Node
: Node_Type
) return Boolean;
787 pragma Inline
(Equivalent_Key_Node
);
789 --------------------------
790 -- Local Instantiations --
791 --------------------------
793 package Key_Keys
is new Hash_Tables
.Generic_Bounded_Keys
794 (HT_Types
=> HT_Types
,
796 Set_Next
=> Set_Next
,
797 Key_Type
=> Key_Type
,
799 Equivalent_Keys
=> Equivalent_Key_Node
);
807 Key
: Key_Type
) return Boolean
810 return Find
(Container
, Key
) /= No_Element
;
817 procedure Delete
(Container
: in out Set
; Key
: Key_Type
) is
821 Key_Keys
.Delete_Key_Sans_Free
(Container
, Key
, X
);
824 raise Constraint_Error
with "attempt to delete key not in set";
836 Key
: Key_Type
) return Element_Type
838 Node
: constant Count_Type
:= Find
(Container
, Key
).Node
;
842 raise Constraint_Error
with "key not in map";
845 return Container
.Nodes
(Node
).Element
;
848 -------------------------
849 -- Equivalent_Key_Node --
850 -------------------------
852 function Equivalent_Key_Node
854 Node
: Node_Type
) return Boolean
857 return Equivalent_Keys
(Key
, Generic_Keys
.Key
(Node
.Element
));
858 end Equivalent_Key_Node
;
864 procedure Exclude
(Container
: in out Set
; Key
: Key_Type
) is
867 Key_Keys
.Delete_Key_Sans_Free
(Container
, Key
, X
);
877 Key
: Key_Type
) return Cursor
879 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
881 return (if Node
= 0 then No_Element
else (Node
=> Node
));
888 package body Formal_Model
is
890 -----------------------
891 -- M_Included_Except --
892 -----------------------
894 function M_Included_Except
897 Key
: Key_Type
) return Boolean
901 if not Contains
(Right
, E
)
902 and not Equivalent_Keys
(Generic_Keys
.Key
(E
), Key
)
909 end M_Included_Except
;
917 function Key
(Container
: Set
; Position
: Cursor
) return Key_Type
is
919 if not Has_Element
(Container
, Position
) then
920 raise Constraint_Error
with "Position cursor has no element";
924 (Vet
(Container
, Position
), "bad cursor in function Key");
927 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
929 return Key
(N
.Element
);
938 (Container
: in out Set
;
940 New_Item
: Element_Type
)
942 Node
: constant Count_Type
:= Key_Keys
.Find
(Container
, Key
);
946 raise Constraint_Error
with "attempt to replace key not in set";
949 Replace_Element
(Container
, Node
, New_Item
);
958 function Has_Element
(Container
: Set
; Position
: Cursor
) return Boolean is
961 or else not Container
.Nodes
(Position
.Node
).Has_Element
973 function Hash_Node
(Node
: Node_Type
) return Hash_Type
is
975 return Hash
(Node
.Element
);
982 procedure Include
(Container
: in out Set
; New_Item
: Element_Type
) is
987 Insert
(Container
, New_Item
, Position
, Inserted
);
990 Container
.Nodes
(Position
.Node
).Element
:= New_Item
;
999 (Container
: in out Set
;
1000 New_Item
: Element_Type
;
1001 Position
: out Cursor
;
1002 Inserted
: out Boolean)
1005 Insert
(Container
, New_Item
, Position
.Node
, Inserted
);
1008 procedure Insert
(Container
: in out Set
; New_Item
: Element_Type
) is
1013 Insert
(Container
, New_Item
, Position
, Inserted
);
1015 if not Inserted
then
1016 raise Constraint_Error
with
1017 "attempt to insert element already in set";
1022 (Container
: in out Set
;
1023 New_Item
: Element_Type
;
1024 Node
: out Count_Type
;
1025 Inserted
: out Boolean)
1027 procedure Allocate_Set_Element
(Node
: in out Node_Type
);
1028 pragma Inline
(Allocate_Set_Element
);
1030 function New_Node
return Count_Type
;
1031 pragma Inline
(New_Node
);
1033 procedure Local_Insert
is
1034 new Element_Keys
.Generic_Conditional_Insert
(New_Node
);
1036 procedure Allocate
is
1037 new Generic_Allocate
(Allocate_Set_Element
);
1039 ---------------------------
1040 -- Allocate_Set_Element --
1041 ---------------------------
1043 procedure Allocate_Set_Element
(Node
: in out Node_Type
) is
1045 Node
.Element
:= New_Item
;
1046 end Allocate_Set_Element
;
1052 function New_Node
return Count_Type
is
1053 Result
: Count_Type
;
1055 Allocate
(Container
, Result
);
1059 -- Start of processing for Insert
1062 Local_Insert
(Container
, New_Item
, Node
, Inserted
);
1069 procedure Intersection
(Target
: in out Set
; Source
: Set
) is
1070 Tgt_Node
: Count_Type
;
1071 TN
: Nodes_Type
renames Target
.Nodes
;
1074 if Target
'Address = Source
'Address then
1078 if Source
.Length
= 0 then
1083 Tgt_Node
:= HT_Ops
.First
(Target
);
1084 while Tgt_Node
/= 0 loop
1085 if Find
(Source
, TN
(Tgt_Node
).Element
).Node
/= 0 then
1086 Tgt_Node
:= HT_Ops
.Next
(Target
, Tgt_Node
);
1090 X
: constant Count_Type
:= Tgt_Node
;
1092 Tgt_Node
:= HT_Ops
.Next
(Target
, Tgt_Node
);
1093 HT_Ops
.Delete_Node_Sans_Free
(Target
, X
);
1100 procedure Intersection
(Left
: Set
; Right
: Set
; Target
: in out Set
) is
1101 procedure Process
(L_Node
: Count_Type
);
1103 procedure Iterate
is
1104 new HT_Ops
.Generic_Iteration
(Process
);
1110 procedure Process
(L_Node
: Count_Type
) is
1111 E
: Element_Type
renames Left
.Nodes
(L_Node
).Element
;
1116 if Find
(Right
, E
).Node
/= 0 then
1117 Insert
(Target
, E
, X
, B
);
1122 -- Start of processing for Intersection
1128 function Intersection
(Left
: Set
; Right
: Set
) return Set
is
1133 if Left
'Address = Right
'Address then
1137 C
:= Count_Type
'Min (Length
(Left
), Length
(Right
)); -- ???
1138 H
:= Default_Modulus
(C
);
1140 return S
: Set
(C
, H
) do
1141 if Length
(Left
) /= 0 and Length
(Right
) /= 0 then
1142 Intersection
(Left
, Right
, Target
=> S
);
1151 function Is_Empty
(Container
: Set
) return Boolean is
1153 return Length
(Container
) = 0;
1160 function Is_In
(HT
: Set
; Key
: Node_Type
) return Boolean is
1162 return Element_Keys
.Find
(HT
, Key
.Element
) /= 0;
1169 function Is_Subset
(Subset
: Set
; Of_Set
: Set
) return Boolean is
1170 Subset_Node
: Count_Type
;
1171 Subset_Nodes
: Nodes_Type
renames Subset
.Nodes
;
1174 if Subset
'Address = Of_Set
'Address then
1178 if Length
(Subset
) > Length
(Of_Set
) then
1182 Subset_Node
:= First
(Subset
).Node
;
1183 while Subset_Node
/= 0 loop
1185 N
: Node_Type
renames Subset_Nodes
(Subset_Node
);
1186 E
: Element_Type
renames N
.Element
;
1189 if Find
(Of_Set
, E
).Node
= 0 then
1194 Subset_Node
:= HT_Ops
.Next
(Subset
, Subset_Node
);
1204 function Length
(Container
: Set
) return Count_Type
is
1206 return Container
.Length
;
1215 procedure Move
(Target
: in out Set
; Source
: in out Set
) is
1216 NN
: HT_Types
.Nodes_Type
renames Source
.Nodes
;
1220 if Target
'Address = Source
'Address then
1224 if Target
.Capacity
< Length
(Source
) then
1225 raise Constraint_Error
with -- ???
1226 "Source length exceeds Target capacity";
1231 if Source
.Length
= 0 then
1235 X
:= HT_Ops
.First
(Source
);
1237 Insert
(Target
, NN
(X
).Element
); -- optimize???
1239 Y
:= HT_Ops
.Next
(Source
, X
);
1241 HT_Ops
.Delete_Node_Sans_Free
(Source
, X
);
1252 function Next
(Node
: Node_Type
) return Count_Type
is
1257 function Next
(Container
: Set
; Position
: Cursor
) return Cursor
is
1259 if Position
.Node
= 0 then
1263 if not Has_Element
(Container
, Position
) then
1264 raise Constraint_Error
with "Position has no element";
1267 pragma Assert
(Vet
(Container
, Position
), "bad cursor in Next");
1269 return (Node
=> HT_Ops
.Next
(Container
, Position
.Node
));
1272 procedure Next
(Container
: Set
; Position
: in out Cursor
) is
1274 Position
:= Next
(Container
, Position
);
1281 function Overlap
(Left
, Right
: Set
) return Boolean is
1282 Left_Node
: Count_Type
;
1283 Left_Nodes
: Nodes_Type
renames Left
.Nodes
;
1286 if Length
(Right
) = 0 or Length
(Left
) = 0 then
1290 if Left
'Address = Right
'Address then
1294 Left_Node
:= First
(Left
).Node
;
1295 while Left_Node
/= 0 loop
1297 N
: Node_Type
renames Left_Nodes
(Left_Node
);
1298 E
: Element_Type
renames N
.Element
;
1300 if Find
(Right
, E
).Node
/= 0 then
1305 Left_Node
:= HT_Ops
.Next
(Left
, Left_Node
);
1315 procedure Replace
(Container
: in out Set
; New_Item
: Element_Type
) is
1316 Node
: constant Count_Type
:= Element_Keys
.Find
(Container
, New_Item
);
1320 raise Constraint_Error
with "attempt to replace element not in set";
1323 Container
.Nodes
(Node
).Element
:= New_Item
;
1326 ---------------------
1327 -- Replace_Element --
1328 ---------------------
1330 procedure Replace_Element
1331 (Container
: in out Set
;
1333 New_Item
: Element_Type
)
1336 if not Has_Element
(Container
, Position
) then
1337 raise Constraint_Error
with "Position cursor equals No_Element";
1341 (Vet
(Container
, Position
), "bad cursor in Replace_Element");
1343 Replace_Element
(Container
, Position
.Node
, New_Item
);
1344 end Replace_Element
;
1346 ----------------------
1347 -- Reserve_Capacity --
1348 ----------------------
1350 procedure Reserve_Capacity
1351 (Container
: in out Set
;
1352 Capacity
: Count_Type
)
1355 if Capacity
> Container
.Capacity
then
1356 raise Constraint_Error
with "requested capacity is too large";
1358 end Reserve_Capacity
;
1364 procedure Set_Element
(Node
: in out Node_Type
; Item
: Element_Type
) is
1366 Node
.Element
:= Item
;
1373 procedure Set_Next
(Node
: in out Node_Type
; Next
: Count_Type
) is
1378 --------------------------
1379 -- Symmetric_Difference --
1380 --------------------------
1382 procedure Symmetric_Difference
(Target
: in out Set
; Source
: Set
) is
1383 procedure Process
(Source_Node
: Count_Type
);
1384 pragma Inline
(Process
);
1386 procedure Iterate
is new HT_Ops
.Generic_Iteration
(Process
);
1392 procedure Process
(Source_Node
: Count_Type
) is
1394 N
: Node_Type
renames Source
.Nodes
(Source_Node
);
1398 if Is_In
(Target
, N
) then
1399 Delete
(Target
, N
.Element
);
1401 Insert
(Target
, N
.Element
, X
, B
);
1406 -- Start of processing for Symmetric_Difference
1409 if Target
'Address = Source
'Address then
1414 if Length
(Target
) = 0 then
1415 Assign
(Target
, Source
);
1420 end Symmetric_Difference
;
1422 function Symmetric_Difference
(Left
: Set
; Right
: Set
) return Set
is
1427 if Left
'Address = Right
'Address then
1431 if Length
(Right
) = 0 then
1435 if Length
(Left
) = 0 then
1439 C
:= Length
(Left
) + Length
(Right
);
1440 H
:= Default_Modulus
(C
);
1442 return S
: Set
(C
, H
) do
1443 Difference
(Left
, Right
, S
);
1444 Difference
(Right
, Left
, S
);
1446 end Symmetric_Difference
;
1452 function To_Set
(New_Item
: Element_Type
) return Set
is
1457 return S
: Set
(Capacity
=> 1, Modulus
=> 1) do
1458 Insert
(S
, New_Item
, X
, B
);
1467 procedure Union
(Target
: in out Set
; Source
: Set
) is
1468 procedure Process
(Src_Node
: Count_Type
);
1470 procedure Iterate
is
1471 new HT_Ops
.Generic_Iteration
(Process
);
1477 procedure Process
(Src_Node
: Count_Type
) is
1478 N
: Node_Type
renames Source
.Nodes
(Src_Node
);
1479 E
: Element_Type
renames N
.Element
;
1485 Insert
(Target
, E
, X
, B
);
1488 -- Start of processing for Union
1491 if Target
'Address = Source
'Address then
1498 function Union
(Left
: Set
; Right
: Set
) return Set
is
1503 if Left
'Address = Right
'Address then
1507 if Length
(Right
) = 0 then
1511 if Length
(Left
) = 0 then
1515 C
:= Length
(Left
) + Length
(Right
);
1516 H
:= Default_Modulus
(C
);
1517 return S
: Set
(C
, H
) do
1518 Assign
(Target
=> S
, Source
=> Left
);
1519 Union
(Target
=> S
, Source
=> Right
);
1527 function Vet
(Container
: Set
; Position
: Cursor
) return Boolean is
1529 if Position
.Node
= 0 then
1534 S
: Set
renames Container
;
1535 N
: Nodes_Type
renames S
.Nodes
;
1539 if S
.Length
= 0 then
1543 if Position
.Node
> N
'Last then
1547 if N
(Position
.Node
).Next
= Position
.Node
then
1551 X
:= S
.Buckets
(Element_Keys
.Index
(S
, N
(Position
.Node
).Element
));
1553 for J
in 1 .. S
.Length
loop
1554 if X
= Position
.Node
then
1562 if X
= N
(X
).Next
then -- to prevent unnecessary looping
1573 end Ada
.Containers
.Formal_Hashed_Sets
;