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