1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT LIBRARY COMPONENTS                          --
4--                                                                          --
5--         ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS        --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2004-2014, 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
30--  The references in this file to "CLR" refer to the following book, from
31--  which several of the algorithms here were adapted:
32
33--     Introduction to Algorithms
34--     by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest
35--     Publisher: The MIT Press (June 18, 1990)
36--     ISBN: 0262031418
37
38with System;  use type System.Address;
39
40package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
41
42   pragma Annotate (CodePeer, Skip_Analysis);
43
44   -----------------------
45   -- Local Subprograms --
46   -----------------------
47
48   procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type);
49   procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type);
50
51   procedure Left_Rotate  (Tree : in out Tree_Type'Class; X : Count_Type);
52   procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type);
53
54   ----------------
55   -- Clear_Tree --
56   ----------------
57
58   procedure Clear_Tree (Tree : in out Tree_Type'Class) is
59   begin
60      if Tree.Busy > 0 then
61         raise Program_Error with
62           "attempt to tamper with cursors (container is busy)";
63      end if;
64
65      --  The lock status (which monitors "element tampering") always implies
66      --  that the busy status (which monitors "cursor tampering") is set too;
67      --  this is a representation invariant. Thus if the busy bit is not set,
68      --  then the lock bit must not be set either.
69
70      pragma Assert (Tree.Lock = 0);
71
72      Tree.First  := 0;
73      Tree.Last   := 0;
74      Tree.Root   := 0;
75      Tree.Length := 0;
76      Tree.Free   := -1;
77   end Clear_Tree;
78
79   ------------------
80   -- Delete_Fixup --
81   ------------------
82
83   procedure Delete_Fixup
84     (Tree : in out Tree_Type'Class;
85      Node : Count_Type)
86   is
87      --  CLR p. 274
88
89      X : Count_Type;
90      W : Count_Type;
91      N : Nodes_Type renames Tree.Nodes;
92
93   begin
94      X := Node;
95      while X /= Tree.Root and then Color (N (X)) = Black loop
96         if X = Left (N (Parent (N (X)))) then
97            W :=  Right (N (Parent (N (X))));
98
99            if Color (N (W)) = Red then
100               Set_Color (N (W), Black);
101               Set_Color (N (Parent (N (X))), Red);
102               Left_Rotate (Tree, Parent (N (X)));
103               W := Right (N (Parent (N (X))));
104            end if;
105
106            if (Left (N (W))  = 0 or else Color (N (Left (N (W)))) = Black)
107                  and then
108               (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
109            then
110               Set_Color (N (W), Red);
111               X := Parent (N (X));
112
113            else
114               if Right (N (W)) = 0
115                 or else Color (N (Right (N (W)))) = Black
116               then
117                  --  As a condition for setting the color of the left child to
118                  --  black, the left child access value must be non-null. A
119                  --  truth table analysis shows that if we arrive here, that
120                  --  condition holds, so there's no need for an explicit test.
121                  --  The assertion is here to document what we know is true.
122
123                  pragma Assert (Left (N (W)) /= 0);
124                  Set_Color (N (Left (N (W))), Black);
125
126                  Set_Color (N (W), Red);
127                  Right_Rotate (Tree, W);
128                  W := Right (N (Parent (N (X))));
129               end if;
130
131               Set_Color (N (W), Color (N (Parent (N (X)))));
132               Set_Color (N (Parent (N (X))), Black);
133               Set_Color (N (Right (N (W))), Black);
134               Left_Rotate  (Tree, Parent (N (X)));
135               X := Tree.Root;
136            end if;
137
138         else
139            pragma Assert (X = Right (N (Parent (N (X)))));
140
141            W :=  Left (N (Parent (N (X))));
142
143            if Color (N (W)) = Red then
144               Set_Color (N (W), Black);
145               Set_Color (N (Parent (N (X))), Red);
146               Right_Rotate (Tree, Parent (N (X)));
147               W := Left (N (Parent (N (X))));
148            end if;
149
150            if (Left (N (W))  = 0 or else Color (N (Left (N (W)))) = Black)
151                  and then
152               (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
153            then
154               Set_Color (N (W), Red);
155               X := Parent (N (X));
156
157            else
158               if Left (N (W)) = 0
159                 or else Color (N (Left (N (W)))) = Black
160               then
161                  --  As a condition for setting the color of the right child
162                  --  to black, the right child access value must be non-null.
163                  --  A truth table analysis shows that if we arrive here, that
164                  --  condition holds, so there's no need for an explicit test.
165                  --  The assertion is here to document what we know is true.
166
167                  pragma Assert (Right (N (W)) /= 0);
168                  Set_Color (N (Right (N (W))), Black);
169
170                  Set_Color (N (W), Red);
171                  Left_Rotate (Tree, W);
172                  W := Left (N (Parent (N (X))));
173               end if;
174
175               Set_Color (N (W), Color (N (Parent (N (X)))));
176               Set_Color (N (Parent (N (X))), Black);
177               Set_Color (N (Left (N (W))), Black);
178               Right_Rotate (Tree, Parent (N (X)));
179               X := Tree.Root;
180            end if;
181         end if;
182      end loop;
183
184      Set_Color (N (X), Black);
185   end Delete_Fixup;
186
187   ---------------------------
188   -- Delete_Node_Sans_Free --
189   ---------------------------
190
191   procedure Delete_Node_Sans_Free
192     (Tree : in out Tree_Type'Class;
193      Node : Count_Type)
194   is
195      --  CLR p. 273
196
197      X, Y : Count_Type;
198
199      Z : constant Count_Type := Node;
200
201      N : Nodes_Type renames Tree.Nodes;
202
203   begin
204      if Tree.Busy > 0 then
205         raise Program_Error with
206           "attempt to tamper with cursors (container is busy)";
207      end if;
208
209      --  If node is not present, return (exception will be raised in caller)
210
211      if Z = 0 then
212         return;
213      end if;
214
215      pragma Assert (Tree.Length > 0);
216      pragma Assert (Tree.Root  /= 0);
217      pragma Assert (Tree.First /= 0);
218      pragma Assert (Tree.Last  /= 0);
219      pragma Assert (Parent (N (Tree.Root)) = 0);
220
221      pragma Assert ((Tree.Length > 1)
222                       or else (Tree.First = Tree.Last
223                                 and then Tree.First = Tree.Root));
224
225      pragma Assert ((Left (N (Node)) = 0)
226                        or else (Parent (N (Left (N (Node)))) = Node));
227
228      pragma Assert ((Right (N (Node)) = 0)
229                        or else (Parent (N (Right (N (Node)))) = Node));
230
231      pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node))
232                        or else ((Parent (N (Node)) /= 0) and then
233                                  ((Left (N (Parent (N (Node)))) = Node)
234                                      or else
235                                   (Right (N (Parent (N (Node)))) = Node))));
236
237      if Left (N (Z)) = 0 then
238         if Right (N (Z)) = 0 then
239            if Z = Tree.First then
240               Tree.First := Parent (N (Z));
241            end if;
242
243            if Z = Tree.Last then
244               Tree.Last := Parent (N (Z));
245            end if;
246
247            if Color (N (Z)) = Black then
248               Delete_Fixup (Tree, Z);
249            end if;
250
251            pragma Assert (Left (N (Z)) = 0);
252            pragma Assert (Right (N (Z)) = 0);
253
254            if Z = Tree.Root then
255               pragma Assert (Tree.Length = 1);
256               pragma Assert (Parent (N (Z)) = 0);
257               Tree.Root := 0;
258            elsif Z = Left (N (Parent (N (Z)))) then
259               Set_Left (N (Parent (N (Z))), 0);
260            else
261               pragma Assert (Z = Right (N (Parent (N (Z)))));
262               Set_Right (N (Parent (N (Z))), 0);
263            end if;
264
265         else
266            pragma Assert (Z /= Tree.Last);
267
268            X := Right (N (Z));
269
270            if Z = Tree.First then
271               Tree.First := Min (Tree, X);
272            end if;
273
274            if Z = Tree.Root then
275               Tree.Root := X;
276            elsif Z = Left (N (Parent (N (Z)))) then
277               Set_Left (N (Parent (N (Z))), X);
278            else
279               pragma Assert (Z = Right (N (Parent (N (Z)))));
280               Set_Right (N (Parent (N (Z))), X);
281            end if;
282
283            Set_Parent (N (X), Parent (N (Z)));
284
285            if Color (N (Z)) = Black then
286               Delete_Fixup (Tree, X);
287            end if;
288         end if;
289
290      elsif Right (N (Z)) = 0 then
291         pragma Assert (Z /= Tree.First);
292
293         X := Left (N (Z));
294
295         if Z = Tree.Last then
296            Tree.Last := Max (Tree, X);
297         end if;
298
299         if Z = Tree.Root then
300            Tree.Root := X;
301         elsif Z = Left (N (Parent (N (Z)))) then
302            Set_Left (N (Parent (N (Z))), X);
303         else
304            pragma Assert (Z = Right (N (Parent (N (Z)))));
305            Set_Right (N (Parent (N (Z))), X);
306         end if;
307
308         Set_Parent (N (X), Parent (N (Z)));
309
310         if Color (N (Z)) = Black then
311            Delete_Fixup (Tree, X);
312         end if;
313
314      else
315         pragma Assert (Z /= Tree.First);
316         pragma Assert (Z /= Tree.Last);
317
318         Y := Next (Tree, Z);
319         pragma Assert (Left (N (Y)) = 0);
320
321         X := Right (N (Y));
322
323         if X = 0 then
324            if Y = Left (N (Parent (N (Y)))) then
325               pragma Assert (Parent (N (Y)) /= Z);
326               Delete_Swap (Tree, Z, Y);
327               Set_Left (N (Parent (N (Z))), Z);
328
329            else
330               pragma Assert (Y = Right (N (Parent (N (Y)))));
331               pragma Assert (Parent (N (Y)) = Z);
332               Set_Parent (N (Y), Parent (N (Z)));
333
334               if Z = Tree.Root then
335                  Tree.Root := Y;
336               elsif Z = Left (N (Parent (N (Z)))) then
337                  Set_Left (N (Parent (N (Z))), Y);
338               else
339                  pragma Assert (Z = Right (N (Parent (N (Z)))));
340                  Set_Right (N (Parent (N (Z))), Y);
341               end if;
342
343               Set_Left   (N (Y), Left (N (Z)));
344               Set_Parent (N (Left (N (Y))), Y);
345               Set_Right  (N (Y), Z);
346
347               Set_Parent (N (Z), Y);
348               Set_Left   (N (Z), 0);
349               Set_Right  (N (Z), 0);
350
351               declare
352                  Y_Color : constant Color_Type := Color (N (Y));
353               begin
354                  Set_Color (N (Y), Color (N (Z)));
355                  Set_Color (N (Z), Y_Color);
356               end;
357            end if;
358
359            if Color (N (Z)) = Black then
360               Delete_Fixup (Tree, Z);
361            end if;
362
363            pragma Assert (Left (N (Z)) = 0);
364            pragma Assert (Right (N (Z)) = 0);
365
366            if Z = Right (N (Parent (N (Z)))) then
367               Set_Right (N (Parent (N (Z))), 0);
368            else
369               pragma Assert (Z = Left (N (Parent (N (Z)))));
370               Set_Left (N (Parent (N (Z))), 0);
371            end if;
372
373         else
374            if Y = Left (N (Parent (N (Y)))) then
375               pragma Assert (Parent (N (Y)) /= Z);
376
377               Delete_Swap (Tree, Z, Y);
378
379               Set_Left (N (Parent (N (Z))), X);
380               Set_Parent (N (X), Parent (N (Z)));
381
382            else
383               pragma Assert (Y = Right (N (Parent (N (Y)))));
384               pragma Assert (Parent (N (Y)) = Z);
385
386               Set_Parent (N (Y), Parent (N (Z)));
387
388               if Z = Tree.Root then
389                  Tree.Root := Y;
390               elsif Z = Left (N (Parent (N (Z)))) then
391                  Set_Left (N (Parent (N (Z))), Y);
392               else
393                  pragma Assert (Z = Right (N (Parent (N (Z)))));
394                  Set_Right (N (Parent (N (Z))), Y);
395               end if;
396
397               Set_Left (N (Y), Left (N (Z)));
398               Set_Parent (N (Left (N (Y))), Y);
399
400               declare
401                  Y_Color : constant Color_Type := Color (N (Y));
402               begin
403                  Set_Color (N (Y), Color (N (Z)));
404                  Set_Color (N (Z), Y_Color);
405               end;
406            end if;
407
408            if Color (N (Z)) = Black then
409               Delete_Fixup (Tree, X);
410            end if;
411         end if;
412      end if;
413
414      Tree.Length := Tree.Length - 1;
415   end Delete_Node_Sans_Free;
416
417   -----------------
418   -- Delete_Swap --
419   -----------------
420
421   procedure Delete_Swap
422     (Tree : in out Tree_Type'Class;
423      Z, Y : Count_Type)
424   is
425      N : Nodes_Type renames Tree.Nodes;
426
427      pragma Assert (Z /= Y);
428      pragma Assert (Parent (N (Y)) /= Z);
429
430      Y_Parent : constant Count_Type := Parent (N (Y));
431      Y_Color  : constant Color_Type := Color (N (Y));
432
433   begin
434      Set_Parent (N (Y), Parent (N (Z)));
435      Set_Left   (N (Y), Left   (N (Z)));
436      Set_Right  (N (Y), Right  (N (Z)));
437      Set_Color  (N (Y), Color  (N (Z)));
438
439      if Tree.Root = Z then
440         Tree.Root := Y;
441      elsif Right (N (Parent (N (Y)))) = Z then
442         Set_Right (N (Parent (N (Y))), Y);
443      else
444         pragma Assert (Left (N (Parent (N (Y)))) = Z);
445         Set_Left (N (Parent (N (Y))), Y);
446      end if;
447
448      if Right (N (Y)) /= 0 then
449         Set_Parent (N (Right (N (Y))), Y);
450      end if;
451
452      if Left (N (Y)) /= 0 then
453         Set_Parent (N (Left (N (Y))), Y);
454      end if;
455
456      Set_Parent (N (Z), Y_Parent);
457      Set_Color  (N (Z), Y_Color);
458      Set_Left   (N (Z), 0);
459      Set_Right  (N (Z), 0);
460   end Delete_Swap;
461
462   ----------
463   -- Free --
464   ----------
465
466   procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is
467      pragma Assert (X > 0);
468      pragma Assert (X <= Tree.Capacity);
469
470      N : Nodes_Type renames Tree.Nodes;
471      --  pragma Assert (N (X).Prev >= 0);  -- node is active
472      --  Find a way to mark a node as active vs. inactive; we could
473      --  use a special value in Color_Type for this.  ???
474
475   begin
476      --  The set container actually contains two data structures: a list for
477      --  the "active" nodes that contain elements that have been inserted
478      --  onto the tree, and another for the "inactive" nodes of the free
479      --  store.
480      --
481      --  We desire that merely declaring an object should have only minimal
482      --  cost; specially, we want to avoid having to initialize the free
483      --  store (to fill in the links), especially if the capacity is large.
484      --
485      --  The head of the free list is indicated by Container.Free. If its
486      --  value is non-negative, then the free store has been initialized
487      --  in the "normal" way: Container.Free points to the head of the list
488      --  of free (inactive) nodes, and the value 0 means the free list is
489      --  empty. Each node on the free list has been initialized to point
490      --  to the next free node (via its Parent component), and the value 0
491      --  means that this is the last free node.
492      --
493      --  If Container.Free is negative, then the links on the free store
494      --  have not been initialized. In this case the link values are
495      --  implied: the free store comprises the components of the node array
496      --  started with the absolute value of Container.Free, and continuing
497      --  until the end of the array (Nodes'Last).
498      --
499      --  ???
500      --  It might be possible to perform an optimization here. Suppose that
501      --  the free store can be represented as having two parts: one
502      --  comprising the non-contiguous inactive nodes linked together
503      --  in the normal way, and the other comprising the contiguous
504      --  inactive nodes (that are not linked together, at the end of the
505      --  nodes array). This would allow us to never have to initialize
506      --  the free store, except in a lazy way as nodes become inactive.
507
508      --  When an element is deleted from the list container, its node
509      --  becomes inactive, and so we set its Prev component to a negative
510      --  value, to indicate that it is now inactive. This provides a useful
511      --  way to detect a dangling cursor reference.
512
513      --  The comment above is incorrect; we need some other way to
514      --  indicate a node is inactive, for example by using a special
515      --  Color_Type value.  ???
516      --  N (X).Prev := -1;  -- Node is deallocated (not on active list)
517
518      if Tree.Free >= 0 then
519         --  The free store has previously been initialized. All we need to
520         --  do here is link the newly-free'd node onto the free list.
521
522         Set_Parent (N (X), Tree.Free);
523         Tree.Free := X;
524
525      elsif X + 1 = abs Tree.Free then
526         --  The free store has not been initialized, and the node becoming
527         --  inactive immediately precedes the start of the free store. All
528         --  we need to do is move the start of the free store back by one.
529
530         Tree.Free := Tree.Free + 1;
531
532      else
533         --  The free store has not been initialized, and the node becoming
534         --  inactive does not immediately precede the free store. Here we
535         --  first initialize the free store (meaning the links are given
536         --  values in the traditional way), and then link the newly-free'd
537         --  node onto the head of the free store.
538
539         --  ???
540         --  See the comments above for an optimization opportunity. If the
541         --  next link for a node on the free store is negative, then this
542         --  means the remaining nodes on the free store are physically
543         --  contiguous, starting as the absolute value of that index value.
544
545         Tree.Free := abs Tree.Free;
546
547         if Tree.Free > Tree.Capacity then
548            Tree.Free := 0;
549
550         else
551            for I in Tree.Free .. Tree.Capacity - 1 loop
552               Set_Parent (N (I), I + 1);
553            end loop;
554
555            Set_Parent (N (Tree.Capacity), 0);
556         end if;
557
558         Set_Parent (N (X), Tree.Free);
559         Tree.Free := X;
560      end if;
561   end Free;
562
563   -----------------------
564   -- Generic_Allocate --
565   -----------------------
566
567   procedure Generic_Allocate
568     (Tree : in out Tree_Type'Class;
569      Node : out Count_Type)
570   is
571      N : Nodes_Type renames Tree.Nodes;
572
573   begin
574      if Tree.Free >= 0 then
575         Node := Tree.Free;
576
577         --  We always perform the assignment first, before we
578         --  change container state, in order to defend against
579         --  exceptions duration assignment.
580
581         Set_Element (N (Node));
582         Tree.Free := Parent (N (Node));
583
584      else
585         --  A negative free store value means that the links of the nodes
586         --  in the free store have not been initialized. In this case, the
587         --  nodes are physically contiguous in the array, starting at the
588         --  index that is the absolute value of the Container.Free, and
589         --  continuing until the end of the array (Nodes'Last).
590
591         Node := abs Tree.Free;
592
593         --  As above, we perform this assignment first, before modifying
594         --  any container state.
595
596         Set_Element (N (Node));
597         Tree.Free := Tree.Free - 1;
598      end if;
599
600      --  When a node is allocated from the free store, its pointer components
601      --  (the links to other nodes in the tree) must also be initialized (to
602      --  0, the equivalent of null). This simplifies the post-allocation
603      --  handling of nodes inserted into terminal positions.
604
605      Set_Parent (N (Node), Parent => 0);
606      Set_Left   (N (Node), Left   => 0);
607      Set_Right  (N (Node), Right  => 0);
608   end Generic_Allocate;
609
610   -------------------
611   -- Generic_Equal --
612   -------------------
613
614   function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is
615      BL : Natural renames Left'Unrestricted_Access.Busy;
616      LL : Natural renames Left'Unrestricted_Access.Lock;
617
618      BR : Natural renames Right'Unrestricted_Access.Busy;
619      LR : Natural renames Right'Unrestricted_Access.Lock;
620
621      L_Node : Count_Type;
622      R_Node : Count_Type;
623
624      Result : Boolean;
625
626   begin
627      if Left'Address = Right'Address then
628         return True;
629      end if;
630
631      if Left.Length /= Right.Length then
632         return False;
633      end if;
634
635      --  If the containers are empty, return a result immediately, so as to
636      --  not manipulate the tamper bits unnecessarily.
637
638      if Left.Length = 0 then
639         return True;
640      end if;
641
642      --  Per AI05-0022, the container implementation is required to detect
643      --  element tampering by a generic actual subprogram.
644
645      BL := BL + 1;
646      LL := LL + 1;
647
648      BR := BR + 1;
649      LR := LR + 1;
650
651      L_Node := Left.First;
652      R_Node := Right.First;
653      Result := True;
654      while L_Node /= 0 loop
655         if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
656            Result := False;
657            exit;
658         end if;
659
660         L_Node := Next (Left, L_Node);
661         R_Node := Next (Right, R_Node);
662      end loop;
663
664      BL := BL - 1;
665      LL := LL - 1;
666
667      BR := BR - 1;
668      LR := LR - 1;
669
670      return Result;
671
672   exception
673      when others =>
674         BL := BL - 1;
675         LL := LL - 1;
676
677         BR := BR - 1;
678         LR := LR - 1;
679
680         raise;
681   end Generic_Equal;
682
683   -----------------------
684   -- Generic_Iteration --
685   -----------------------
686
687   procedure Generic_Iteration (Tree : Tree_Type'Class) is
688      procedure Iterate (P : Count_Type);
689
690      -------------
691      -- Iterate --
692      -------------
693
694      procedure Iterate (P : Count_Type) is
695         X : Count_Type := P;
696      begin
697         while X /= 0 loop
698            Iterate (Left (Tree.Nodes (X)));
699            Process (X);
700            X := Right (Tree.Nodes (X));
701         end loop;
702      end Iterate;
703
704   --  Start of processing for Generic_Iteration
705
706   begin
707      Iterate (Tree.Root);
708   end Generic_Iteration;
709
710   ------------------
711   -- Generic_Read --
712   ------------------
713
714   procedure Generic_Read
715     (Stream : not null access Root_Stream_Type'Class;
716      Tree   : in out Tree_Type'Class)
717   is
718      Len : Count_Type'Base;
719
720      Node, Last_Node : Count_Type;
721
722      N : Nodes_Type renames Tree.Nodes;
723
724   begin
725      Clear_Tree (Tree);
726      Count_Type'Base'Read (Stream, Len);
727
728      if Len < 0 then
729         raise Program_Error with "bad container length (corrupt stream)";
730      end if;
731
732      if Len = 0 then
733         return;
734      end if;
735
736      if Len > Tree.Capacity then
737         raise Constraint_Error with "length exceeds capacity";
738      end if;
739
740      --  Use Unconditional_Insert_With_Hint here instead ???
741
742      Allocate (Tree, Node);
743      pragma Assert (Node /= 0);
744
745      Set_Color (N (Node), Black);
746
747      Tree.Root   := Node;
748      Tree.First  := Node;
749      Tree.Last   := Node;
750      Tree.Length := 1;
751
752      for J in Count_Type range 2 .. Len loop
753         Last_Node := Node;
754         pragma Assert (Last_Node = Tree.Last);
755
756         Allocate (Tree, Node);
757         pragma Assert (Node /= 0);
758
759         Set_Color (N (Node), Red);
760         Set_Right (N (Last_Node), Right => Node);
761         Tree.Last := Node;
762         Set_Parent (N (Node), Parent => Last_Node);
763
764         Rebalance_For_Insert (Tree, Node);
765         Tree.Length := Tree.Length + 1;
766      end loop;
767   end Generic_Read;
768
769   -------------------------------
770   -- Generic_Reverse_Iteration --
771   -------------------------------
772
773   procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is
774      procedure Iterate (P : Count_Type);
775
776      -------------
777      -- Iterate --
778      -------------
779
780      procedure Iterate (P : Count_Type) is
781         X : Count_Type := P;
782      begin
783         while X /= 0 loop
784            Iterate (Right (Tree.Nodes (X)));
785            Process (X);
786            X := Left (Tree.Nodes (X));
787         end loop;
788      end Iterate;
789
790   --  Start of processing for Generic_Reverse_Iteration
791
792   begin
793      Iterate (Tree.Root);
794   end Generic_Reverse_Iteration;
795
796   -------------------
797   -- Generic_Write --
798   -------------------
799
800   procedure Generic_Write
801     (Stream : not null access Root_Stream_Type'Class;
802      Tree   : Tree_Type'Class)
803   is
804      procedure Process (Node : Count_Type);
805      pragma Inline (Process);
806
807      procedure Iterate is new Generic_Iteration (Process);
808
809      -------------
810      -- Process --
811      -------------
812
813      procedure Process (Node : Count_Type) is
814      begin
815         Write_Node (Stream, Tree.Nodes (Node));
816      end Process;
817
818   --  Start of processing for Generic_Write
819
820   begin
821      Count_Type'Base'Write (Stream, Tree.Length);
822      Iterate (Tree);
823   end Generic_Write;
824
825   -----------------
826   -- Left_Rotate --
827   -----------------
828
829   procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is
830
831      --  CLR p. 266
832
833      N : Nodes_Type renames Tree.Nodes;
834
835      Y : constant Count_Type := Right (N (X));
836      pragma Assert (Y /= 0);
837
838   begin
839      Set_Right (N (X), Left (N (Y)));
840
841      if Left (N (Y)) /= 0 then
842         Set_Parent (N (Left (N (Y))), X);
843      end if;
844
845      Set_Parent (N (Y), Parent (N (X)));
846
847      if X = Tree.Root then
848         Tree.Root := Y;
849      elsif X = Left (N (Parent (N (X)))) then
850         Set_Left (N (Parent (N (X))), Y);
851      else
852         pragma Assert (X = Right (N (Parent (N (X)))));
853         Set_Right (N (Parent (N (X))), Y);
854      end if;
855
856      Set_Left   (N (Y), X);
857      Set_Parent (N (X), Y);
858   end Left_Rotate;
859
860   ---------
861   -- Max --
862   ---------
863
864   function Max
865     (Tree : Tree_Type'Class;
866      Node : Count_Type) return Count_Type
867   is
868      --  CLR p. 248
869
870      X : Count_Type := Node;
871      Y : Count_Type;
872
873   begin
874      loop
875         Y := Right (Tree.Nodes (X));
876
877         if Y = 0 then
878            return X;
879         end if;
880
881         X := Y;
882      end loop;
883   end Max;
884
885   ---------
886   -- Min --
887   ---------
888
889   function Min
890     (Tree : Tree_Type'Class;
891      Node : Count_Type) return Count_Type
892   is
893      --  CLR p. 248
894
895      X : Count_Type := Node;
896      Y : Count_Type;
897
898   begin
899      loop
900         Y := Left (Tree.Nodes (X));
901
902         if Y = 0 then
903            return X;
904         end if;
905
906         X := Y;
907      end loop;
908   end Min;
909
910   ----------
911   -- Next --
912   ----------
913
914   function Next
915     (Tree : Tree_Type'Class;
916      Node : Count_Type) return Count_Type
917   is
918   begin
919      --  CLR p. 249
920
921      if Node = 0 then
922         return 0;
923      end if;
924
925      if Right (Tree.Nodes (Node)) /= 0 then
926         return Min (Tree, Right (Tree.Nodes (Node)));
927      end if;
928
929      declare
930         X : Count_Type := Node;
931         Y : Count_Type := Parent (Tree.Nodes (Node));
932
933      begin
934         while Y /= 0 and then X = Right (Tree.Nodes (Y)) loop
935            X := Y;
936            Y := Parent (Tree.Nodes (Y));
937         end loop;
938
939         return Y;
940      end;
941   end Next;
942
943   --------------
944   -- Previous --
945   --------------
946
947   function Previous
948     (Tree : Tree_Type'Class;
949      Node : Count_Type) return Count_Type
950   is
951   begin
952      if Node = 0 then
953         return 0;
954      end if;
955
956      if Left (Tree.Nodes (Node)) /= 0 then
957         return Max (Tree, Left (Tree.Nodes (Node)));
958      end if;
959
960      declare
961         X : Count_Type := Node;
962         Y : Count_Type := Parent (Tree.Nodes (Node));
963
964      begin
965         while Y /= 0 and then X = Left (Tree.Nodes (Y)) loop
966            X := Y;
967            Y := Parent (Tree.Nodes (Y));
968         end loop;
969
970         return Y;
971      end;
972   end Previous;
973
974   --------------------------
975   -- Rebalance_For_Insert --
976   --------------------------
977
978   procedure Rebalance_For_Insert
979     (Tree : in out Tree_Type'Class;
980      Node : Count_Type)
981   is
982      --  CLR p. 268
983
984      N : Nodes_Type renames Tree.Nodes;
985
986      X : Count_Type := Node;
987      pragma Assert (X /= 0);
988      pragma Assert (Color (N (X)) = Red);
989
990      Y : Count_Type;
991
992   begin
993      while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop
994         if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then
995            Y := Right (N (Parent (N (Parent (N (X))))));
996
997            if Y /= 0 and then Color (N (Y)) = Red then
998               Set_Color (N (Parent (N (X))), Black);
999               Set_Color (N (Y), Black);
1000               Set_Color (N (Parent (N (Parent (N (X))))), Red);
1001               X := Parent (N (Parent (N (X))));
1002
1003            else
1004               if X = Right (N (Parent (N (X)))) then
1005                  X := Parent (N (X));
1006                  Left_Rotate (Tree, X);
1007               end if;
1008
1009               Set_Color (N (Parent (N (X))), Black);
1010               Set_Color (N (Parent (N (Parent (N (X))))), Red);
1011               Right_Rotate (Tree, Parent (N (Parent (N (X)))));
1012            end if;
1013
1014         else
1015            pragma Assert (Parent (N (X)) =
1016                             Right (N (Parent (N (Parent (N (X)))))));
1017
1018            Y := Left (N (Parent (N (Parent (N (X))))));
1019
1020            if Y /= 0 and then Color (N (Y)) = Red then
1021               Set_Color (N (Parent (N (X))), Black);
1022               Set_Color (N (Y), Black);
1023               Set_Color (N (Parent (N (Parent (N (X))))), Red);
1024               X := Parent (N (Parent (N (X))));
1025
1026            else
1027               if X = Left (N (Parent (N (X)))) then
1028                  X := Parent (N (X));
1029                  Right_Rotate (Tree, X);
1030               end if;
1031
1032               Set_Color (N (Parent (N (X))), Black);
1033               Set_Color (N (Parent (N (Parent (N (X))))), Red);
1034               Left_Rotate (Tree, Parent (N (Parent (N (X)))));
1035            end if;
1036         end if;
1037      end loop;
1038
1039      Set_Color (N (Tree.Root), Black);
1040   end Rebalance_For_Insert;
1041
1042   ------------------
1043   -- Right_Rotate --
1044   ------------------
1045
1046   procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is
1047      N : Nodes_Type renames Tree.Nodes;
1048
1049      X : constant Count_Type := Left (N (Y));
1050      pragma Assert (X /= 0);
1051
1052   begin
1053      Set_Left (N (Y), Right (N (X)));
1054
1055      if Right (N (X)) /= 0 then
1056         Set_Parent (N (Right (N (X))), Y);
1057      end if;
1058
1059      Set_Parent (N (X), Parent (N (Y)));
1060
1061      if Y = Tree.Root then
1062         Tree.Root := X;
1063      elsif Y = Left (N (Parent (N (Y)))) then
1064         Set_Left (N (Parent (N (Y))), X);
1065      else
1066         pragma Assert (Y = Right (N (Parent (N (Y)))));
1067         Set_Right (N (Parent (N (Y))), X);
1068      end if;
1069
1070      Set_Right  (N (X), Y);
1071      Set_Parent (N (Y), X);
1072   end Right_Rotate;
1073
1074   ---------
1075   -- Vet --
1076   ---------
1077
1078   function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is
1079      Nodes : Nodes_Type renames Tree.Nodes;
1080      Node  : Node_Type renames Nodes (Index);
1081
1082   begin
1083      if Parent (Node) = Index
1084        or else Left (Node) = Index
1085        or else Right (Node) = Index
1086      then
1087         return False;
1088      end if;
1089
1090      if Tree.Length = 0
1091        or else Tree.Root = 0
1092        or else Tree.First = 0
1093        or else Tree.Last = 0
1094      then
1095         return False;
1096      end if;
1097
1098      if Parent (Nodes (Tree.Root)) /= 0 then
1099         return False;
1100      end if;
1101
1102      if Left (Nodes (Tree.First)) /= 0 then
1103         return False;
1104      end if;
1105
1106      if Right (Nodes (Tree.Last)) /= 0 then
1107         return False;
1108      end if;
1109
1110      if Tree.Length = 1 then
1111         if Tree.First /= Tree.Last
1112           or else Tree.First /= Tree.Root
1113         then
1114            return False;
1115         end if;
1116
1117         if Index /= Tree.First then
1118            return False;
1119         end if;
1120
1121         if Parent (Node) /= 0
1122           or else Left (Node) /= 0
1123           or else Right (Node) /= 0
1124         then
1125            return False;
1126         end if;
1127
1128         return True;
1129      end if;
1130
1131      if Tree.First = Tree.Last then
1132         return False;
1133      end if;
1134
1135      if Tree.Length = 2 then
1136         if Tree.First /= Tree.Root and then Tree.Last /= Tree.Root then
1137            return False;
1138         end if;
1139
1140         if Tree.First /= Index and then Tree.Last /= Index then
1141            return False;
1142         end if;
1143      end if;
1144
1145      if Left (Node) /= 0 and then Parent (Nodes (Left (Node))) /= Index then
1146         return False;
1147      end if;
1148
1149      if Right (Node) /= 0 and then Parent (Nodes (Right (Node))) /= Index then
1150         return False;
1151      end if;
1152
1153      if Parent (Node) = 0 then
1154         if Tree.Root /= Index then
1155            return False;
1156         end if;
1157
1158      elsif Left (Nodes (Parent (Node))) /= Index
1159        and then Right (Nodes (Parent (Node))) /= Index
1160      then
1161         return False;
1162      end if;
1163
1164      return True;
1165   end Vet;
1166
1167end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
1168