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