File : a-cfhase.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
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 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2010-2015, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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 ------------------------------------------------------------------------------
27
28 with Ada.Containers.Hash_Tables.Generic_Bounded_Operations;
29 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
30
31 with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
32 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
33
34 with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
35
36 with System; use type System.Address;
37
38 package body Ada.Containers.Formal_Hashed_Sets with
39 SPARK_Mode => Off
40 is
41
42 -----------------------
43 -- Local Subprograms --
44 -----------------------
45
46 -- All need comments ???
47
48 procedure Difference
49 (Left, Right : Set;
50 Target : in out Set);
51
52 function Equivalent_Keys
53 (Key : Element_Type;
54 Node : Node_Type) return Boolean;
55 pragma Inline (Equivalent_Keys);
56
57 procedure Free
58 (HT : in out Set;
59 X : Count_Type);
60
61 generic
62 with procedure Set_Element (Node : in out Node_Type);
63 procedure Generic_Allocate
64 (HT : in out Set;
65 Node : out Count_Type);
66
67 function Hash_Node (Node : Node_Type) return Hash_Type;
68 pragma Inline (Hash_Node);
69
70 procedure Insert
71 (Container : in out Set;
72 New_Item : Element_Type;
73 Node : out Count_Type;
74 Inserted : out Boolean);
75
76 procedure Intersection
77 (Left : Set;
78 Right : Set;
79 Target : in out Set);
80
81 function Is_In
82 (HT : Set;
83 Key : Node_Type) return Boolean;
84 pragma Inline (Is_In);
85
86 procedure Set_Element (Node : in out Node_Type; Item : Element_Type);
87 pragma Inline (Set_Element);
88
89 function Next (Node : Node_Type) return Count_Type;
90 pragma Inline (Next);
91
92 procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
93 pragma Inline (Set_Next);
94
95 function Vet (Container : Set; Position : Cursor) return Boolean;
96
97 --------------------------
98 -- Local Instantiations --
99 --------------------------
100
101 package HT_Ops is new Hash_Tables.Generic_Bounded_Operations
102 (HT_Types => HT_Types,
103 Hash_Node => Hash_Node,
104 Next => Next,
105 Set_Next => Set_Next);
106
107 package Element_Keys is new Hash_Tables.Generic_Bounded_Keys
108 (HT_Types => HT_Types,
109 Next => Next,
110 Set_Next => Set_Next,
111 Key_Type => Element_Type,
112 Hash => Hash,
113 Equivalent_Keys => Equivalent_Keys);
114
115 procedure Replace_Element is
116 new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element);
117
118 ---------
119 -- "=" --
120 ---------
121
122 function "=" (Left, Right : Set) return Boolean is
123 begin
124 if Length (Left) /= Length (Right) then
125 return False;
126 end if;
127
128 if Length (Left) = 0 then
129 return True;
130 end if;
131
132 declare
133 Node : Count_Type;
134 ENode : Count_Type;
135
136 begin
137 Node := First (Left).Node;
138 while Node /= 0 loop
139 ENode := Find (Container => Right,
140 Item => Left.Nodes (Node).Element).Node;
141 if ENode = 0 or else
142 Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
143 then
144 return False;
145 end if;
146
147 Node := HT_Ops.Next (Left, Node);
148 end loop;
149
150 return True;
151
152 end;
153
154 end "=";
155
156 ------------
157 -- Assign --
158 ------------
159
160 procedure Assign (Target : in out Set; Source : Set) is
161 procedure Insert_Element (Source_Node : Count_Type);
162
163 procedure Insert_Elements is
164 new HT_Ops.Generic_Iteration (Insert_Element);
165
166 --------------------
167 -- Insert_Element --
168 --------------------
169
170 procedure Insert_Element (Source_Node : Count_Type) is
171 N : Node_Type renames Source.Nodes (Source_Node);
172 X : Count_Type;
173 B : Boolean;
174
175 begin
176 Insert (Target, N.Element, X, B);
177 pragma Assert (B);
178 end Insert_Element;
179
180 -- Start of processing for Assign
181
182 begin
183 if Target'Address = Source'Address then
184 return;
185 end if;
186
187 if Target.Capacity < Length (Source) then
188 raise Storage_Error with "not enough capacity"; -- SE or CE? ???
189 end if;
190
191 HT_Ops.Clear (Target);
192 Insert_Elements (Source);
193 end Assign;
194
195 --------------
196 -- Capacity --
197 --------------
198
199 function Capacity (Container : Set) return Count_Type is
200 begin
201 return Container.Nodes'Length;
202 end Capacity;
203
204 -----------
205 -- Clear --
206 -----------
207
208 procedure Clear (Container : in out Set) is
209 begin
210 HT_Ops.Clear (Container);
211 end Clear;
212
213 --------------
214 -- Contains --
215 --------------
216
217 function Contains (Container : Set; Item : Element_Type) return Boolean is
218 begin
219 return Find (Container, Item) /= No_Element;
220 end Contains;
221
222 ----------
223 -- Copy --
224 ----------
225
226 function Copy
227 (Source : Set;
228 Capacity : Count_Type := 0) return Set
229 is
230 C : constant Count_Type :=
231 Count_Type'Max (Capacity, Source.Capacity);
232 H : Hash_Type;
233 N : Count_Type;
234 Target : Set (C, Source.Modulus);
235 Cu : Cursor;
236
237 begin
238 if 0 < Capacity and then Capacity < Source.Capacity then
239 raise Capacity_Error;
240 end if;
241
242 Target.Length := Source.Length;
243 Target.Free := Source.Free;
244
245 H := 1;
246 while H <= Source.Modulus loop
247 Target.Buckets (H) := Source.Buckets (H);
248 H := H + 1;
249 end loop;
250
251 N := 1;
252 while N <= Source.Capacity loop
253 Target.Nodes (N) := Source.Nodes (N);
254 N := N + 1;
255 end loop;
256
257 while N <= C loop
258 Cu := (Node => N);
259 Free (Target, Cu.Node);
260 N := N + 1;
261 end loop;
262
263 return Target;
264 end Copy;
265
266 ---------------------
267 -- Current_To_Last --
268 ---------------------
269
270 function Current_To_Last (Container : Set; Current : Cursor) return Set is
271 Curs : Cursor := First (Container);
272 C : Set (Container.Capacity, Container.Modulus) :=
273 Copy (Container, Container.Capacity);
274 Node : Count_Type;
275
276 begin
277 if Curs = No_Element then
278 Clear (C);
279 return C;
280
281 elsif Current /= No_Element and not Has_Element (Container, Current) then
282 raise Constraint_Error;
283
284 else
285 while Curs.Node /= Current.Node loop
286 Node := Curs.Node;
287 Delete (C, Curs);
288 Curs := Next (Container, (Node => Node));
289 end loop;
290
291 return C;
292 end if;
293 end Current_To_Last;
294
295 ---------------------
296 -- Default_Modulus --
297 ---------------------
298
299 function Default_Modulus (Capacity : Count_Type) return Hash_Type is
300 begin
301 return To_Prime (Capacity);
302 end Default_Modulus;
303
304 ------------
305 -- Delete --
306 ------------
307
308 procedure Delete
309 (Container : in out Set;
310 Item : Element_Type)
311 is
312 X : Count_Type;
313
314 begin
315 Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
316
317 if X = 0 then
318 raise Constraint_Error with "attempt to delete element not in set";
319 end if;
320
321 Free (Container, X);
322 end Delete;
323
324 procedure Delete
325 (Container : in out Set;
326 Position : in out Cursor)
327 is
328 begin
329 if not Has_Element (Container, Position) then
330 raise Constraint_Error with "Position cursor has no element";
331 end if;
332
333 pragma Assert (Vet (Container, Position), "bad cursor in Delete");
334
335 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
336 Free (Container, Position.Node);
337
338 Position := No_Element;
339 end Delete;
340
341 ----------------
342 -- Difference --
343 ----------------
344
345 procedure Difference
346 (Target : in out Set;
347 Source : Set)
348 is
349 Tgt_Node, Src_Node, Src_Last, Src_Length : Count_Type;
350
351 TN : Nodes_Type renames Target.Nodes;
352 SN : Nodes_Type renames Source.Nodes;
353
354 begin
355 if Target'Address = Source'Address then
356 Clear (Target);
357 return;
358 end if;
359
360 Src_Length := Source.Length;
361
362 if Src_Length = 0 then
363 return;
364 end if;
365
366 if Src_Length >= Target.Length then
367 Tgt_Node := HT_Ops.First (Target);
368 while Tgt_Node /= 0 loop
369 if Element_Keys.Find (Source, TN (Tgt_Node).Element) /= 0 then
370 declare
371 X : constant Count_Type := Tgt_Node;
372 begin
373 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
374 HT_Ops.Delete_Node_Sans_Free (Target, X);
375 Free (Target, X);
376 end;
377
378 else
379 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
380 end if;
381 end loop;
382
383 return;
384 else
385 Src_Node := HT_Ops.First (Source);
386 Src_Last := 0;
387 end if;
388
389 while Src_Node /= Src_Last loop
390 Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element);
391
392 if Tgt_Node /= 0 then
393 HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node);
394 Free (Target, Tgt_Node);
395 end if;
396
397 Src_Node := HT_Ops.Next (Source, Src_Node);
398 end loop;
399 end Difference;
400
401 procedure Difference
402 (Left, Right : Set;
403 Target : in out Set)
404 is
405 procedure Process (L_Node : Count_Type);
406
407 procedure Iterate is
408 new HT_Ops.Generic_Iteration (Process);
409
410 -------------
411 -- Process --
412 -------------
413
414 procedure Process (L_Node : Count_Type) is
415 E : Element_Type renames Left.Nodes (L_Node).Element;
416 X : Count_Type;
417 B : Boolean;
418 begin
419 if Find (Right, E).Node = 0 then
420 Insert (Target, E, X, B);
421 pragma Assert (B);
422 end if;
423 end Process;
424
425 -- Start of processing for Difference
426
427 begin
428 Iterate (Left);
429 end Difference;
430
431 function Difference (Left, Right : Set) return Set is
432 C : Count_Type;
433 H : Hash_Type;
434
435 begin
436 if Left'Address = Right'Address then
437 return Empty_Set;
438 end if;
439
440 if Length (Left) = 0 then
441 return Empty_Set;
442 end if;
443
444 if Length (Right) = 0 then
445 return Left.Copy;
446 end if;
447
448 C := Length (Left);
449 H := Default_Modulus (C);
450
451 return S : Set (C, H) do
452 Difference (Left, Right, Target => S);
453 end return;
454 end Difference;
455
456 -------------
457 -- Element --
458 -------------
459
460 function Element
461 (Container : Set;
462 Position : Cursor) return Element_Type
463 is
464 begin
465 if not Has_Element (Container, Position) then
466 raise Constraint_Error with "Position cursor equals No_Element";
467 end if;
468
469 pragma Assert (Vet (Container, Position),
470 "bad cursor in function Element");
471
472 return Container.Nodes (Position.Node).Element;
473 end Element;
474
475 ---------------------
476 -- Equivalent_Sets --
477 ---------------------
478
479 function Equivalent_Sets (Left, Right : Set) return Boolean is
480
481 function Find_Equivalent_Key
482 (R_HT : Hash_Table_Type'Class;
483 L_Node : Node_Type) return Boolean;
484 pragma Inline (Find_Equivalent_Key);
485
486 function Is_Equivalent is
487 new HT_Ops.Generic_Equal (Find_Equivalent_Key);
488
489 -------------------------
490 -- Find_Equivalent_Key --
491 -------------------------
492
493 function Find_Equivalent_Key
494 (R_HT : Hash_Table_Type'Class;
495 L_Node : Node_Type) return Boolean
496 is
497 R_Index : constant Hash_Type :=
498 Element_Keys.Index (R_HT, L_Node.Element);
499 R_Node : Count_Type := R_HT.Buckets (R_Index);
500 RN : Nodes_Type renames R_HT.Nodes;
501
502 begin
503 loop
504 if R_Node = 0 then
505 return False;
506 end if;
507
508 if Equivalent_Elements
509 (L_Node.Element, RN (R_Node).Element)
510 then
511 return True;
512 end if;
513
514 R_Node := HT_Ops.Next (R_HT, R_Node);
515 end loop;
516 end Find_Equivalent_Key;
517
518 -- Start of processing for Equivalent_Sets
519
520 begin
521 return Is_Equivalent (Left, Right);
522 end Equivalent_Sets;
523
524 -------------------------
525 -- Equivalent_Elements --
526 -------------------------
527
528 function Equivalent_Elements
529 (Left : Set;
530 CLeft : Cursor;
531 Right : Set;
532 CRight : Cursor) return Boolean
533 is
534 begin
535 if not Has_Element (Left, CLeft) then
536 raise Constraint_Error with
537 "Left cursor of Equivalent_Elements has no element";
538 end if;
539
540 if not Has_Element (Right, CRight) then
541 raise Constraint_Error with
542 "Right cursor of Equivalent_Elements has no element";
543 end if;
544
545 pragma Assert (Vet (Left, CLeft),
546 "bad Left cursor in Equivalent_Elements");
547 pragma Assert (Vet (Right, CRight),
548 "bad Right cursor in Equivalent_Elements");
549
550 declare
551 LN : Node_Type renames Left.Nodes (CLeft.Node);
552 RN : Node_Type renames Right.Nodes (CRight.Node);
553 begin
554 return Equivalent_Elements (LN.Element, RN.Element);
555 end;
556 end Equivalent_Elements;
557
558 function Equivalent_Elements
559 (Left : Set;
560 CLeft : Cursor;
561 Right : Element_Type) return Boolean
562 is
563 begin
564 if not Has_Element (Left, CLeft) then
565 raise Constraint_Error with
566 "Left cursor of Equivalent_Elements has no element";
567 end if;
568
569 pragma Assert (Vet (Left, CLeft),
570 "Left cursor in Equivalent_Elements is bad");
571
572 declare
573 LN : Node_Type renames Left.Nodes (CLeft.Node);
574 begin
575 return Equivalent_Elements (LN.Element, Right);
576 end;
577 end Equivalent_Elements;
578
579 function Equivalent_Elements
580 (Left : Element_Type;
581 Right : Set;
582 CRight : Cursor) return Boolean
583 is
584 begin
585 if not Has_Element (Right, CRight) then
586 raise Constraint_Error with
587 "Right cursor of Equivalent_Elements has no element";
588 end if;
589
590 pragma Assert
591 (Vet (Right, CRight),
592 "Right cursor of Equivalent_Elements is bad");
593
594 declare
595 RN : Node_Type renames Right.Nodes (CRight.Node);
596 begin
597 return Equivalent_Elements (Left, RN.Element);
598 end;
599 end Equivalent_Elements;
600
601 ---------------------
602 -- Equivalent_Keys --
603 ---------------------
604
605 function Equivalent_Keys
606 (Key : Element_Type;
607 Node : Node_Type) return Boolean
608 is
609 begin
610 return Equivalent_Elements (Key, Node.Element);
611 end Equivalent_Keys;
612
613 -------------
614 -- Exclude --
615 -------------
616
617 procedure Exclude
618 (Container : in out Set;
619 Item : Element_Type)
620 is
621 X : Count_Type;
622 begin
623 Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
624 Free (Container, X);
625 end Exclude;
626
627 ----------
628 -- Find --
629 ----------
630
631 function Find
632 (Container : Set;
633 Item : Element_Type) return Cursor
634 is
635 Node : constant Count_Type := Element_Keys.Find (Container, Item);
636
637 begin
638 if Node = 0 then
639 return No_Element;
640 end if;
641
642 return (Node => Node);
643 end Find;
644
645 -----------
646 -- First --
647 -----------
648
649 function First (Container : Set) return Cursor is
650 Node : constant Count_Type := HT_Ops.First (Container);
651
652 begin
653 if Node = 0 then
654 return No_Element;
655 end if;
656
657 return (Node => Node);
658 end First;
659
660 -----------------------
661 -- First_To_Previous --
662 -----------------------
663
664 function First_To_Previous
665 (Container : Set;
666 Current : Cursor) return Set
667 is
668 Curs : Cursor := Current;
669 C : Set (Container.Capacity, Container.Modulus) :=
670 Copy (Container, Container.Capacity);
671 Node : Count_Type;
672
673 begin
674 if Curs = No_Element then
675 return C;
676
677 elsif not Has_Element (Container, Curs) then
678 raise Constraint_Error;
679
680 else
681 while Curs.Node /= 0 loop
682 Node := Curs.Node;
683 Delete (C, Curs);
684 Curs := Next (Container, (Node => Node));
685 end loop;
686
687 return C;
688 end if;
689 end First_To_Previous;
690
691 ----------
692 -- Free --
693 ----------
694
695 procedure Free
696 (HT : in out Set;
697 X : Count_Type)
698 is
699 begin
700 HT.Nodes (X).Has_Element := False;
701 HT_Ops.Free (HT, X);
702 end Free;
703
704 ----------------------
705 -- Generic_Allocate --
706 ----------------------
707
708 procedure Generic_Allocate
709 (HT : in out Set;
710 Node : out Count_Type)
711 is
712 procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element);
713 begin
714 Allocate (HT, Node);
715 HT.Nodes (Node).Has_Element := True;
716 end Generic_Allocate;
717
718 -----------------
719 -- Has_Element --
720 -----------------
721
722 function Has_Element (Container : Set; Position : Cursor) return Boolean is
723 begin
724 if Position.Node = 0
725 or else not Container.Nodes (Position.Node).Has_Element
726 then
727 return False;
728 end if;
729
730 return True;
731 end Has_Element;
732
733 ---------------
734 -- Hash_Node --
735 ---------------
736
737 function Hash_Node (Node : Node_Type) return Hash_Type is
738 begin
739 return Hash (Node.Element);
740 end Hash_Node;
741
742 -------------
743 -- Include --
744 -------------
745
746 procedure Include
747 (Container : in out Set;
748 New_Item : Element_Type)
749 is
750 Position : Cursor;
751 Inserted : Boolean;
752
753 begin
754 Insert (Container, New_Item, Position, Inserted);
755
756 if not Inserted then
757 Container.Nodes (Position.Node).Element := New_Item;
758 end if;
759 end Include;
760
761 ------------
762 -- Insert --
763 ------------
764
765 procedure Insert
766 (Container : in out Set;
767 New_Item : Element_Type;
768 Position : out Cursor;
769 Inserted : out Boolean)
770 is
771 begin
772 Insert (Container, New_Item, Position.Node, Inserted);
773 end Insert;
774
775 procedure Insert
776 (Container : in out Set;
777 New_Item : Element_Type)
778 is
779 Position : Cursor;
780 Inserted : Boolean;
781
782 begin
783 Insert (Container, New_Item, Position, Inserted);
784
785 if not Inserted then
786 raise Constraint_Error with
787 "attempt to insert element already in set";
788 end if;
789 end Insert;
790
791 procedure Insert
792 (Container : in out Set;
793 New_Item : Element_Type;
794 Node : out Count_Type;
795 Inserted : out Boolean)
796 is
797 procedure Allocate_Set_Element (Node : in out Node_Type);
798 pragma Inline (Allocate_Set_Element);
799
800 function New_Node return Count_Type;
801 pragma Inline (New_Node);
802
803 procedure Local_Insert is
804 new Element_Keys.Generic_Conditional_Insert (New_Node);
805
806 procedure Allocate is
807 new Generic_Allocate (Allocate_Set_Element);
808
809 ---------------------------
810 -- Allocate_Set_Element --
811 ---------------------------
812
813 procedure Allocate_Set_Element (Node : in out Node_Type) is
814 begin
815 Node.Element := New_Item;
816 end Allocate_Set_Element;
817
818 --------------
819 -- New_Node --
820 --------------
821
822 function New_Node return Count_Type is
823 Result : Count_Type;
824 begin
825 Allocate (Container, Result);
826 return Result;
827 end New_Node;
828
829 -- Start of processing for Insert
830
831 begin
832 Local_Insert (Container, New_Item, Node, Inserted);
833 end Insert;
834
835 ------------------
836 -- Intersection --
837 ------------------
838
839 procedure Intersection
840 (Target : in out Set;
841 Source : Set)
842 is
843 Tgt_Node : Count_Type;
844 TN : Nodes_Type renames Target.Nodes;
845
846 begin
847 if Target'Address = Source'Address then
848 return;
849 end if;
850
851 if Source.Length = 0 then
852 Clear (Target);
853 return;
854 end if;
855
856 Tgt_Node := HT_Ops.First (Target);
857 while Tgt_Node /= 0 loop
858 if Find (Source, TN (Tgt_Node).Element).Node /= 0 then
859 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
860
861 else
862 declare
863 X : constant Count_Type := Tgt_Node;
864 begin
865 Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
866 HT_Ops.Delete_Node_Sans_Free (Target, X);
867 Free (Target, X);
868 end;
869 end if;
870 end loop;
871 end Intersection;
872
873 procedure Intersection
874 (Left : Set;
875 Right : Set;
876 Target : in out Set)
877 is
878 procedure Process (L_Node : Count_Type);
879
880 procedure Iterate is
881 new HT_Ops.Generic_Iteration (Process);
882
883 -------------
884 -- Process --
885 -------------
886
887 procedure Process (L_Node : Count_Type) is
888 E : Element_Type renames Left.Nodes (L_Node).Element;
889 X : Count_Type;
890 B : Boolean;
891
892 begin
893 if Find (Right, E).Node /= 0 then
894 Insert (Target, E, X, B);
895 pragma Assert (B);
896 end if;
897 end Process;
898
899 -- Start of processing for Intersection
900
901 begin
902 Iterate (Left);
903 end Intersection;
904
905 function Intersection (Left, Right : Set) return Set is
906 C : Count_Type;
907 H : Hash_Type;
908
909 begin
910 if Left'Address = Right'Address then
911 return Left.Copy;
912 end if;
913
914 C := Count_Type'Min (Length (Left), Length (Right)); -- ???
915 H := Default_Modulus (C);
916
917 return S : Set (C, H) do
918 if Length (Left) /= 0 and Length (Right) /= 0 then
919 Intersection (Left, Right, Target => S);
920 end if;
921 end return;
922 end Intersection;
923
924 --------------
925 -- Is_Empty --
926 --------------
927
928 function Is_Empty (Container : Set) return Boolean is
929 begin
930 return Length (Container) = 0;
931 end Is_Empty;
932
933 -----------
934 -- Is_In --
935 -----------
936
937 function Is_In (HT : Set; Key : Node_Type) return Boolean is
938 begin
939 return Element_Keys.Find (HT, Key.Element) /= 0;
940 end Is_In;
941
942 ---------------
943 -- Is_Subset --
944 ---------------
945
946 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
947 Subset_Node : Count_Type;
948 Subset_Nodes : Nodes_Type renames Subset.Nodes;
949
950 begin
951 if Subset'Address = Of_Set'Address then
952 return True;
953 end if;
954
955 if Length (Subset) > Length (Of_Set) then
956 return False;
957 end if;
958
959 Subset_Node := First (Subset).Node;
960 while Subset_Node /= 0 loop
961 declare
962 N : Node_Type renames Subset_Nodes (Subset_Node);
963 E : Element_Type renames N.Element;
964
965 begin
966 if Find (Of_Set, E).Node = 0 then
967 return False;
968 end if;
969 end;
970
971 Subset_Node := HT_Ops.Next (Subset, Subset_Node);
972 end loop;
973
974 return True;
975 end Is_Subset;
976
977 ------------
978 -- Length --
979 ------------
980
981 function Length (Container : Set) return Count_Type is
982 begin
983 return Container.Length;
984 end Length;
985
986 ----------
987 -- Move --
988 ----------
989
990 -- Comments???
991
992 procedure Move (Target : in out Set; Source : in out Set) is
993 NN : HT_Types.Nodes_Type renames Source.Nodes;
994 X, Y : Count_Type;
995
996 begin
997 if Target'Address = Source'Address then
998 return;
999 end if;
1000
1001 if Target.Capacity < Length (Source) then
1002 raise Constraint_Error with -- ???
1003 "Source length exceeds Target capacity";
1004 end if;
1005
1006 Clear (Target);
1007
1008 if Source.Length = 0 then
1009 return;
1010 end if;
1011
1012 X := HT_Ops.First (Source);
1013 while X /= 0 loop
1014 Insert (Target, NN (X).Element); -- optimize???
1015
1016 Y := HT_Ops.Next (Source, X);
1017
1018 HT_Ops.Delete_Node_Sans_Free (Source, X);
1019 Free (Source, X);
1020
1021 X := Y;
1022 end loop;
1023 end Move;
1024
1025 ----------
1026 -- Next --
1027 ----------
1028
1029 function Next (Node : Node_Type) return Count_Type is
1030 begin
1031 return Node.Next;
1032 end Next;
1033
1034 function Next (Container : Set; Position : Cursor) return Cursor is
1035 begin
1036 if Position.Node = 0 then
1037 return No_Element;
1038 end if;
1039
1040 if not Has_Element (Container, Position) then
1041 raise Constraint_Error
1042 with "Position has no element";
1043 end if;
1044
1045 pragma Assert (Vet (Container, Position), "bad cursor in Next");
1046
1047 return (Node => HT_Ops.Next (Container, Position.Node));
1048 end Next;
1049
1050 procedure Next (Container : Set; Position : in out Cursor) is
1051 begin
1052 Position := Next (Container, Position);
1053 end Next;
1054
1055 -------------
1056 -- Overlap --
1057 -------------
1058
1059 function Overlap (Left, Right : Set) return Boolean is
1060 Left_Node : Count_Type;
1061 Left_Nodes : Nodes_Type renames Left.Nodes;
1062
1063 begin
1064 if Length (Right) = 0 or Length (Left) = 0 then
1065 return False;
1066 end if;
1067
1068 if Left'Address = Right'Address then
1069 return True;
1070 end if;
1071
1072 Left_Node := First (Left).Node;
1073 while Left_Node /= 0 loop
1074 declare
1075 N : Node_Type renames Left_Nodes (Left_Node);
1076 E : Element_Type renames N.Element;
1077 begin
1078 if Find (Right, E).Node /= 0 then
1079 return True;
1080 end if;
1081 end;
1082
1083 Left_Node := HT_Ops.Next (Left, Left_Node);
1084 end loop;
1085
1086 return False;
1087 end Overlap;
1088
1089 -------------
1090 -- Replace --
1091 -------------
1092
1093 procedure Replace
1094 (Container : in out Set;
1095 New_Item : Element_Type)
1096 is
1097 Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
1098
1099 begin
1100 if Node = 0 then
1101 raise Constraint_Error with
1102 "attempt to replace element not in set";
1103 end if;
1104
1105 Container.Nodes (Node).Element := New_Item;
1106 end Replace;
1107
1108 ---------------------
1109 -- Replace_Element --
1110 ---------------------
1111
1112 procedure Replace_Element
1113 (Container : in out Set;
1114 Position : Cursor;
1115 New_Item : Element_Type)
1116 is
1117 begin
1118 if not Has_Element (Container, Position) then
1119 raise Constraint_Error with
1120 "Position cursor equals No_Element";
1121 end if;
1122
1123 pragma Assert (Vet (Container, Position),
1124 "bad cursor in Replace_Element");
1125
1126 Replace_Element (Container, Position.Node, New_Item);
1127 end Replace_Element;
1128
1129 ----------------------
1130 -- Reserve_Capacity --
1131 ----------------------
1132
1133 procedure Reserve_Capacity
1134 (Container : in out Set;
1135 Capacity : Count_Type)
1136 is
1137 begin
1138 if Capacity > Container.Capacity then
1139 raise Constraint_Error with "requested capacity is too large";
1140 end if;
1141 end Reserve_Capacity;
1142
1143 ------------------
1144 -- Set_Element --
1145 ------------------
1146
1147 procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is
1148 begin
1149 Node.Element := Item;
1150 end Set_Element;
1151
1152 --------------
1153 -- Set_Next --
1154 --------------
1155
1156 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
1157 begin
1158 Node.Next := Next;
1159 end Set_Next;
1160
1161 ------------------
1162 -- Strict_Equal --
1163 ------------------
1164
1165 function Strict_Equal (Left, Right : Set) return Boolean is
1166 CuL : Cursor := First (Left);
1167 CuR : Cursor := First (Right);
1168
1169 begin
1170 if Length (Left) /= Length (Right) then
1171 return False;
1172 end if;
1173
1174 while CuL.Node /= 0 or CuR.Node /= 0 loop
1175 if CuL.Node /= CuR.Node
1176 or else Left.Nodes (CuL.Node).Element /=
1177 Right.Nodes (CuR.Node).Element
1178 then
1179 return False;
1180 end if;
1181
1182 CuL := Next (Left, CuL);
1183 CuR := Next (Right, CuR);
1184 end loop;
1185
1186 return True;
1187 end Strict_Equal;
1188
1189 --------------------------
1190 -- Symmetric_Difference --
1191 --------------------------
1192
1193 procedure Symmetric_Difference
1194 (Target : in out Set;
1195 Source : Set)
1196 is
1197 procedure Process (Source_Node : Count_Type);
1198 pragma Inline (Process);
1199
1200 procedure Iterate is new HT_Ops.Generic_Iteration (Process);
1201
1202 -------------
1203 -- Process --
1204 -------------
1205
1206 procedure Process (Source_Node : Count_Type) is
1207 N : Node_Type renames Source.Nodes (Source_Node);
1208 X : Count_Type;
1209 B : Boolean;
1210 begin
1211 if Is_In (Target, N) then
1212 Delete (Target, N.Element);
1213 else
1214 Insert (Target, N.Element, X, B);
1215 pragma Assert (B);
1216 end if;
1217 end Process;
1218
1219 -- Start of processing for Symmetric_Difference
1220
1221 begin
1222 if Target'Address = Source'Address then
1223 Clear (Target);
1224 return;
1225 end if;
1226
1227 if Length (Target) = 0 then
1228 Assign (Target, Source);
1229 return;
1230 end if;
1231
1232 Iterate (Source);
1233 end Symmetric_Difference;
1234
1235 function Symmetric_Difference (Left, Right : Set) return Set is
1236 C : Count_Type;
1237 H : Hash_Type;
1238
1239 begin
1240 if Left'Address = Right'Address then
1241 return Empty_Set;
1242 end if;
1243
1244 if Length (Right) = 0 then
1245 return Left.Copy;
1246 end if;
1247
1248 if Length (Left) = 0 then
1249 return Right.Copy;
1250 end if;
1251
1252 C := Length (Left) + Length (Right);
1253 H := Default_Modulus (C);
1254
1255 return S : Set (C, H) do
1256 Difference (Left, Right, S);
1257 Difference (Right, Left, S);
1258 end return;
1259 end Symmetric_Difference;
1260
1261 ------------
1262 -- To_Set --
1263 ------------
1264
1265 function To_Set (New_Item : Element_Type) return Set is
1266 X : Count_Type;
1267 B : Boolean;
1268
1269 begin
1270 return S : Set (Capacity => 1, Modulus => 1) do
1271 Insert (S, New_Item, X, B);
1272 pragma Assert (B);
1273 end return;
1274 end To_Set;
1275
1276 -----------
1277 -- Union --
1278 -----------
1279
1280 procedure Union
1281 (Target : in out Set;
1282 Source : Set)
1283 is
1284 procedure Process (Src_Node : Count_Type);
1285
1286 procedure Iterate is
1287 new HT_Ops.Generic_Iteration (Process);
1288
1289 -------------
1290 -- Process --
1291 -------------
1292
1293 procedure Process (Src_Node : Count_Type) is
1294 N : Node_Type renames Source.Nodes (Src_Node);
1295 E : Element_Type renames N.Element;
1296
1297 X : Count_Type;
1298 B : Boolean;
1299
1300 begin
1301 Insert (Target, E, X, B);
1302 end Process;
1303
1304 -- Start of processing for Union
1305
1306 begin
1307 if Target'Address = Source'Address then
1308 return;
1309 end if;
1310
1311 Iterate (Source);
1312 end Union;
1313
1314 function Union (Left, Right : Set) return Set is
1315 C : Count_Type;
1316 H : Hash_Type;
1317
1318 begin
1319 if Left'Address = Right'Address then
1320 return Left.Copy;
1321 end if;
1322
1323 if Length (Right) = 0 then
1324 return Left.Copy;
1325 end if;
1326
1327 if Length (Left) = 0 then
1328 return Right.Copy;
1329 end if;
1330
1331 C := Length (Left) + Length (Right);
1332 H := Default_Modulus (C);
1333 return S : Set (C, H) do
1334 Assign (Target => S, Source => Left);
1335 Union (Target => S, Source => Right);
1336 end return;
1337 end Union;
1338
1339 ---------
1340 -- Vet --
1341 ---------
1342
1343 function Vet (Container : Set; Position : Cursor) return Boolean is
1344 begin
1345 if Position.Node = 0 then
1346 return True;
1347 end if;
1348
1349 declare
1350 S : Set renames Container;
1351 N : Nodes_Type renames S.Nodes;
1352 X : Count_Type;
1353
1354 begin
1355 if S.Length = 0 then
1356 return False;
1357 end if;
1358
1359 if Position.Node > N'Last then
1360 return False;
1361 end if;
1362
1363 if N (Position.Node).Next = Position.Node then
1364 return False;
1365 end if;
1366
1367 X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element));
1368
1369 for J in 1 .. S.Length loop
1370 if X = Position.Node then
1371 return True;
1372 end if;
1373
1374 if X = 0 then
1375 return False;
1376 end if;
1377
1378 if X = N (X).Next then -- to prevent unnecessary looping
1379 return False;
1380 end if;
1381
1382 X := N (X).Next;
1383 end loop;
1384
1385 return False;
1386 end;
1387 end Vet;
1388
1389 package body Generic_Keys with SPARK_Mode => Off is
1390
1391 -----------------------
1392 -- Local Subprograms --
1393 -----------------------
1394
1395 function Equivalent_Key_Node
1396 (Key : Key_Type;
1397 Node : Node_Type) return Boolean;
1398 pragma Inline (Equivalent_Key_Node);
1399
1400 --------------------------
1401 -- Local Instantiations --
1402 --------------------------
1403
1404 package Key_Keys is
1405 new Hash_Tables.Generic_Bounded_Keys
1406 (HT_Types => HT_Types,
1407 Next => Next,
1408 Set_Next => Set_Next,
1409 Key_Type => Key_Type,
1410 Hash => Hash,
1411 Equivalent_Keys => Equivalent_Key_Node);
1412
1413 --------------
1414 -- Contains --
1415 --------------
1416
1417 function Contains
1418 (Container : Set;
1419 Key : Key_Type) return Boolean
1420 is
1421 begin
1422 return Find (Container, Key) /= No_Element;
1423 end Contains;
1424
1425 ------------
1426 -- Delete --
1427 ------------
1428
1429 procedure Delete
1430 (Container : in out Set;
1431 Key : Key_Type)
1432 is
1433 X : Count_Type;
1434
1435 begin
1436 Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1437
1438 if X = 0 then
1439 raise Constraint_Error with "attempt to delete key not in set";
1440 end if;
1441
1442 Free (Container, X);
1443 end Delete;
1444
1445 -------------
1446 -- Element --
1447 -------------
1448
1449 function Element
1450 (Container : Set;
1451 Key : Key_Type) return Element_Type
1452 is
1453 Node : constant Count_Type := Find (Container, Key).Node;
1454
1455 begin
1456 if Node = 0 then
1457 raise Constraint_Error with "key not in map";
1458 end if;
1459
1460 return Container.Nodes (Node).Element;
1461 end Element;
1462
1463 -------------------------
1464 -- Equivalent_Key_Node --
1465 -------------------------
1466
1467 function Equivalent_Key_Node
1468 (Key : Key_Type;
1469 Node : Node_Type) return Boolean
1470 is
1471 begin
1472 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1473 end Equivalent_Key_Node;
1474
1475 -------------
1476 -- Exclude --
1477 -------------
1478
1479 procedure Exclude
1480 (Container : in out Set;
1481 Key : Key_Type)
1482 is
1483 X : Count_Type;
1484 begin
1485 Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1486 Free (Container, X);
1487 end Exclude;
1488
1489 ----------
1490 -- Find --
1491 ----------
1492
1493 function Find
1494 (Container : Set;
1495 Key : Key_Type) return Cursor
1496 is
1497 Node : constant Count_Type := Key_Keys.Find (Container, Key);
1498 begin
1499 return (if Node = 0 then No_Element else (Node => Node));
1500 end Find;
1501
1502 ---------
1503 -- Key --
1504 ---------
1505
1506 function Key (Container : Set; Position : Cursor) return Key_Type is
1507 begin
1508 if not Has_Element (Container, Position) then
1509 raise Constraint_Error with
1510 "Position cursor has no element";
1511 end if;
1512
1513 pragma Assert
1514 (Vet (Container, Position), "bad cursor in function Key");
1515
1516 declare
1517 N : Node_Type renames Container.Nodes (Position.Node);
1518 begin
1519 return Key (N.Element);
1520 end;
1521 end Key;
1522
1523 -------------
1524 -- Replace --
1525 -------------
1526
1527 procedure Replace
1528 (Container : in out Set;
1529 Key : Key_Type;
1530 New_Item : Element_Type)
1531 is
1532 Node : constant Count_Type := Key_Keys.Find (Container, Key);
1533
1534 begin
1535 if Node = 0 then
1536 raise Constraint_Error with
1537 "attempt to replace key not in set";
1538 end if;
1539
1540 Replace_Element (Container, Node, New_Item);
1541 end Replace;
1542
1543 end Generic_Keys;
1544
1545 end Ada.Containers.Formal_Hashed_Sets;