OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-rbtgbo.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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