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