summaryrefslogtreecommitdiff
path: root/gcc/ada/a-crbtgk.adb
blob: c06f31e1d0731fe7f1795ef0d0decdae2f198708 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT LIBRARY COMPONENTS                          --
--                                                                          --
--                ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2004-2009, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- This unit was originally developed by Matthew J Heaney.                  --
------------------------------------------------------------------------------

package body Ada.Containers.Red_Black_Trees.Generic_Keys is

   package Ops renames Tree_Operations;

   -------------
   -- Ceiling --
   -------------

   --  AKA Lower_Bound

   function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is
      Y : Node_Access;
      X : Node_Access;

   begin
      X := Tree.Root;
      while X /= null loop
         if Is_Greater_Key_Node (Key, X) then
            X := Ops.Right (X);
         else
            Y := X;
            X := Ops.Left (X);
         end if;
      end loop;

      return Y;
   end Ceiling;

   ----------
   -- Find --
   ----------

   function Find (Tree : Tree_Type; Key  : Key_Type) return Node_Access is
      Y : Node_Access;
      X : Node_Access;

   begin
      X := Tree.Root;
      while X /= null loop
         if Is_Greater_Key_Node (Key, X) then
            X := Ops.Right (X);
         else
            Y := X;
            X := Ops.Left (X);
         end if;
      end loop;

      if Y = null then
         return null;
      end if;

      if Is_Less_Key_Node (Key, Y) then
         return null;
      end if;

      return Y;
   end Find;

   -----------
   -- Floor --
   -----------

   function Floor (Tree : Tree_Type; Key  : Key_Type) return Node_Access is
      Y : Node_Access;
      X : Node_Access;

   begin
      X := Tree.Root;
      while X /= null loop
         if Is_Less_Key_Node (Key, X) then
            X := Ops.Left (X);
         else
            Y := X;
            X := Ops.Right (X);
         end if;
      end loop;

      return Y;
   end Floor;

   --------------------------------
   -- Generic_Conditional_Insert --
   --------------------------------

   procedure Generic_Conditional_Insert
     (Tree     : in out Tree_Type;
      Key      : Key_Type;
      Node     : out Node_Access;
      Inserted : out Boolean)
   is
      Y : Node_Access := null;
      X : Node_Access := Tree.Root;

   begin
      Inserted := True;
      while X /= null loop
         Y := X;
         Inserted := Is_Less_Key_Node (Key, X);

         if Inserted then
            X := Ops.Left (X);
         else
            X := Ops.Right (X);
         end if;
      end loop;

      --  If Inserted is True, then this means either that Tree is
      --  empty, or there was a least one node (strictly) greater than
      --  Key. Otherwise, it means that Key is equal to or greater than
      --  every node.

      if Inserted then
         if Y = Tree.First then
            Insert_Post (Tree, Y, True, Node);
            return;
         end if;

         Node := Ops.Previous (Y);

      else
         Node := Y;
      end if;

      --  Here Node has a value that is less than or equal to Key. We
      --  now have to resolve whether Key is equal to or greater than
      --  Node, which determines whether the insertion succeeds.

      if Is_Greater_Key_Node (Key, Node) then
         Insert_Post (Tree, Y, Inserted, Node);
         Inserted := True;
         return;
      end if;

      Inserted := False;
   end Generic_Conditional_Insert;

   ------------------------------------------
   -- Generic_Conditional_Insert_With_Hint --
   ------------------------------------------

   procedure Generic_Conditional_Insert_With_Hint
     (Tree      : in out Tree_Type;
      Position  : Node_Access;
      Key       : Key_Type;
      Node      : out Node_Access;
      Inserted  : out Boolean)
   is
   begin
      --  The purpose of a hint is to avoid a search from the root of
      --  tree. If we have it hint it means we only need to traverse the
      --  subtree rooted at the hint to find the nearest neighbor. Note
      --  that finding the neighbor means merely walking the tree; this
      --  is not a search and the only comparisons that occur are with
      --  the hint and its neighbor.

      --  If Position is null, this is interpreted to mean that Key is
      --  large relative to the nodes in the tree. If the tree is empty,
      --  or Key is greater than the last node in the tree, then we're
      --  done; otherwise the hint was "wrong" and we must search.

      if Position = null then  -- largest
         if Tree.Last = null
           or else Is_Greater_Key_Node (Key, Tree.Last)
         then
            Insert_Post (Tree, Tree.Last, False, Node);
            Inserted := True;
         else
            Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
         end if;

         return;
      end if;

      pragma Assert (Tree.Length > 0);

      --  A hint can either name the node that immediately follows Key,
      --  or immediately precedes Key. We first test whether Key is
      --  less than the hint, and if so we compare Key to the node that
      --  precedes the hint. If Key is both less than the hint and
      --  greater than the hint's preceding neighbor, then we're done;
      --  otherwise we must search.

      --  Note also that a hint can either be an anterior node or a leaf
      --  node. A new node is always inserted at the bottom of the tree
      --  (at least prior to rebalancing), becoming the new left or
      --  right child of leaf node (which prior to the insertion must
      --  necessarily be null, since this is a leaf). If the hint names
      --  an anterior node then its neighbor must be a leaf, and so
      --  (here) we insert after the neighbor. If the hint names a leaf
      --  then its neighbor must be anterior and so we insert before the
      --  hint.

      if Is_Less_Key_Node (Key, Position) then
         declare
            Before : constant Node_Access := Ops.Previous (Position);

         begin
            if Before = null then
               Insert_Post (Tree, Tree.First, True, Node);
               Inserted := True;

            elsif Is_Greater_Key_Node (Key, Before) then
               if Ops.Right (Before) = null then
                  Insert_Post (Tree, Before, False, Node);
               else
                  Insert_Post (Tree, Position, True, Node);
               end if;

               Inserted := True;

            else
               Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
            end if;
         end;

         return;
      end if;

      --  We know that Key isn't less than the hint so we try again,
      --  this time to see if it's greater than the hint. If so we
      --  compare Key to the node that follows the hint. If Key is both
      --  greater than the hint and less than the hint's next neighbor,
      --  then we're done; otherwise we must search.

      if Is_Greater_Key_Node (Key, Position) then
         declare
            After : constant Node_Access := Ops.Next (Position);

         begin
            if After = null then
               Insert_Post (Tree, Tree.Last, False, Node);
               Inserted := True;

            elsif Is_Less_Key_Node (Key, After) then
               if Ops.Right (Position) = null then
                  Insert_Post (Tree, Position, False, Node);
               else
                  Insert_Post (Tree, After, True, Node);
               end if;

               Inserted := True;

            else
               Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
            end if;
         end;

         return;
      end if;

      --  We know that Key is neither less than the hint nor greater
      --  than the hint, and that's the definition of equivalence.
      --  There's nothing else we need to do, since a search would just
      --  reach the same conclusion.

      Node := Position;
      Inserted := False;
   end Generic_Conditional_Insert_With_Hint;

   -------------------------
   -- Generic_Insert_Post --
   -------------------------

   procedure Generic_Insert_Post
     (Tree   : in out Tree_Type;
      Y      : Node_Access;
      Before : Boolean;
      Z      : out Node_Access)
   is
   begin
      if Tree.Length = Count_Type'Last then
         raise Constraint_Error with "too many elements";
      end if;

      if Tree.Busy > 0 then
         raise Program_Error with
           "attempt to tamper with cursors (container is busy)";
      end if;

      Z := New_Node;
      pragma Assert (Z /= null);
      pragma Assert (Ops.Color (Z) = Red);

      if Y = null then
         pragma Assert (Tree.Length = 0);
         pragma Assert (Tree.Root = null);
         pragma Assert (Tree.First = null);
         pragma Assert (Tree.Last = null);

         Tree.Root := Z;
         Tree.First := Z;
         Tree.Last := Z;

      elsif Before then
         pragma Assert (Ops.Left (Y) = null);

         Ops.Set_Left (Y, Z);

         if Y = Tree.First then
            Tree.First := Z;
         end if;

      else
         pragma Assert (Ops.Right (Y) = null);

         Ops.Set_Right (Y, Z);

         if Y = Tree.Last then
            Tree.Last := Z;
         end if;
      end if;

      Ops.Set_Parent (Z, Y);
      Ops.Rebalance_For_Insert (Tree, Z);
      Tree.Length := Tree.Length + 1;
   end Generic_Insert_Post;

   -----------------------
   -- Generic_Iteration --
   -----------------------

   procedure Generic_Iteration
     (Tree : Tree_Type;
      Key  : Key_Type)
   is
      procedure Iterate (Node : Node_Access);

      -------------
      -- Iterate --
      -------------

      procedure Iterate (Node : Node_Access) is
         N : Node_Access;
      begin
         N := Node;
         while N /= null loop
            if Is_Less_Key_Node (Key, N) then
               N := Ops.Left (N);
            elsif Is_Greater_Key_Node (Key, N) then
               N := Ops.Right (N);
            else
               Iterate (Ops.Left (N));
               Process (N);
               N := Ops.Right (N);
            end if;
         end loop;
      end Iterate;

   --  Start of processing for Generic_Iteration

   begin
      Iterate (Tree.Root);
   end Generic_Iteration;

   -------------------------------
   -- Generic_Reverse_Iteration --
   -------------------------------

   procedure Generic_Reverse_Iteration
     (Tree : Tree_Type;
      Key  : Key_Type)
   is
      procedure Iterate (Node : Node_Access);

      -------------
      -- Iterate --
      -------------

      procedure Iterate (Node : Node_Access) is
         N : Node_Access;
      begin
         N := Node;
         while N /= null loop
            if Is_Less_Key_Node (Key, N) then
               N := Ops.Left (N);
            elsif Is_Greater_Key_Node (Key, N) then
               N := Ops.Right (N);
            else
               Iterate (Ops.Right (N));
               Process (N);
               N := Ops.Left (N);
            end if;
         end loop;
      end Iterate;

   --  Start of processing for Generic_Reverse_Iteration

   begin
      Iterate (Tree.Root);
   end Generic_Reverse_Iteration;

   ----------------------------------
   -- Generic_Unconditional_Insert --
   ----------------------------------

   procedure Generic_Unconditional_Insert
     (Tree : in out Tree_Type;
      Key  : Key_Type;
      Node : out Node_Access)
   is
      Y : Node_Access;
      X : Node_Access;

      Before : Boolean;

   begin
      Y := null;
      Before := False;

      X := Tree.Root;
      while X /= null loop
         Y := X;
         Before := Is_Less_Key_Node (Key, X);

         if Before then
            X := Ops.Left (X);
         else
            X := Ops.Right (X);
         end if;
      end loop;

      Insert_Post (Tree, Y, Before, Node);
   end Generic_Unconditional_Insert;

   --------------------------------------------
   -- Generic_Unconditional_Insert_With_Hint --
   --------------------------------------------

   procedure Generic_Unconditional_Insert_With_Hint
     (Tree : in out Tree_Type;
      Hint : Node_Access;
      Key  : Key_Type;
      Node : out Node_Access)
   is
   begin
      --  There are fewer constraints for an unconditional insertion
      --  than for a conditional insertion, since we allow duplicate
      --  keys. So instead of having to check (say) whether Key is
      --  (strictly) greater than the hint's previous neighbor, here we
      --  allow Key to be equal to or greater than the previous node.

      --  There is the issue of what to do if Key is equivalent to the
      --  hint. Does the new node get inserted before or after the hint?
      --  We decide that it gets inserted after the hint, reasoning that
      --  this is consistent with behavior for non-hint insertion, which
      --  inserts a new node after existing nodes with equivalent keys.

      --  First we check whether the hint is null, which is interpreted
      --  to mean that Key is large relative to existing nodes.
      --  Following our rule above, if Key is equal to or greater than
      --  the last node, then we insert the new node immediately after
      --  last. (We don't have an operation for testing whether a key is
      --  "equal to or greater than" a node, so we must say instead "not
      --  less than", which is equivalent.)

      if Hint = null then  -- largest
         if Tree.Last = null then
            Insert_Post (Tree, null, False, Node);
         elsif Is_Less_Key_Node (Key, Tree.Last) then
            Unconditional_Insert_Sans_Hint (Tree, Key, Node);
         else
            Insert_Post (Tree, Tree.Last, False, Node);
         end if;

         return;
      end if;

      pragma Assert (Tree.Length > 0);

      --  We decide here whether to insert the new node prior to the
      --  hint. Key could be equivalent to the hint, so in theory we
      --  could write the following test as "not greater than" (same as
      --  "less than or equal to"). If Key were equivalent to the hint,
      --  that would mean that the new node gets inserted before an
      --  equivalent node. That wouldn't break any container invariants,
      --  but our rule above says that new nodes always get inserted
      --  after equivalent nodes. So here we test whether Key is both
      --  less than the hint and equal to or greater than the hint's
      --  previous neighbor, and if so insert it before the hint.

      if Is_Less_Key_Node (Key, Hint) then
         declare
            Before : constant Node_Access := Ops.Previous (Hint);
         begin
            if Before = null then
               Insert_Post (Tree, Hint, True, Node);
            elsif Is_Less_Key_Node (Key, Before) then
               Unconditional_Insert_Sans_Hint (Tree, Key, Node);
            elsif Ops.Right (Before) = null then
               Insert_Post (Tree, Before, False, Node);
            else
               Insert_Post (Tree, Hint, True, Node);
            end if;
         end;

         return;
      end if;

      --  We know that Key isn't less than the hint, so it must be equal
      --  or greater. So we just test whether Key is less than or equal
      --  to (same as "not greater than") the hint's next neighbor, and
      --  if so insert it after the hint.

      declare
         After : constant Node_Access := Ops.Next (Hint);
      begin
         if After = null then
            Insert_Post (Tree, Hint, False, Node);
         elsif Is_Greater_Key_Node (Key, After) then
            Unconditional_Insert_Sans_Hint (Tree, Key, Node);
         elsif Ops.Right (Hint) = null then
            Insert_Post (Tree, Hint, False, Node);
         else
            Insert_Post (Tree, After, True, Node);
         end if;
      end;
   end Generic_Unconditional_Insert_With_Hint;

   -----------------
   -- Upper_Bound --
   -----------------

   function Upper_Bound
     (Tree : Tree_Type;
      Key  : Key_Type) return Node_Access
   is
      Y : Node_Access;
      X : Node_Access;

   begin
      X := Tree.Root;
      while X /= null loop
         if Is_Less_Key_Node (Key, X) then
            Y := X;
            X := Ops.Left (X);
         else
            X := Ops.Right (X);
         end if;
      end loop;

      return Y;
   end Upper_Bound;

end Ada.Containers.Red_Black_Trees.Generic_Keys;