1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT LIBRARY COMPONENTS                          --
4--                                                                          --
5--                ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS               --
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
30package body Ada.Containers.Red_Black_Trees.Generic_Keys is
31
32   pragma Warnings (Off, "variable ""Busy*"" is not referenced");
33   pragma Warnings (Off, "variable ""Lock*"" is not referenced");
34   --  See comment in Ada.Containers.Helpers
35
36   package Ops renames Tree_Operations;
37
38   -------------
39   -- Ceiling --
40   -------------
41
42   --  AKA Lower_Bound
43
44   function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is
45      --  Per AI05-0022, the container implementation is required to detect
46      --  element tampering by a generic actual subprogram.
47
48      Lock : With_Lock (Tree.TC'Unrestricted_Access);
49
50      Y : Node_Access;
51      X : Node_Access;
52
53   begin
54      --  If the container is empty, return a result immediately, so that we do
55      --  not manipulate the tamper bits unnecessarily.
56
57      if Tree.Root = null then
58         return null;
59      end if;
60
61      X := Tree.Root;
62      while X /= null loop
63         if Is_Greater_Key_Node (Key, X) then
64            X := Ops.Right (X);
65         else
66            Y := X;
67            X := Ops.Left (X);
68         end if;
69      end loop;
70
71      return Y;
72   end Ceiling;
73
74   ----------
75   -- Find --
76   ----------
77
78   function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is
79      --  Per AI05-0022, the container implementation is required to detect
80      --  element tampering by a generic actual subprogram.
81
82      Lock : With_Lock (Tree.TC'Unrestricted_Access);
83
84      Y : Node_Access;
85      X : Node_Access;
86
87   begin
88      --  If the container is empty, return a result immediately, so that we do
89      --  not manipulate the tamper bits unnecessarily.
90
91      if Tree.Root = null then
92         return null;
93      end if;
94
95      X := Tree.Root;
96      while X /= null loop
97         if Is_Greater_Key_Node (Key, X) then
98            X := Ops.Right (X);
99         else
100            Y := X;
101            X := Ops.Left (X);
102         end if;
103      end loop;
104
105      if Y = null or else Is_Less_Key_Node (Key, Y) then
106         return null;
107      else
108         return Y;
109      end if;
110   end Find;
111
112   -----------
113   -- Floor --
114   -----------
115
116   function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is
117      --  Per AI05-0022, the container implementation is required to detect
118      --  element tampering by a generic actual subprogram.
119
120      Lock : With_Lock (Tree.TC'Unrestricted_Access);
121
122      Y : Node_Access;
123      X : Node_Access;
124
125   begin
126      --  If the container is empty, return a result immediately, so that we do
127      --  not manipulate the tamper bits unnecessarily.
128
129      if Tree.Root = null then
130         return null;
131      end if;
132
133      X := Tree.Root;
134      while X /= null loop
135         if Is_Less_Key_Node (Key, X) then
136            X := Ops.Left (X);
137         else
138            Y := X;
139            X := Ops.Right (X);
140         end if;
141      end loop;
142
143      return Y;
144   end Floor;
145
146   --------------------------------
147   -- Generic_Conditional_Insert --
148   --------------------------------
149
150   procedure Generic_Conditional_Insert
151     (Tree     : in out Tree_Type;
152      Key      : Key_Type;
153      Node     : out Node_Access;
154      Inserted : out Boolean)
155   is
156      X : Node_Access;
157      Y : Node_Access;
158
159      Compare : Boolean;
160
161   begin
162      --  This is a "conditional" insertion, meaning that the insertion request
163      --  can "fail" in the sense that no new node is created. If the Key is
164      --  equivalent to an existing node, then we return the existing node and
165      --  Inserted is set to False. Otherwise, we allocate a new node (via
166      --  Insert_Post) and Inserted is set to True.
167
168      --  Note that we are testing for equivalence here, not equality. Key must
169      --  be strictly less than its next neighbor, and strictly greater than
170      --  its previous neighbor, in order for the conditional insertion to
171      --  succeed.
172
173      --  Handle insertion into an empty container as a special case, so that
174      --  we do not manipulate the tamper bits unnecessarily.
175
176      if Tree.Root = null then
177         Insert_Post (Tree, null, True, Node);
178         Inserted := True;
179         return;
180      end if;
181
182      --  We search the tree to find the nearest neighbor of Key, which is
183      --  either the smallest node greater than Key (Inserted is True), or the
184      --  largest node less or equivalent to Key (Inserted is False).
185
186      declare
187         Lock : With_Lock (Tree.TC'Unrestricted_Access);
188      begin
189         X := Tree.Root;
190         Y := null;
191         Inserted := True;
192         while X /= null loop
193            Y := X;
194            Inserted := Is_Less_Key_Node (Key, X);
195            X := (if Inserted then Ops.Left (X) else Ops.Right (X));
196         end loop;
197      end;
198
199      if Inserted then
200
201         --  Key is less than Y. If Y is the first node in the tree, then there
202         --  are no other nodes that we need to search for, and we insert a new
203         --  node into the tree.
204
205         if Y = Tree.First then
206            Insert_Post (Tree, Y, True, Node);
207            return;
208         end if;
209
210         --  Y is the next nearest-neighbor of Key. We know that Key is not
211         --  equivalent to Y (because Key is strictly less than Y), so we move
212         --  to the previous node, the nearest-neighbor just smaller or
213         --  equivalent to Key.
214
215         Node := Ops.Previous (Y);
216
217      else
218         --  Y is the previous nearest-neighbor of Key. We know that Key is not
219         --  less than Y, which means either that Key is equivalent to Y, or
220         --  greater than Y.
221
222         Node := Y;
223      end if;
224
225      --  Key is equivalent to or greater than Node. We must resolve which is
226      --  the case, to determine whether the conditional insertion succeeds.
227
228      declare
229         Lock : With_Lock (Tree.TC'Unrestricted_Access);
230      begin
231         Compare := Is_Greater_Key_Node (Key, Node);
232      end;
233
234      if Compare then
235
236         --  Key is strictly greater than Node, which means that Key is not
237         --  equivalent to Node. In this case, the insertion succeeds, and we
238         --  insert a new node into the tree.
239
240         Insert_Post (Tree, Y, Inserted, Node);
241         Inserted := True;
242         return;
243      end if;
244
245      --  Key is equivalent to Node. This is a conditional insertion, so we do
246      --  not insert a new node in this case. We return the existing node and
247      --  report that no insertion has occurred.
248
249      Inserted := False;
250   end Generic_Conditional_Insert;
251
252   ------------------------------------------
253   -- Generic_Conditional_Insert_With_Hint --
254   ------------------------------------------
255
256   procedure Generic_Conditional_Insert_With_Hint
257     (Tree      : in out Tree_Type;
258      Position  : Node_Access;
259      Key       : Key_Type;
260      Node      : out Node_Access;
261      Inserted  : out Boolean)
262   is
263      Test    : Node_Access;
264      Compare : Boolean;
265
266   begin
267      --  The purpose of a hint is to avoid a search from the root of
268      --  tree. If we have it hint it means we only need to traverse the
269      --  subtree rooted at the hint to find the nearest neighbor. Note
270      --  that finding the neighbor means merely walking the tree; this
271      --  is not a search and the only comparisons that occur are with
272      --  the hint and its neighbor.
273
274      --  Handle insertion into an empty container as a special case, so that
275      --  we do not manipulate the tamper bits unnecessarily.
276
277      if Tree.Root = null then
278         Insert_Post (Tree, null, True, Node);
279         Inserted := True;
280         return;
281      end if;
282
283      --  If Position is null, this is interpreted to mean that Key is large
284      --  relative to the nodes in the tree. If Key is greater than the last
285      --  node in the tree, then we're done; otherwise the hint was "wrong" and
286      --  we must search.
287
288      if Position = null then  -- largest
289         declare
290            Lock : With_Lock (Tree.TC'Unrestricted_Access);
291         begin
292            Compare := Is_Greater_Key_Node (Key, Tree.Last);
293         end;
294
295         if Compare then
296            Insert_Post (Tree, Tree.Last, False, Node);
297            Inserted := True;
298         else
299            Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
300         end if;
301
302         return;
303      end if;
304
305      pragma Assert (Tree.Length > 0);
306
307      --  A hint can either name the node that immediately follows Key,
308      --  or immediately precedes Key. We first test whether Key is
309      --  less than the hint, and if so we compare Key to the node that
310      --  precedes the hint. If Key is both less than the hint and
311      --  greater than the hint's preceding neighbor, then we're done;
312      --  otherwise we must search.
313
314      --  Note also that a hint can either be an anterior node or a leaf
315      --  node. A new node is always inserted at the bottom of the tree
316      --  (at least prior to rebalancing), becoming the new left or
317      --  right child of leaf node (which prior to the insertion must
318      --  necessarily be null, since this is a leaf). If the hint names
319      --  an anterior node then its neighbor must be a leaf, and so
320      --  (here) we insert after the neighbor. If the hint names a leaf
321      --  then its neighbor must be anterior and so we insert before the
322      --  hint.
323
324      declare
325         Lock : With_Lock (Tree.TC'Unrestricted_Access);
326      begin
327         Compare := Is_Less_Key_Node (Key, Position);
328      end;
329
330      if Compare then
331         Test := Ops.Previous (Position);  -- "before"
332
333         if Test = null then  -- new first node
334            Insert_Post (Tree, Tree.First, True, Node);
335
336            Inserted := True;
337            return;
338         end if;
339
340         declare
341            Lock : With_Lock (Tree.TC'Unrestricted_Access);
342         begin
343            Compare := Is_Greater_Key_Node (Key, Test);
344         end;
345
346         if Compare then
347            if Ops.Right (Test) = null then
348               Insert_Post (Tree, Test, False, Node);
349            else
350               Insert_Post (Tree, Position, True, Node);
351            end if;
352
353            Inserted := True;
354
355         else
356            Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
357         end if;
358
359         return;
360      end if;
361
362      --  We know that Key isn't less than the hint so we try again, this time
363      --  to see if it's greater than the hint. If so we compare Key to the
364      --  node that follows the hint. If Key is both greater than the hint and
365      --  less than the hint's next neighbor, then we're done; otherwise we
366      --  must search.
367
368      declare
369         Lock : With_Lock (Tree.TC'Unrestricted_Access);
370      begin
371         Compare := Is_Greater_Key_Node (Key, Position);
372      end;
373
374      if Compare then
375         Test := Ops.Next (Position);  -- "after"
376
377         if Test = null then  -- new last node
378            Insert_Post (Tree, Tree.Last, False, Node);
379
380            Inserted := True;
381            return;
382         end if;
383
384         declare
385            Lock : With_Lock (Tree.TC'Unrestricted_Access);
386         begin
387            Compare := Is_Less_Key_Node (Key, Test);
388         end;
389
390         if Compare then
391            if Ops.Right (Position) = null then
392               Insert_Post (Tree, Position, False, Node);
393            else
394               Insert_Post (Tree, Test, True, Node);
395            end if;
396
397            Inserted := True;
398
399         else
400            Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
401         end if;
402
403         return;
404      end if;
405
406      --  We know that Key is neither less than the hint nor greater than the
407      --  hint, and that's the definition of equivalence. There's nothing else
408      --  we need to do, since a search would just reach the same conclusion.
409
410      Node := Position;
411      Inserted := False;
412   end Generic_Conditional_Insert_With_Hint;
413
414   -------------------------
415   -- Generic_Insert_Post --
416   -------------------------
417
418   procedure Generic_Insert_Post
419     (Tree   : in out Tree_Type;
420      Y      : Node_Access;
421      Before : Boolean;
422      Z      : out Node_Access)
423   is
424   begin
425      if Checks and then Tree.Length = Count_Type'Last then
426         raise Constraint_Error with "too many elements";
427      end if;
428
429      TC_Check (Tree.TC);
430
431      Z := New_Node;
432      pragma Assert (Z /= null);
433      pragma Assert (Ops.Color (Z) = Red);
434
435      if Y = null then
436         pragma Assert (Tree.Length = 0);
437         pragma Assert (Tree.Root = null);
438         pragma Assert (Tree.First = null);
439         pragma Assert (Tree.Last = null);
440
441         Tree.Root := Z;
442         Tree.First := Z;
443         Tree.Last := Z;
444
445      elsif Before then
446         pragma Assert (Ops.Left (Y) = null);
447
448         Ops.Set_Left (Y, Z);
449
450         if Y = Tree.First then
451            Tree.First := Z;
452         end if;
453
454      else
455         pragma Assert (Ops.Right (Y) = null);
456
457         Ops.Set_Right (Y, Z);
458
459         if Y = Tree.Last then
460            Tree.Last := Z;
461         end if;
462      end if;
463
464      Ops.Set_Parent (Z, Y);
465      Ops.Rebalance_For_Insert (Tree, Z);
466      Tree.Length := Tree.Length + 1;
467   end Generic_Insert_Post;
468
469   -----------------------
470   -- Generic_Iteration --
471   -----------------------
472
473   procedure Generic_Iteration
474     (Tree : Tree_Type;
475      Key  : Key_Type)
476   is
477      procedure Iterate (Node : Node_Access);
478
479      -------------
480      -- Iterate --
481      -------------
482
483      procedure Iterate (Node : Node_Access) is
484         N : Node_Access;
485      begin
486         N := Node;
487         while N /= null loop
488            if Is_Less_Key_Node (Key, N) then
489               N := Ops.Left (N);
490            elsif Is_Greater_Key_Node (Key, N) then
491               N := Ops.Right (N);
492            else
493               Iterate (Ops.Left (N));
494               Process (N);
495               N := Ops.Right (N);
496            end if;
497         end loop;
498      end Iterate;
499
500   --  Start of processing for Generic_Iteration
501
502   begin
503      Iterate (Tree.Root);
504   end Generic_Iteration;
505
506   -------------------------------
507   -- Generic_Reverse_Iteration --
508   -------------------------------
509
510   procedure Generic_Reverse_Iteration
511     (Tree : Tree_Type;
512      Key  : Key_Type)
513   is
514      procedure Iterate (Node : Node_Access);
515
516      -------------
517      -- Iterate --
518      -------------
519
520      procedure Iterate (Node : Node_Access) is
521         N : Node_Access;
522      begin
523         N := Node;
524         while N /= null loop
525            if Is_Less_Key_Node (Key, N) then
526               N := Ops.Left (N);
527            elsif Is_Greater_Key_Node (Key, N) then
528               N := Ops.Right (N);
529            else
530               Iterate (Ops.Right (N));
531               Process (N);
532               N := Ops.Left (N);
533            end if;
534         end loop;
535      end Iterate;
536
537   --  Start of processing for Generic_Reverse_Iteration
538
539   begin
540      Iterate (Tree.Root);
541   end Generic_Reverse_Iteration;
542
543   ----------------------------------
544   -- Generic_Unconditional_Insert --
545   ----------------------------------
546
547   procedure Generic_Unconditional_Insert
548     (Tree : in out Tree_Type;
549      Key  : Key_Type;
550      Node : out Node_Access)
551   is
552      Y : Node_Access;
553      X : Node_Access;
554
555      Before : Boolean;
556
557   begin
558      Y := null;
559      Before := False;
560
561      X := Tree.Root;
562      while X /= null loop
563         Y := X;
564         Before := Is_Less_Key_Node (Key, X);
565         X := (if Before then Ops.Left (X) else Ops.Right (X));
566      end loop;
567
568      Insert_Post (Tree, Y, Before, Node);
569   end Generic_Unconditional_Insert;
570
571   --------------------------------------------
572   -- Generic_Unconditional_Insert_With_Hint --
573   --------------------------------------------
574
575   procedure Generic_Unconditional_Insert_With_Hint
576     (Tree : in out Tree_Type;
577      Hint : Node_Access;
578      Key  : Key_Type;
579      Node : out Node_Access)
580   is
581   begin
582      --  There are fewer constraints for an unconditional insertion
583      --  than for a conditional insertion, since we allow duplicate
584      --  keys. So instead of having to check (say) whether Key is
585      --  (strictly) greater than the hint's previous neighbor, here we
586      --  allow Key to be equal to or greater than the previous node.
587
588      --  There is the issue of what to do if Key is equivalent to the
589      --  hint. Does the new node get inserted before or after the hint?
590      --  We decide that it gets inserted after the hint, reasoning that
591      --  this is consistent with behavior for non-hint insertion, which
592      --  inserts a new node after existing nodes with equivalent keys.
593
594      --  First we check whether the hint is null, which is interpreted
595      --  to mean that Key is large relative to existing nodes.
596      --  Following our rule above, if Key is equal to or greater than
597      --  the last node, then we insert the new node immediately after
598      --  last. (We don't have an operation for testing whether a key is
599      --  "equal to or greater than" a node, so we must say instead "not
600      --  less than", which is equivalent.)
601
602      if Hint = null then  -- largest
603         if Tree.Last = null then
604            Insert_Post (Tree, null, False, Node);
605         elsif Is_Less_Key_Node (Key, Tree.Last) then
606            Unconditional_Insert_Sans_Hint (Tree, Key, Node);
607         else
608            Insert_Post (Tree, Tree.Last, False, Node);
609         end if;
610
611         return;
612      end if;
613
614      pragma Assert (Tree.Length > 0);
615
616      --  We decide here whether to insert the new node prior to the
617      --  hint. Key could be equivalent to the hint, so in theory we
618      --  could write the following test as "not greater than" (same as
619      --  "less than or equal to"). If Key were equivalent to the hint,
620      --  that would mean that the new node gets inserted before an
621      --  equivalent node. That wouldn't break any container invariants,
622      --  but our rule above says that new nodes always get inserted
623      --  after equivalent nodes. So here we test whether Key is both
624      --  less than the hint and equal to or greater than the hint's
625      --  previous neighbor, and if so insert it before the hint.
626
627      if Is_Less_Key_Node (Key, Hint) then
628         declare
629            Before : constant Node_Access := Ops.Previous (Hint);
630         begin
631            if Before = null then
632               Insert_Post (Tree, Hint, True, Node);
633            elsif Is_Less_Key_Node (Key, Before) then
634               Unconditional_Insert_Sans_Hint (Tree, Key, Node);
635            elsif Ops.Right (Before) = null then
636               Insert_Post (Tree, Before, False, Node);
637            else
638               Insert_Post (Tree, Hint, True, Node);
639            end if;
640         end;
641
642         return;
643      end if;
644
645      --  We know that Key isn't less than the hint, so it must be equal
646      --  or greater. So we just test whether Key is less than or equal
647      --  to (same as "not greater than") the hint's next neighbor, and
648      --  if so insert it after the hint.
649
650      declare
651         After : constant Node_Access := Ops.Next (Hint);
652      begin
653         if After = null then
654            Insert_Post (Tree, Hint, False, Node);
655         elsif Is_Greater_Key_Node (Key, After) then
656            Unconditional_Insert_Sans_Hint (Tree, Key, Node);
657         elsif Ops.Right (Hint) = null then
658            Insert_Post (Tree, Hint, False, Node);
659         else
660            Insert_Post (Tree, After, True, Node);
661         end if;
662      end;
663   end Generic_Unconditional_Insert_With_Hint;
664
665   -----------------
666   -- Upper_Bound --
667   -----------------
668
669   function Upper_Bound
670     (Tree : Tree_Type;
671      Key  : Key_Type) return Node_Access
672   is
673      Y : Node_Access;
674      X : Node_Access;
675
676   begin
677      X := Tree.Root;
678      while X /= null loop
679         if Is_Less_Key_Node (Key, X) then
680            Y := X;
681            X := Ops.Left (X);
682         else
683            X := Ops.Right (X);
684         end if;
685      end loop;
686
687      return Y;
688   end Upper_Bound;
689
690end Ada.Containers.Red_Black_Trees.Generic_Keys;
691