File : a-coormu.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-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 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
29
30 with Ada.Unchecked_Deallocation;
31
32 with Ada.Containers.Red_Black_Trees.Generic_Operations;
33 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
34
35 with Ada.Containers.Red_Black_Trees.Generic_Keys;
36 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
37
38 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
39 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
40
41 with System; use type System.Address;
42
43 package body Ada.Containers.Ordered_Multisets is
44
45 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
46 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
47 -- See comment in Ada.Containers.Helpers
48
49 -----------------------------
50 -- Node Access Subprograms --
51 -----------------------------
52
53 -- These subprograms provide a functional interface to access fields
54 -- of a node, and a procedural interface for modifying these values.
55
56 function Color (Node : Node_Access) return Color_Type;
57 pragma Inline (Color);
58
59 function Left (Node : Node_Access) return Node_Access;
60 pragma Inline (Left);
61
62 function Parent (Node : Node_Access) return Node_Access;
63 pragma Inline (Parent);
64
65 function Right (Node : Node_Access) return Node_Access;
66 pragma Inline (Right);
67
68 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
69 pragma Inline (Set_Parent);
70
71 procedure Set_Left (Node : Node_Access; Left : Node_Access);
72 pragma Inline (Set_Left);
73
74 procedure Set_Right (Node : Node_Access; Right : Node_Access);
75 pragma Inline (Set_Right);
76
77 procedure Set_Color (Node : Node_Access; Color : Color_Type);
78 pragma Inline (Set_Color);
79
80 -----------------------
81 -- Local Subprograms --
82 -----------------------
83
84 function Copy_Node (Source : Node_Access) return Node_Access;
85 pragma Inline (Copy_Node);
86
87 procedure Free (X : in out Node_Access);
88
89 procedure Insert_Sans_Hint
90 (Tree : in out Tree_Type;
91 New_Item : Element_Type;
92 Node : out Node_Access);
93
94 procedure Insert_With_Hint
95 (Dst_Tree : in out Tree_Type;
96 Dst_Hint : Node_Access;
97 Src_Node : Node_Access;
98 Dst_Node : out Node_Access);
99
100 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
101 pragma Inline (Is_Equal_Node_Node);
102
103 function Is_Greater_Element_Node
104 (Left : Element_Type;
105 Right : Node_Access) return Boolean;
106 pragma Inline (Is_Greater_Element_Node);
107
108 function Is_Less_Element_Node
109 (Left : Element_Type;
110 Right : Node_Access) return Boolean;
111 pragma Inline (Is_Less_Element_Node);
112
113 function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
114 pragma Inline (Is_Less_Node_Node);
115
116 procedure Replace_Element
117 (Tree : in out Tree_Type;
118 Node : Node_Access;
119 Item : Element_Type);
120
121 --------------------------
122 -- Local Instantiations --
123 --------------------------
124
125 package Tree_Operations is
126 new Red_Black_Trees.Generic_Operations (Tree_Types);
127
128 procedure Delete_Tree is
129 new Tree_Operations.Generic_Delete_Tree (Free);
130
131 function Copy_Tree is
132 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
133
134 use Tree_Operations;
135
136 function Is_Equal is
137 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
138
139 package Element_Keys is
140 new Red_Black_Trees.Generic_Keys
141 (Tree_Operations => Tree_Operations,
142 Key_Type => Element_Type,
143 Is_Less_Key_Node => Is_Less_Element_Node,
144 Is_Greater_Key_Node => Is_Greater_Element_Node);
145
146 package Set_Ops is
147 new Generic_Set_Operations
148 (Tree_Operations => Tree_Operations,
149 Insert_With_Hint => Insert_With_Hint,
150 Copy_Tree => Copy_Tree,
151 Delete_Tree => Delete_Tree,
152 Is_Less => Is_Less_Node_Node,
153 Free => Free);
154
155 ---------
156 -- "<" --
157 ---------
158
159 function "<" (Left, Right : Cursor) return Boolean is
160 begin
161 if Left.Node = null then
162 raise Constraint_Error with "Left cursor equals No_Element";
163 end if;
164
165 if Right.Node = null then
166 raise Constraint_Error with "Right cursor equals No_Element";
167 end if;
168
169 pragma Assert (Vet (Left.Container.Tree, Left.Node),
170 "bad Left cursor in ""<""");
171
172 pragma Assert (Vet (Right.Container.Tree, Right.Node),
173 "bad Right cursor in ""<""");
174
175 return Left.Node.Element < Right.Node.Element;
176 end "<";
177
178 function "<" (Left : Cursor; Right : Element_Type)
179 return Boolean is
180 begin
181 if Left.Node = null then
182 raise Constraint_Error with "Left cursor equals No_Element";
183 end if;
184
185 pragma Assert (Vet (Left.Container.Tree, Left.Node),
186 "bad Left cursor in ""<""");
187
188 return Left.Node.Element < Right;
189 end "<";
190
191 function "<" (Left : Element_Type; Right : Cursor)
192 return Boolean is
193 begin
194 if Right.Node = null then
195 raise Constraint_Error with "Right cursor equals No_Element";
196 end if;
197
198 pragma Assert (Vet (Right.Container.Tree, Right.Node),
199 "bad Right cursor in ""<""");
200
201 return Left < Right.Node.Element;
202 end "<";
203
204 ---------
205 -- "=" --
206 ---------
207
208 function "=" (Left, Right : Set) return Boolean is
209 begin
210 return Is_Equal (Left.Tree, Right.Tree);
211 end "=";
212
213 ---------
214 -- ">" --
215 ---------
216
217 function ">" (Left, Right : Cursor) return Boolean is
218 begin
219 if Left.Node = null then
220 raise Constraint_Error with "Left cursor equals No_Element";
221 end if;
222
223 if Right.Node = null then
224 raise Constraint_Error with "Right cursor equals No_Element";
225 end if;
226
227 pragma Assert (Vet (Left.Container.Tree, Left.Node),
228 "bad Left cursor in "">""");
229
230 pragma Assert (Vet (Right.Container.Tree, Right.Node),
231 "bad Right cursor in "">""");
232
233 -- L > R same as R < L
234
235 return Right.Node.Element < Left.Node.Element;
236 end ">";
237
238 function ">" (Left : Cursor; Right : Element_Type)
239 return Boolean is
240 begin
241 if Left.Node = null then
242 raise Constraint_Error with "Left cursor equals No_Element";
243 end if;
244
245 pragma Assert (Vet (Left.Container.Tree, Left.Node),
246 "bad Left cursor in "">""");
247
248 return Right < Left.Node.Element;
249 end ">";
250
251 function ">" (Left : Element_Type; Right : Cursor)
252 return Boolean is
253 begin
254 if Right.Node = null then
255 raise Constraint_Error with "Right cursor equals No_Element";
256 end if;
257
258 pragma Assert (Vet (Right.Container.Tree, Right.Node),
259 "bad Right cursor in "">""");
260
261 return Right.Node.Element < Left;
262 end ">";
263
264 ------------
265 -- Adjust --
266 ------------
267
268 procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree);
269
270 procedure Adjust (Container : in out Set) is
271 begin
272 Adjust (Container.Tree);
273 end Adjust;
274
275 ------------
276 -- Assign --
277 ------------
278
279 procedure Assign (Target : in out Set; Source : Set) is
280 begin
281 if Target'Address = Source'Address then
282 return;
283 end if;
284
285 Target.Clear;
286 Target.Union (Source);
287 end Assign;
288
289 -------------
290 -- Ceiling --
291 -------------
292
293 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
294 Node : constant Node_Access :=
295 Element_Keys.Ceiling (Container.Tree, Item);
296
297 begin
298 if Node = null then
299 return No_Element;
300 end if;
301
302 return Cursor'(Container'Unrestricted_Access, Node);
303 end Ceiling;
304
305 -----------
306 -- Clear --
307 -----------
308
309 procedure Clear is
310 new Tree_Operations.Generic_Clear (Delete_Tree);
311
312 procedure Clear (Container : in out Set) is
313 begin
314 Clear (Container.Tree);
315 end Clear;
316
317 -----------
318 -- Color --
319 -----------
320
321 function Color (Node : Node_Access) return Color_Type is
322 begin
323 return Node.Color;
324 end Color;
325
326 ------------------------
327 -- Constant_Reference --
328 ------------------------
329
330 function Constant_Reference
331 (Container : aliased Set;
332 Position : Cursor) return Constant_Reference_Type
333 is
334 begin
335 if Position.Container = null then
336 raise Constraint_Error with "Position cursor has no element";
337 end if;
338
339 if Position.Container /= Container'Unrestricted_Access then
340 raise Program_Error with
341 "Position cursor designates wrong container";
342 end if;
343
344 pragma Assert (Vet (Position.Container.Tree, Position.Node),
345 "bad cursor in Constant_Reference");
346
347 -- Note: in predefined container units, the creation of a reference
348 -- increments the busy bit of the container, and its finalization
349 -- decrements it. In the absence of control machinery, this tampering
350 -- protection is missing.
351
352 declare
353 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
354 pragma Unreferenced (T);
355 begin
356 return R : constant Constant_Reference_Type :=
357 (Element => Position.Node.Element'Unrestricted_Access,
358 Control => (Container => Container'Unrestricted_Access))
359 do
360 null;
361 end return;
362 end;
363 end Constant_Reference;
364
365 --------------
366 -- Contains --
367 --------------
368
369 function Contains (Container : Set; Item : Element_Type) return Boolean is
370 begin
371 return Find (Container, Item) /= No_Element;
372 end Contains;
373
374 ----------
375 -- Copy --
376 ----------
377
378 function Copy (Source : Set) return Set is
379 begin
380 return Target : Set do
381 Target.Assign (Source);
382 end return;
383 end Copy;
384
385 ---------------
386 -- Copy_Node --
387 ---------------
388
389 function Copy_Node (Source : Node_Access) return Node_Access is
390 Target : constant Node_Access :=
391 new Node_Type'(Parent => null,
392 Left => null,
393 Right => null,
394 Color => Source.Color,
395 Element => Source.Element);
396 begin
397 return Target;
398 end Copy_Node;
399
400 ------------
401 -- Delete --
402 ------------
403
404 procedure Delete (Container : in out Set; Item : Element_Type) is
405 Tree : Tree_Type renames Container.Tree;
406 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
407 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
408 X : Node_Access;
409
410 begin
411 if Node = Done then
412 raise Constraint_Error with
413 "attempt to delete element not in set";
414 end if;
415
416 loop
417 X := Node;
418 Node := Tree_Operations.Next (Node);
419 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
420 Free (X);
421
422 exit when Node = Done;
423 end loop;
424 end Delete;
425
426 procedure Delete (Container : in out Set; Position : in out Cursor) is
427 begin
428 if Position.Node = null then
429 raise Constraint_Error with "Position cursor equals No_Element";
430 end if;
431
432 if Position.Container /= Container'Unrestricted_Access then
433 raise Program_Error with "Position cursor designates wrong set";
434 end if;
435
436 pragma Assert (Vet (Container.Tree, Position.Node),
437 "bad cursor in Delete");
438
439 Delete_Node_Sans_Free (Container.Tree, Position.Node);
440 Free (Position.Node);
441
442 Position.Container := null;
443 end Delete;
444
445 ------------------
446 -- Delete_First --
447 ------------------
448
449 procedure Delete_First (Container : in out Set) is
450 Tree : Tree_Type renames Container.Tree;
451 X : Node_Access := Tree.First;
452
453 begin
454 if X = null then
455 return;
456 end if;
457
458 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
459 Free (X);
460 end Delete_First;
461
462 -----------------
463 -- Delete_Last --
464 -----------------
465
466 procedure Delete_Last (Container : in out Set) is
467 Tree : Tree_Type renames Container.Tree;
468 X : Node_Access := Tree.Last;
469
470 begin
471 if X = null then
472 return;
473 end if;
474
475 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
476 Free (X);
477 end Delete_Last;
478
479 ----------------
480 -- Difference --
481 ----------------
482
483 procedure Difference (Target : in out Set; Source : Set) is
484 begin
485 Set_Ops.Difference (Target.Tree, Source.Tree);
486 end Difference;
487
488 function Difference (Left, Right : Set) return Set is
489 Tree : constant Tree_Type :=
490 Set_Ops.Difference (Left.Tree, Right.Tree);
491 begin
492 return Set'(Controlled with Tree);
493 end Difference;
494
495 -------------
496 -- Element --
497 -------------
498
499 function Element (Position : Cursor) return Element_Type is
500 begin
501 if Position.Node = null then
502 raise Constraint_Error with "Position cursor equals No_Element";
503 end if;
504
505 pragma Assert (Vet (Position.Container.Tree, Position.Node),
506 "bad cursor in Element");
507
508 return Position.Node.Element;
509 end Element;
510
511 -------------------------
512 -- Equivalent_Elements --
513 -------------------------
514
515 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
516 begin
517 if Left < Right
518 or else Right < Left
519 then
520 return False;
521 else
522 return True;
523 end if;
524 end Equivalent_Elements;
525
526 ---------------------
527 -- Equivalent_Sets --
528 ---------------------
529
530 function Equivalent_Sets (Left, Right : Set) return Boolean is
531
532 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
533 pragma Inline (Is_Equivalent_Node_Node);
534
535 function Is_Equivalent is
536 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
537
538 -----------------------------
539 -- Is_Equivalent_Node_Node --
540 -----------------------------
541
542 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
543 begin
544 if L.Element < R.Element then
545 return False;
546 elsif R.Element < L.Element then
547 return False;
548 else
549 return True;
550 end if;
551 end Is_Equivalent_Node_Node;
552
553 -- Start of processing for Equivalent_Sets
554
555 begin
556 return Is_Equivalent (Left.Tree, Right.Tree);
557 end Equivalent_Sets;
558
559 -------------
560 -- Exclude --
561 -------------
562
563 procedure Exclude (Container : in out Set; Item : Element_Type) is
564 Tree : Tree_Type renames Container.Tree;
565 Node : Node_Access := Element_Keys.Ceiling (Tree, Item);
566 Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item);
567 X : Node_Access;
568 begin
569 while Node /= Done loop
570 X := Node;
571 Node := Tree_Operations.Next (Node);
572 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
573 Free (X);
574 end loop;
575 end Exclude;
576
577 --------------
578 -- Finalize --
579 --------------
580
581 procedure Finalize (Object : in out Iterator) is
582 begin
583 Unbusy (Object.Container.Tree.TC);
584 end Finalize;
585
586 ----------
587 -- Find --
588 ----------
589
590 function Find (Container : Set; Item : Element_Type) return Cursor is
591 Node : constant Node_Access :=
592 Element_Keys.Find (Container.Tree, Item);
593
594 begin
595 if Node = null then
596 return No_Element;
597 end if;
598
599 return Cursor'(Container'Unrestricted_Access, Node);
600 end Find;
601
602 -----------
603 -- First --
604 -----------
605
606 function First (Container : Set) return Cursor is
607 begin
608 if Container.Tree.First = null then
609 return No_Element;
610 end if;
611
612 return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
613 end First;
614
615 function First (Object : Iterator) return Cursor is
616 begin
617 -- The value of the iterator object's Node component influences the
618 -- behavior of the First (and Last) selector function.
619
620 -- When the Node component is null, this means the iterator object was
621 -- constructed without a start expression, in which case the (forward)
622 -- iteration starts from the (logical) beginning of the entire sequence
623 -- of items (corresponding to Container.First, for a forward iterator).
624
625 -- Otherwise, this is iteration over a partial sequence of items. When
626 -- the Node component is non-null, the iterator object was constructed
627 -- with a start expression, that specifies the position from which the
628 -- (forward) partial iteration begins.
629
630 if Object.Node = null then
631 return Object.Container.First;
632 else
633 return Cursor'(Object.Container, Object.Node);
634 end if;
635 end First;
636
637 -------------------
638 -- First_Element --
639 -------------------
640
641 function First_Element (Container : Set) return Element_Type is
642 begin
643 if Container.Tree.First = null then
644 raise Constraint_Error with "set is empty";
645 end if;
646
647 return Container.Tree.First.Element;
648 end First_Element;
649
650 -----------
651 -- Floor --
652 -----------
653
654 function Floor (Container : Set; Item : Element_Type) return Cursor is
655 Node : constant Node_Access :=
656 Element_Keys.Floor (Container.Tree, Item);
657
658 begin
659 if Node = null then
660 return No_Element;
661 end if;
662
663 return Cursor'(Container'Unrestricted_Access, Node);
664 end Floor;
665
666 ----------
667 -- Free --
668 ----------
669
670 procedure Free (X : in out Node_Access) is
671 procedure Deallocate is
672 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
673
674 begin
675 if X /= null then
676 X.Parent := X;
677 X.Left := X;
678 X.Right := X;
679
680 Deallocate (X);
681 end if;
682 end Free;
683
684 ------------------
685 -- Generic_Keys --
686 ------------------
687
688 package body Generic_Keys is
689
690 -----------------------
691 -- Local Subprograms --
692 -----------------------
693
694 function Is_Greater_Key_Node
695 (Left : Key_Type;
696 Right : Node_Access) return Boolean;
697 pragma Inline (Is_Greater_Key_Node);
698
699 function Is_Less_Key_Node
700 (Left : Key_Type;
701 Right : Node_Access) return Boolean;
702 pragma Inline (Is_Less_Key_Node);
703
704 --------------------------
705 -- Local_Instantiations --
706 --------------------------
707
708 package Key_Keys is
709 new Red_Black_Trees.Generic_Keys
710 (Tree_Operations => Tree_Operations,
711 Key_Type => Key_Type,
712 Is_Less_Key_Node => Is_Less_Key_Node,
713 Is_Greater_Key_Node => Is_Greater_Key_Node);
714
715 -------------
716 -- Ceiling --
717 -------------
718
719 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
720 Node : constant Node_Access :=
721 Key_Keys.Ceiling (Container.Tree, Key);
722
723 begin
724 if Node = null then
725 return No_Element;
726 end if;
727
728 return Cursor'(Container'Unrestricted_Access, Node);
729 end Ceiling;
730
731 --------------
732 -- Contains --
733 --------------
734
735 function Contains (Container : Set; Key : Key_Type) return Boolean is
736 begin
737 return Find (Container, Key) /= No_Element;
738 end Contains;
739
740 ------------
741 -- Delete --
742 ------------
743
744 procedure Delete (Container : in out Set; Key : Key_Type) is
745 Tree : Tree_Type renames Container.Tree;
746 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
747 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
748 X : Node_Access;
749
750 begin
751 if Node = Done then
752 raise Constraint_Error with "attempt to delete key not in set";
753 end if;
754
755 loop
756 X := Node;
757 Node := Tree_Operations.Next (Node);
758 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
759 Free (X);
760
761 exit when Node = Done;
762 end loop;
763 end Delete;
764
765 -------------
766 -- Element --
767 -------------
768
769 function Element (Container : Set; Key : Key_Type) return Element_Type is
770 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
771 begin
772 if Node = null then
773 raise Constraint_Error with "key not in set";
774 end if;
775
776 return Node.Element;
777 end Element;
778
779 ---------------------
780 -- Equivalent_Keys --
781 ---------------------
782
783 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
784 begin
785 if Left < Right
786 or else Right < Left
787 then
788 return False;
789 else
790 return True;
791 end if;
792 end Equivalent_Keys;
793
794 -------------
795 -- Exclude --
796 -------------
797
798 procedure Exclude (Container : in out Set; Key : Key_Type) is
799 Tree : Tree_Type renames Container.Tree;
800 Node : Node_Access := Key_Keys.Ceiling (Tree, Key);
801 Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key);
802 X : Node_Access;
803
804 begin
805 while Node /= Done loop
806 X := Node;
807 Node := Tree_Operations.Next (Node);
808 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
809 Free (X);
810 end loop;
811 end Exclude;
812
813 ----------
814 -- Find --
815 ----------
816
817 function Find (Container : Set; Key : Key_Type) return Cursor is
818 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
819
820 begin
821 if Node = null then
822 return No_Element;
823 end if;
824
825 return Cursor'(Container'Unrestricted_Access, Node);
826 end Find;
827
828 -----------
829 -- Floor --
830 -----------
831
832 function Floor (Container : Set; Key : Key_Type) return Cursor is
833 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
834
835 begin
836 if Node = null then
837 return No_Element;
838 end if;
839
840 return Cursor'(Container'Unrestricted_Access, Node);
841 end Floor;
842
843 -------------------------
844 -- Is_Greater_Key_Node --
845 -------------------------
846
847 function Is_Greater_Key_Node
848 (Left : Key_Type;
849 Right : Node_Access) return Boolean is
850 begin
851 return Key (Right.Element) < Left;
852 end Is_Greater_Key_Node;
853
854 ----------------------
855 -- Is_Less_Key_Node --
856 ----------------------
857
858 function Is_Less_Key_Node
859 (Left : Key_Type;
860 Right : Node_Access) return Boolean is
861 begin
862 return Left < Key (Right.Element);
863 end Is_Less_Key_Node;
864
865 -------------
866 -- Iterate --
867 -------------
868
869 procedure Iterate
870 (Container : Set;
871 Key : Key_Type;
872 Process : not null access procedure (Position : Cursor))
873 is
874 procedure Process_Node (Node : Node_Access);
875 pragma Inline (Process_Node);
876
877 procedure Local_Iterate is
878 new Key_Keys.Generic_Iteration (Process_Node);
879
880 ------------------
881 -- Process_Node --
882 ------------------
883
884 procedure Process_Node (Node : Node_Access) is
885 begin
886 Process (Cursor'(Container'Unrestricted_Access, Node));
887 end Process_Node;
888
889 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
890 Busy : With_Busy (T.TC'Unrestricted_Access);
891
892 -- Start of processing for Iterate
893
894 begin
895 Local_Iterate (T, Key);
896 end Iterate;
897
898 ---------
899 -- Key --
900 ---------
901
902 function Key (Position : Cursor) return Key_Type is
903 begin
904 if Position.Node = null then
905 raise Constraint_Error with
906 "Position cursor equals No_Element";
907 end if;
908
909 pragma Assert (Vet (Position.Container.Tree, Position.Node),
910 "bad cursor in Key");
911
912 return Key (Position.Node.Element);
913 end Key;
914
915 ---------------------
916 -- Reverse_Iterate --
917 ---------------------
918
919 procedure Reverse_Iterate
920 (Container : Set;
921 Key : Key_Type;
922 Process : not null access procedure (Position : Cursor))
923 is
924 procedure Process_Node (Node : Node_Access);
925 pragma Inline (Process_Node);
926
927 procedure Local_Reverse_Iterate is
928 new Key_Keys.Generic_Reverse_Iteration (Process_Node);
929
930 ------------------
931 -- Process_Node --
932 ------------------
933
934 procedure Process_Node (Node : Node_Access) is
935 begin
936 Process (Cursor'(Container'Unrestricted_Access, Node));
937 end Process_Node;
938
939 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
940 Busy : With_Busy (T.TC'Unrestricted_Access);
941
942 -- Start of processing for Reverse_Iterate
943
944 begin
945 Local_Reverse_Iterate (T, Key);
946 end Reverse_Iterate;
947
948 --------------------
949 -- Update_Element --
950 --------------------
951
952 procedure Update_Element
953 (Container : in out Set;
954 Position : Cursor;
955 Process : not null access procedure (Element : in out Element_Type))
956 is
957 Tree : Tree_Type renames Container.Tree;
958 Node : constant Node_Access := Position.Node;
959
960 begin
961 if Node = null then
962 raise Constraint_Error with
963 "Position cursor equals No_Element";
964 end if;
965
966 if Position.Container /= Container'Unrestricted_Access then
967 raise Program_Error with
968 "Position cursor designates wrong set";
969 end if;
970
971 pragma Assert (Vet (Tree, Node),
972 "bad cursor in Update_Element");
973
974 declare
975 E : Element_Type renames Node.Element;
976 K : constant Key_Type := Key (E);
977 Lock : With_Lock (Tree.TC'Unrestricted_Access);
978 begin
979 Process (E);
980
981 if Equivalent_Keys (Left => K, Right => Key (E)) then
982 return;
983 end if;
984 end;
985
986 -- Delete_Node checks busy-bit
987
988 Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
989
990 Insert_New_Item : declare
991 function New_Node return Node_Access;
992 pragma Inline (New_Node);
993
994 procedure Insert_Post is
995 new Element_Keys.Generic_Insert_Post (New_Node);
996
997 procedure Unconditional_Insert is
998 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
999
1000 --------------
1001 -- New_Node --
1002 --------------
1003
1004 function New_Node return Node_Access is
1005 begin
1006 Node.Color := Red_Black_Trees.Red;
1007 Node.Parent := null;
1008 Node.Left := null;
1009 Node.Right := null;
1010
1011 return Node;
1012 end New_Node;
1013
1014 Result : Node_Access;
1015
1016 -- Start of processing for Insert_New_Item
1017
1018 begin
1019 Unconditional_Insert
1020 (Tree => Tree,
1021 Key => Node.Element,
1022 Node => Result);
1023
1024 pragma Assert (Result = Node);
1025 end Insert_New_Item;
1026 end Update_Element;
1027
1028 end Generic_Keys;
1029
1030 -----------------
1031 -- Has_Element --
1032 -----------------
1033
1034 function Has_Element (Position : Cursor) return Boolean is
1035 begin
1036 return Position /= No_Element;
1037 end Has_Element;
1038
1039 ------------
1040 -- Insert --
1041 ------------
1042
1043 procedure Insert (Container : in out Set; New_Item : Element_Type) is
1044 Position : Cursor;
1045 pragma Unreferenced (Position);
1046 begin
1047 Insert (Container, New_Item, Position);
1048 end Insert;
1049
1050 procedure Insert
1051 (Container : in out Set;
1052 New_Item : Element_Type;
1053 Position : out Cursor)
1054 is
1055 begin
1056 Insert_Sans_Hint (Container.Tree, New_Item, Position.Node);
1057 Position.Container := Container'Unrestricted_Access;
1058 end Insert;
1059
1060 ----------------------
1061 -- Insert_Sans_Hint --
1062 ----------------------
1063
1064 procedure Insert_Sans_Hint
1065 (Tree : in out Tree_Type;
1066 New_Item : Element_Type;
1067 Node : out Node_Access)
1068 is
1069 function New_Node return Node_Access;
1070 pragma Inline (New_Node);
1071
1072 procedure Insert_Post is
1073 new Element_Keys.Generic_Insert_Post (New_Node);
1074
1075 procedure Unconditional_Insert is
1076 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1077
1078 --------------
1079 -- New_Node --
1080 --------------
1081
1082 function New_Node return Node_Access is
1083 Node : constant Node_Access :=
1084 new Node_Type'(Parent => null,
1085 Left => null,
1086 Right => null,
1087 Color => Red_Black_Trees.Red,
1088 Element => New_Item);
1089 begin
1090 return Node;
1091 end New_Node;
1092
1093 -- Start of processing for Insert_Sans_Hint
1094
1095 begin
1096 Unconditional_Insert (Tree, New_Item, Node);
1097 end Insert_Sans_Hint;
1098
1099 ----------------------
1100 -- Insert_With_Hint --
1101 ----------------------
1102
1103 procedure Insert_With_Hint
1104 (Dst_Tree : in out Tree_Type;
1105 Dst_Hint : Node_Access;
1106 Src_Node : Node_Access;
1107 Dst_Node : out Node_Access)
1108 is
1109 function New_Node return Node_Access;
1110 pragma Inline (New_Node);
1111
1112 procedure Insert_Post is
1113 new Element_Keys.Generic_Insert_Post (New_Node);
1114
1115 procedure Insert_Sans_Hint is
1116 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1117
1118 procedure Local_Insert_With_Hint is
1119 new Element_Keys.Generic_Unconditional_Insert_With_Hint
1120 (Insert_Post,
1121 Insert_Sans_Hint);
1122
1123 --------------
1124 -- New_Node --
1125 --------------
1126
1127 function New_Node return Node_Access is
1128 Node : constant Node_Access :=
1129 new Node_Type'(Parent => null,
1130 Left => null,
1131 Right => null,
1132 Color => Red,
1133 Element => Src_Node.Element);
1134 begin
1135 return Node;
1136 end New_Node;
1137
1138 -- Start of processing for Insert_With_Hint
1139
1140 begin
1141 Local_Insert_With_Hint
1142 (Dst_Tree,
1143 Dst_Hint,
1144 Src_Node.Element,
1145 Dst_Node);
1146 end Insert_With_Hint;
1147
1148 ------------------
1149 -- Intersection --
1150 ------------------
1151
1152 procedure Intersection (Target : in out Set; Source : Set) is
1153 begin
1154 Set_Ops.Intersection (Target.Tree, Source.Tree);
1155 end Intersection;
1156
1157 function Intersection (Left, Right : Set) return Set is
1158 Tree : constant Tree_Type :=
1159 Set_Ops.Intersection (Left.Tree, Right.Tree);
1160 begin
1161 return Set'(Controlled with Tree);
1162 end Intersection;
1163
1164 --------------
1165 -- Is_Empty --
1166 --------------
1167
1168 function Is_Empty (Container : Set) return Boolean is
1169 begin
1170 return Container.Tree.Length = 0;
1171 end Is_Empty;
1172
1173 ------------------------
1174 -- Is_Equal_Node_Node --
1175 ------------------------
1176
1177 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
1178 begin
1179 return L.Element = R.Element;
1180 end Is_Equal_Node_Node;
1181
1182 -----------------------------
1183 -- Is_Greater_Element_Node --
1184 -----------------------------
1185
1186 function Is_Greater_Element_Node
1187 (Left : Element_Type;
1188 Right : Node_Access) return Boolean
1189 is
1190 begin
1191 -- e > node same as node < e
1192
1193 return Right.Element < Left;
1194 end Is_Greater_Element_Node;
1195
1196 --------------------------
1197 -- Is_Less_Element_Node --
1198 --------------------------
1199
1200 function Is_Less_Element_Node
1201 (Left : Element_Type;
1202 Right : Node_Access) return Boolean
1203 is
1204 begin
1205 return Left < Right.Element;
1206 end Is_Less_Element_Node;
1207
1208 -----------------------
1209 -- Is_Less_Node_Node --
1210 -----------------------
1211
1212 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1213 begin
1214 return L.Element < R.Element;
1215 end Is_Less_Node_Node;
1216
1217 ---------------
1218 -- Is_Subset --
1219 ---------------
1220
1221 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1222 begin
1223 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1224 end Is_Subset;
1225
1226 -------------
1227 -- Iterate --
1228 -------------
1229
1230 procedure Iterate
1231 (Container : Set;
1232 Process : not null access procedure (Position : Cursor))
1233 is
1234 procedure Process_Node (Node : Node_Access);
1235 pragma Inline (Process_Node);
1236
1237 procedure Local_Iterate is
1238 new Tree_Operations.Generic_Iteration (Process_Node);
1239
1240 ------------------
1241 -- Process_Node --
1242 ------------------
1243
1244 procedure Process_Node (Node : Node_Access) is
1245 begin
1246 Process (Cursor'(Container'Unrestricted_Access, Node));
1247 end Process_Node;
1248
1249 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1250 Busy : With_Busy (T.TC'Unrestricted_Access);
1251
1252 -- Start of processing for Iterate
1253
1254 begin
1255 Local_Iterate (T);
1256 end Iterate;
1257
1258 procedure Iterate
1259 (Container : Set;
1260 Item : Element_Type;
1261 Process : not null access procedure (Position : Cursor))
1262 is
1263 procedure Process_Node (Node : Node_Access);
1264 pragma Inline (Process_Node);
1265
1266 procedure Local_Iterate is
1267 new Element_Keys.Generic_Iteration (Process_Node);
1268
1269 ------------------
1270 -- Process_Node --
1271 ------------------
1272
1273 procedure Process_Node (Node : Node_Access) is
1274 begin
1275 Process (Cursor'(Container'Unrestricted_Access, Node));
1276 end Process_Node;
1277
1278 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1279 Busy : With_Busy (T.TC'Unrestricted_Access);
1280
1281 -- Start of processing for Iterate
1282
1283 begin
1284 Local_Iterate (T, Item);
1285 end Iterate;
1286
1287 function Iterate (Container : Set)
1288 return Set_Iterator_Interfaces.Reversible_Iterator'Class
1289 is
1290 S : constant Set_Access := Container'Unrestricted_Access;
1291 begin
1292 -- The value of the Node component influences the behavior of the First
1293 -- and Last selector functions of the iterator object. When the Node
1294 -- component is null (as is the case here), this means the iterator
1295 -- object was constructed without a start expression. This is a complete
1296 -- iterator, meaning that the iteration starts from the (logical)
1297 -- beginning of the sequence of items.
1298
1299 -- Note: For a forward iterator, Container.First is the beginning, and
1300 -- for a reverse iterator, Container.Last is the beginning.
1301
1302 return It : constant Iterator := (Limited_Controlled with S, null) do
1303 Busy (S.Tree.TC);
1304 end return;
1305 end Iterate;
1306
1307 function Iterate (Container : Set; Start : Cursor)
1308 return Set_Iterator_Interfaces.Reversible_Iterator'Class
1309 is
1310 S : constant Set_Access := Container'Unrestricted_Access;
1311 begin
1312 -- It was formerly the case that when Start = No_Element, the partial
1313 -- iterator was defined to behave the same as for a complete iterator,
1314 -- and iterate over the entire sequence of items. However, those
1315 -- semantics were unintuitive and arguably error-prone (it is too easy
1316 -- to accidentally create an endless loop), and so they were changed,
1317 -- per the ARG meeting in Denver on 2011/11. However, there was no
1318 -- consensus about what positive meaning this corner case should have,
1319 -- and so it was decided to simply raise an exception. This does imply,
1320 -- however, that it is not possible to use a partial iterator to specify
1321 -- an empty sequence of items.
1322
1323 if Start = No_Element then
1324 raise Constraint_Error with
1325 "Start position for iterator equals No_Element";
1326 end if;
1327
1328 if Start.Container /= Container'Unrestricted_Access then
1329 raise Program_Error with
1330 "Start cursor of Iterate designates wrong set";
1331 end if;
1332
1333 pragma Assert (Vet (Container.Tree, Start.Node),
1334 "Start cursor of Iterate is bad");
1335
1336 -- The value of the Node component influences the behavior of the First
1337 -- and Last selector functions of the iterator object. When the Node
1338 -- component is non-null (as is the case here), it means that this is a
1339 -- partial iteration, over a subset of the complete sequence of
1340 -- items. The iterator object was constructed with a start expression,
1341 -- indicating the position from which the iteration begins. Note that
1342 -- the start position has the same value irrespective of whether this is
1343 -- a forward or reverse iteration.
1344
1345 return It : constant Iterator :=
1346 (Limited_Controlled with S, Start.Node)
1347 do
1348 Busy (S.Tree.TC);
1349 end return;
1350 end Iterate;
1351
1352 ----------
1353 -- Last --
1354 ----------
1355
1356 function Last (Container : Set) return Cursor is
1357 begin
1358 if Container.Tree.Last = null then
1359 return No_Element;
1360 end if;
1361
1362 return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1363 end Last;
1364
1365 function Last (Object : Iterator) return Cursor is
1366 begin
1367 -- The value of the iterator object's Node component influences the
1368 -- behavior of the Last (and First) selector function.
1369
1370 -- When the Node component is null, this means the iterator object was
1371 -- constructed without a start expression, in which case the (reverse)
1372 -- iteration starts from the (logical) beginning of the entire sequence
1373 -- (corresponding to Container.Last, for a reverse iterator).
1374
1375 -- Otherwise, this is iteration over a partial sequence of items. When
1376 -- the Node component is non-null, the iterator object was constructed
1377 -- with a start expression, that specifies the position from which the
1378 -- (reverse) partial iteration begins.
1379
1380 if Object.Node = null then
1381 return Object.Container.Last;
1382 else
1383 return Cursor'(Object.Container, Object.Node);
1384 end if;
1385 end Last;
1386
1387 ------------------
1388 -- Last_Element --
1389 ------------------
1390
1391 function Last_Element (Container : Set) return Element_Type is
1392 begin
1393 if Container.Tree.Last = null then
1394 raise Constraint_Error with "set is empty";
1395 end if;
1396
1397 return Container.Tree.Last.Element;
1398 end Last_Element;
1399
1400 ----------
1401 -- Left --
1402 ----------
1403
1404 function Left (Node : Node_Access) return Node_Access is
1405 begin
1406 return Node.Left;
1407 end Left;
1408
1409 ------------
1410 -- Length --
1411 ------------
1412
1413 function Length (Container : Set) return Count_Type is
1414 begin
1415 return Container.Tree.Length;
1416 end Length;
1417
1418 ----------
1419 -- Move --
1420 ----------
1421
1422 procedure Move is
1423 new Tree_Operations.Generic_Move (Clear);
1424
1425 procedure Move (Target : in out Set; Source : in out Set) is
1426 begin
1427 Move (Target => Target.Tree, Source => Source.Tree);
1428 end Move;
1429
1430 ----------
1431 -- Next --
1432 ----------
1433
1434 procedure Next (Position : in out Cursor)
1435 is
1436 begin
1437 Position := Next (Position);
1438 end Next;
1439
1440 function Next (Position : Cursor) return Cursor is
1441 begin
1442 if Position = No_Element then
1443 return No_Element;
1444 end if;
1445
1446 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1447 "bad cursor in Next");
1448
1449 declare
1450 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
1451 begin
1452 if Node = null then
1453 return No_Element;
1454 end if;
1455
1456 return Cursor'(Position.Container, Node);
1457 end;
1458 end Next;
1459
1460 function Next (Object : Iterator; Position : Cursor) return Cursor is
1461 begin
1462 if Position.Container = null then
1463 return No_Element;
1464 end if;
1465
1466 if Position.Container /= Object.Container then
1467 raise Program_Error with
1468 "Position cursor of Next designates wrong set";
1469 end if;
1470
1471 return Next (Position);
1472 end Next;
1473
1474 -------------
1475 -- Overlap --
1476 -------------
1477
1478 function Overlap (Left, Right : Set) return Boolean is
1479 begin
1480 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1481 end Overlap;
1482
1483 ------------
1484 -- Parent --
1485 ------------
1486
1487 function Parent (Node : Node_Access) return Node_Access is
1488 begin
1489 return Node.Parent;
1490 end Parent;
1491
1492 --------------
1493 -- Previous --
1494 --------------
1495
1496 procedure Previous (Position : in out Cursor)
1497 is
1498 begin
1499 Position := Previous (Position);
1500 end Previous;
1501
1502 function Previous (Position : Cursor) return Cursor is
1503 begin
1504 if Position = No_Element then
1505 return No_Element;
1506 end if;
1507
1508 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1509 "bad cursor in Previous");
1510
1511 declare
1512 Node : constant Node_Access :=
1513 Tree_Operations.Previous (Position.Node);
1514 begin
1515 return (if Node = null then No_Element
1516 else Cursor'(Position.Container, Node));
1517 end;
1518 end Previous;
1519
1520 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1521 begin
1522 if Position.Container = null then
1523 return No_Element;
1524 end if;
1525
1526 if Position.Container /= Object.Container then
1527 raise Program_Error with
1528 "Position cursor of Previous designates wrong set";
1529 end if;
1530
1531 return Previous (Position);
1532 end Previous;
1533
1534 -------------------
1535 -- Query_Element --
1536 -------------------
1537
1538 procedure Query_Element
1539 (Position : Cursor;
1540 Process : not null access procedure (Element : Element_Type))
1541 is
1542 begin
1543 if Position.Node = null then
1544 raise Constraint_Error with "Position cursor equals No_Element";
1545 end if;
1546
1547 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1548 "bad cursor in Query_Element");
1549
1550 declare
1551 T : Tree_Type renames Position.Container.Tree;
1552 Lock : With_Lock (T.TC'Unrestricted_Access);
1553 begin
1554 Process (Position.Node.Element);
1555 end;
1556 end Query_Element;
1557
1558 ----------
1559 -- Read --
1560 ----------
1561
1562 procedure Read
1563 (Stream : not null access Root_Stream_Type'Class;
1564 Container : out Set)
1565 is
1566 function Read_Node
1567 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1568 pragma Inline (Read_Node);
1569
1570 procedure Read is
1571 new Tree_Operations.Generic_Read (Clear, Read_Node);
1572
1573 ---------------
1574 -- Read_Node --
1575 ---------------
1576
1577 function Read_Node
1578 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1579 is
1580 Node : Node_Access := new Node_Type;
1581 begin
1582 Element_Type'Read (Stream, Node.Element);
1583 return Node;
1584 exception
1585 when others =>
1586 Free (Node); -- Note that Free deallocates elem too
1587 raise;
1588 end Read_Node;
1589
1590 -- Start of processing for Read
1591
1592 begin
1593 Read (Stream, Container.Tree);
1594 end Read;
1595
1596 procedure Read
1597 (Stream : not null access Root_Stream_Type'Class;
1598 Item : out Cursor)
1599 is
1600 begin
1601 raise Program_Error with "attempt to stream set cursor";
1602 end Read;
1603
1604 procedure Read
1605 (Stream : not null access Root_Stream_Type'Class;
1606 Item : out Constant_Reference_Type)
1607 is
1608 begin
1609 raise Program_Error with "attempt to stream reference";
1610 end Read;
1611
1612 ---------------------
1613 -- Replace_Element --
1614 ---------------------
1615
1616 procedure Replace_Element
1617 (Tree : in out Tree_Type;
1618 Node : Node_Access;
1619 Item : Element_Type)
1620 is
1621 begin
1622 if Item < Node.Element
1623 or else Node.Element < Item
1624 then
1625 null;
1626 else
1627 TE_Check (Tree.TC);
1628
1629 Node.Element := Item;
1630 return;
1631 end if;
1632
1633 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
1634
1635 Insert_New_Item : declare
1636 function New_Node return Node_Access;
1637 pragma Inline (New_Node);
1638
1639 procedure Insert_Post is
1640 new Element_Keys.Generic_Insert_Post (New_Node);
1641
1642 procedure Unconditional_Insert is
1643 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
1644
1645 --------------
1646 -- New_Node --
1647 --------------
1648
1649 function New_Node return Node_Access is
1650 begin
1651 Node.Element := Item;
1652 Node.Color := Red_Black_Trees.Red;
1653 Node.Parent := null;
1654 Node.Left := null;
1655 Node.Right := null;
1656
1657 return Node;
1658 end New_Node;
1659
1660 Result : Node_Access;
1661
1662 -- Start of processing for Insert_New_Item
1663
1664 begin
1665 Unconditional_Insert
1666 (Tree => Tree,
1667 Key => Item,
1668 Node => Result);
1669
1670 pragma Assert (Result = Node);
1671 end Insert_New_Item;
1672 end Replace_Element;
1673
1674 procedure Replace_Element
1675 (Container : in out Set;
1676 Position : Cursor;
1677 New_Item : Element_Type)
1678 is
1679 begin
1680 if Position.Node = null then
1681 raise Constraint_Error with
1682 "Position cursor equals No_Element";
1683 end if;
1684
1685 if Position.Container /= Container'Unrestricted_Access then
1686 raise Program_Error with
1687 "Position cursor designates wrong set";
1688 end if;
1689
1690 pragma Assert (Vet (Container.Tree, Position.Node),
1691 "bad cursor in Replace_Element");
1692
1693 Replace_Element (Container.Tree, Position.Node, New_Item);
1694 end Replace_Element;
1695
1696 ---------------------
1697 -- Reverse_Iterate --
1698 ---------------------
1699
1700 procedure Reverse_Iterate
1701 (Container : Set;
1702 Process : not null access procedure (Position : Cursor))
1703 is
1704 procedure Process_Node (Node : Node_Access);
1705 pragma Inline (Process_Node);
1706
1707 procedure Local_Reverse_Iterate is
1708 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1709
1710 ------------------
1711 -- Process_Node --
1712 ------------------
1713
1714 procedure Process_Node (Node : Node_Access) is
1715 begin
1716 Process (Cursor'(Container'Unrestricted_Access, Node));
1717 end Process_Node;
1718
1719 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1720 Busy : With_Busy (T.TC'Unrestricted_Access);
1721
1722 -- Start of processing for Reverse_Iterate
1723
1724 begin
1725 Local_Reverse_Iterate (T);
1726 end Reverse_Iterate;
1727
1728 procedure Reverse_Iterate
1729 (Container : Set;
1730 Item : Element_Type;
1731 Process : not null access procedure (Position : Cursor))
1732 is
1733 procedure Process_Node (Node : Node_Access);
1734 pragma Inline (Process_Node);
1735
1736 procedure Local_Reverse_Iterate is
1737 new Element_Keys.Generic_Reverse_Iteration (Process_Node);
1738
1739 ------------------
1740 -- Process_Node --
1741 ------------------
1742
1743 procedure Process_Node (Node : Node_Access) is
1744 begin
1745 Process (Cursor'(Container'Unrestricted_Access, Node));
1746 end Process_Node;
1747
1748 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1749 Busy : With_Busy (T.TC'Unrestricted_Access);
1750
1751 -- Start of processing for Reverse_Iterate
1752
1753 begin
1754 Local_Reverse_Iterate (T, Item);
1755 end Reverse_Iterate;
1756
1757 -----------
1758 -- Right --
1759 -----------
1760
1761 function Right (Node : Node_Access) return Node_Access is
1762 begin
1763 return Node.Right;
1764 end Right;
1765
1766 ---------------
1767 -- Set_Color --
1768 ---------------
1769
1770 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1771 begin
1772 Node.Color := Color;
1773 end Set_Color;
1774
1775 --------------
1776 -- Set_Left --
1777 --------------
1778
1779 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1780 begin
1781 Node.Left := Left;
1782 end Set_Left;
1783
1784 ----------------
1785 -- Set_Parent --
1786 ----------------
1787
1788 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1789 begin
1790 Node.Parent := Parent;
1791 end Set_Parent;
1792
1793 ---------------
1794 -- Set_Right --
1795 ---------------
1796
1797 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1798 begin
1799 Node.Right := Right;
1800 end Set_Right;
1801
1802 --------------------------
1803 -- Symmetric_Difference --
1804 --------------------------
1805
1806 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1807 begin
1808 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1809 end Symmetric_Difference;
1810
1811 function Symmetric_Difference (Left, Right : Set) return Set is
1812 Tree : constant Tree_Type :=
1813 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1814 begin
1815 return Set'(Controlled with Tree);
1816 end Symmetric_Difference;
1817
1818 ------------
1819 -- To_Set --
1820 ------------
1821
1822 function To_Set (New_Item : Element_Type) return Set is
1823 Tree : Tree_Type;
1824 Node : Node_Access;
1825 pragma Unreferenced (Node);
1826 begin
1827 Insert_Sans_Hint (Tree, New_Item, Node);
1828 return Set'(Controlled with Tree);
1829 end To_Set;
1830
1831 -----------
1832 -- Union --
1833 -----------
1834
1835 procedure Union (Target : in out Set; Source : Set) is
1836 begin
1837 Set_Ops.Union (Target.Tree, Source.Tree);
1838 end Union;
1839
1840 function Union (Left, Right : Set) return Set is
1841 Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
1842 begin
1843 return Set'(Controlled with Tree);
1844 end Union;
1845
1846 -----------
1847 -- Write --
1848 -----------
1849
1850 procedure Write
1851 (Stream : not null access Root_Stream_Type'Class;
1852 Container : Set)
1853 is
1854 procedure Write_Node
1855 (Stream : not null access Root_Stream_Type'Class;
1856 Node : Node_Access);
1857 pragma Inline (Write_Node);
1858
1859 procedure Write is
1860 new Tree_Operations.Generic_Write (Write_Node);
1861
1862 ----------------
1863 -- Write_Node --
1864 ----------------
1865
1866 procedure Write_Node
1867 (Stream : not null access Root_Stream_Type'Class;
1868 Node : Node_Access)
1869 is
1870 begin
1871 Element_Type'Write (Stream, Node.Element);
1872 end Write_Node;
1873
1874 -- Start of processing for Write
1875
1876 begin
1877 Write (Stream, Container.Tree);
1878 end Write;
1879
1880 procedure Write
1881 (Stream : not null access Root_Stream_Type'Class;
1882 Item : Cursor)
1883 is
1884 begin
1885 raise Program_Error with "attempt to stream set cursor";
1886 end Write;
1887
1888 procedure Write
1889 (Stream : not null access Root_Stream_Type'Class;
1890 Item : Constant_Reference_Type)
1891 is
1892 begin
1893 raise Program_Error with "attempt to stream reference";
1894 end Write;
1895 end Ada.Containers.Ordered_Multisets;