OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [a-crbtgo.adb] - Blame information for rev 410

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.