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