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

Subversion Repositories openrisc_me

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

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.INDEFINITE_ORDERED_SETS                   --
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
with Ada.Containers.Red_Black_Trees.Generic_Operations;
31
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
32
 
33
with Ada.Containers.Red_Black_Trees.Generic_Keys;
34
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
35
 
36
with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
37
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
38
 
39
with Ada.Unchecked_Deallocation;
40
 
41
package body Ada.Containers.Indefinite_Ordered_Sets is
42
 
43
   -----------------------
44
   -- Local Subprograms --
45
   -----------------------
46
 
47
   function Color (Node : Node_Access) return Color_Type;
48
   pragma Inline (Color);
49
 
50
   function Copy_Node (Source : Node_Access) return Node_Access;
51
   pragma Inline (Copy_Node);
52
 
53
   procedure Free (X : in out Node_Access);
54
 
55
   procedure Insert_Sans_Hint
56
     (Tree     : in out Tree_Type;
57
      New_Item : Element_Type;
58
      Node     : out Node_Access;
59
      Inserted : out Boolean);
60
 
61
   procedure Insert_With_Hint
62
     (Dst_Tree : in out Tree_Type;
63
      Dst_Hint : Node_Access;
64
      Src_Node : Node_Access;
65
      Dst_Node : out Node_Access);
66
 
67
   function Is_Greater_Element_Node
68
     (Left  : Element_Type;
69
      Right : Node_Access) return Boolean;
70
   pragma Inline (Is_Greater_Element_Node);
71
 
72
   function Is_Less_Element_Node
73
     (Left  : Element_Type;
74
      Right : Node_Access) return Boolean;
75
   pragma Inline (Is_Less_Element_Node);
76
 
77
   function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
78
   pragma Inline (Is_Less_Node_Node);
79
 
80
   function Left (Node : Node_Access) return Node_Access;
81
   pragma Inline (Left);
82
 
83
   function Parent (Node : Node_Access) return Node_Access;
84
   pragma Inline (Parent);
85
 
86
   procedure Replace_Element
87
     (Tree : in out Tree_Type;
88
      Node : Node_Access;
89
      Item : Element_Type);
90
 
91
   function Right (Node : Node_Access) return Node_Access;
92
   pragma Inline (Right);
93
 
94
   procedure Set_Color (Node : Node_Access; Color : Color_Type);
95
   pragma Inline (Set_Color);
96
 
97
   procedure Set_Left (Node : Node_Access; Left : Node_Access);
98
   pragma Inline (Set_Left);
99
 
100
   procedure Set_Parent (Node   : Node_Access; Parent : Node_Access);
101
   pragma Inline (Set_Parent);
102
 
103
   procedure Set_Right (Node : Node_Access; Right : Node_Access);
104
   pragma Inline (Set_Right);
105
 
106
   --------------------------
107
   -- Local Instantiations --
108
   --------------------------
109
 
110
   procedure Free_Element is
111
     new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
112
 
113
   package Tree_Operations is
114
     new Red_Black_Trees.Generic_Operations (Tree_Types);
115
 
116
   procedure Delete_Tree is
117
     new Tree_Operations.Generic_Delete_Tree (Free);
118
 
119
   function Copy_Tree is
120
     new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
121
 
122
   use Tree_Operations;
123
 
124
   package Element_Keys is
125
     new Red_Black_Trees.Generic_Keys
126
       (Tree_Operations     => Tree_Operations,
127
        Key_Type            => Element_Type,
128
        Is_Less_Key_Node    => Is_Less_Element_Node,
129
        Is_Greater_Key_Node => Is_Greater_Element_Node);
130
 
131
   package Set_Ops is
132
      new Generic_Set_Operations
133
        (Tree_Operations  => Tree_Operations,
134
         Insert_With_Hint => Insert_With_Hint,
135
         Copy_Tree        => Copy_Tree,
136
         Delete_Tree      => Delete_Tree,
137
         Is_Less          => Is_Less_Node_Node,
138
         Free             => Free);
139
 
140
   ---------
141
   -- "<" --
142
   ---------
143
 
144
   function "<" (Left, Right : Cursor) return Boolean is
145
   begin
146
      if Left.Node = null then
147
         raise Constraint_Error with "Left cursor equals No_Element";
148
      end if;
149
 
150
      if Right.Node = null then
151
         raise Constraint_Error with "Right cursor equals No_Element";
152
      end if;
153
 
154
      if Left.Node.Element = null then
155
         raise Program_Error with "Left cursor is bad";
156
      end if;
157
 
158
      if Right.Node.Element = null then
159
         raise Program_Error with "Right cursor is bad";
160
      end if;
161
 
162
      pragma Assert (Vet (Left.Container.Tree, Left.Node),
163
                     "bad Left cursor in ""<""");
164
 
165
      pragma Assert (Vet (Right.Container.Tree, Right.Node),
166
                     "bad Right cursor in ""<""");
167
 
168
      return Left.Node.Element.all < Right.Node.Element.all;
169
   end "<";
170
 
171
   function "<" (Left : Cursor; Right : Element_Type) return Boolean is
172
   begin
173
      if Left.Node = null then
174
         raise Constraint_Error with "Left cursor equals No_Element";
175
      end if;
176
 
177
      if Left.Node.Element = null then
178
         raise Program_Error with "Left cursor is bad";
179
      end if;
180
 
181
      pragma Assert (Vet (Left.Container.Tree, Left.Node),
182
                     "bad Left cursor in ""<""");
183
 
184
      return Left.Node.Element.all < Right;
185
   end "<";
186
 
187
   function "<" (Left : Element_Type; Right : Cursor) return Boolean is
188
   begin
189
      if Right.Node = null then
190
         raise Constraint_Error with "Right cursor equals No_Element";
191
      end if;
192
 
193
      if Right.Node.Element = null then
194
         raise Program_Error with "Right cursor is bad";
195
      end if;
196
 
197
      pragma Assert (Vet (Right.Container.Tree, Right.Node),
198
                     "bad Right cursor in ""<""");
199
 
200
      return Left < Right.Node.Element.all;
201
   end "<";
202
 
203
   ---------
204
   -- "=" --
205
   ---------
206
 
207
   function "=" (Left, Right : Set) return Boolean is
208
 
209
      function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
210
      pragma Inline (Is_Equal_Node_Node);
211
 
212
      function Is_Equal is
213
        new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
214
 
215
      ------------------------
216
      -- Is_Equal_Node_Node --
217
      ------------------------
218
 
219
      function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
220
      begin
221
         return L.Element.all = R.Element.all;
222
      end Is_Equal_Node_Node;
223
 
224
   --  Start of processing for "="
225
 
226
   begin
227
      return Is_Equal (Left.Tree, Right.Tree);
228
   end "=";
229
 
230
   ---------
231
   -- ">" --
232
   ---------
233
 
234
   function ">" (Left, Right : Cursor) return Boolean is
235
   begin
236
      if Left.Node = null then
237
         raise Constraint_Error with "Left cursor equals No_Element";
238
      end if;
239
 
240
      if Right.Node = null then
241
         raise Constraint_Error with "Right cursor equals No_Element";
242
      end if;
243
 
244
      if Left.Node.Element = null then
245
         raise Program_Error with "Left cursor is bad";
246
      end if;
247
 
248
      if Right.Node.Element = null then
249
         raise Program_Error with "Right cursor is bad";
250
      end if;
251
 
252
      pragma Assert (Vet (Left.Container.Tree, Left.Node),
253
                     "bad Left cursor in "">""");
254
 
255
      pragma Assert (Vet (Right.Container.Tree, Right.Node),
256
                     "bad Right cursor in "">""");
257
 
258
      --  L > R same as R < L
259
 
260
      return Right.Node.Element.all < Left.Node.Element.all;
261
   end ">";
262
 
263
   function ">" (Left : Cursor; Right : Element_Type) return Boolean is
264
   begin
265
      if Left.Node = null then
266
         raise Constraint_Error with "Left cursor equals No_Element";
267
      end if;
268
 
269
      if Left.Node.Element = null then
270
         raise Program_Error with "Left cursor is bad";
271
      end if;
272
 
273
      pragma Assert (Vet (Left.Container.Tree, Left.Node),
274
                     "bad Left cursor in "">""");
275
 
276
      return Right < Left.Node.Element.all;
277
   end ">";
278
 
279
   function ">" (Left : Element_Type; Right : Cursor) return Boolean is
280
   begin
281
      if Right.Node = null then
282
         raise Constraint_Error with "Right cursor equals No_Element";
283
      end if;
284
 
285
      if Right.Node.Element = null then
286
         raise Program_Error with "Right cursor is bad";
287
      end if;
288
 
289
      pragma Assert (Vet (Right.Container.Tree, Right.Node),
290
                     "bad Right cursor in "">""");
291
 
292
      return Right.Node.Element.all < Left;
293
   end ">";
294
 
295
   ------------
296
   -- Adjust --
297
   ------------
298
 
299
   procedure Adjust is
300
      new Tree_Operations.Generic_Adjust (Copy_Tree);
301
 
302
   procedure Adjust (Container : in out Set) is
303
   begin
304
      Adjust (Container.Tree);
305
   end Adjust;
306
 
307
   -------------
308
   -- Ceiling --
309
   -------------
310
 
311
   function Ceiling (Container : Set; Item : Element_Type) return Cursor is
312
      Node : constant Node_Access :=
313
               Element_Keys.Ceiling (Container.Tree, Item);
314
 
315
   begin
316
      if Node = null then
317
         return No_Element;
318
      end if;
319
 
320
      return Cursor'(Container'Unrestricted_Access, Node);
321
   end Ceiling;
322
 
323
   -----------
324
   -- Clear --
325
   -----------
326
 
327
   procedure Clear is
328
      new Tree_Operations.Generic_Clear (Delete_Tree);
329
 
330
   procedure Clear (Container : in out Set) is
331
   begin
332
      Clear (Container.Tree);
333
   end Clear;
334
 
335
   -----------
336
   -- Color --
337
   -----------
338
 
339
   function Color (Node : Node_Access) return Color_Type is
340
   begin
341
      return Node.Color;
342
   end Color;
343
 
344
   --------------
345
   -- Contains --
346
   --------------
347
 
348
   function Contains (Container : Set; Item : Element_Type) return Boolean is
349
   begin
350
      return Find (Container, Item) /= No_Element;
351
   end Contains;
352
 
353
   ---------------
354
   -- Copy_Node --
355
   ---------------
356
 
357
   function Copy_Node (Source : Node_Access) return Node_Access is
358
      Element : Element_Access := new Element_Type'(Source.Element.all);
359
 
360
   begin
361
      return new Node_Type'(Parent  => null,
362
                            Left    => null,
363
                            Right   => null,
364
                            Color   => Source.Color,
365
                            Element => Element);
366
   exception
367
      when others =>
368
         Free_Element (Element);
369
         raise;
370
   end Copy_Node;
371
 
372
   ------------
373
   -- Delete --
374
   ------------
375
 
376
   procedure Delete (Container : in out Set; Position : in out Cursor) is
377
   begin
378
      if Position.Node = null then
379
         raise Constraint_Error with "Position cursor equals No_Element";
380
      end if;
381
 
382
      if Position.Node.Element = null then
383
         raise Program_Error with "Position cursor is bad";
384
      end if;
385
 
386
      if Position.Container /= Container'Unrestricted_Access then
387
         raise Program_Error with "Position cursor designates wrong set";
388
      end if;
389
 
390
      pragma Assert (Vet (Container.Tree, Position.Node),
391
                     "bad cursor in Delete");
392
 
393
      Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
394
      Free (Position.Node);
395
      Position.Container := null;
396
   end Delete;
397
 
398
   procedure Delete (Container : in out Set; Item : Element_Type) is
399
      X : Node_Access :=
400
            Element_Keys.Find (Container.Tree, Item);
401
 
402
   begin
403
      if X = null then
404
         raise Constraint_Error with "attempt to delete element not in set";
405
      end if;
406
 
407
      Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
408
      Free (X);
409
   end Delete;
410
 
411
   ------------------
412
   -- Delete_First --
413
   ------------------
414
 
415
   procedure Delete_First (Container : in out Set) is
416
      Tree : Tree_Type renames Container.Tree;
417
      X    : Node_Access := Tree.First;
418
 
419
   begin
420
      if X /= null then
421
         Tree_Operations.Delete_Node_Sans_Free (Tree, X);
422
         Free (X);
423
      end if;
424
   end Delete_First;
425
 
426
   -----------------
427
   -- Delete_Last --
428
   -----------------
429
 
430
   procedure Delete_Last (Container : in out Set) is
431
      Tree : Tree_Type renames Container.Tree;
432
      X    : Node_Access := Tree.Last;
433
 
434
   begin
435
      if X /= null then
436
         Tree_Operations.Delete_Node_Sans_Free (Tree, X);
437
         Free (X);
438
      end if;
439
   end Delete_Last;
440
 
441
   ----------------
442
   -- Difference --
443
   ----------------
444
 
445
   procedure Difference (Target : in out Set; Source : Set) is
446
   begin
447
      Set_Ops.Difference (Target.Tree, Source.Tree);
448
   end Difference;
449
 
450
   function Difference (Left, Right : Set) return Set is
451
      Tree : constant Tree_Type :=
452
               Set_Ops.Difference (Left.Tree, Right.Tree);
453
   begin
454
      return Set'(Controlled with Tree);
455
   end Difference;
456
 
457
   -------------
458
   -- Element --
459
   -------------
460
 
461
   function Element (Position : Cursor) return Element_Type is
462
   begin
463
      if Position.Node = null then
464
         raise Constraint_Error with "Position cursor equals No_Element";
465
      end if;
466
 
467
      if Position.Node.Element = null then
468
         raise Program_Error with "Position cursor is bad";
469
      end if;
470
 
471
      pragma Assert (Vet (Position.Container.Tree, Position.Node),
472
                     "bad cursor in Element");
473
 
474
      return Position.Node.Element.all;
475
   end Element;
476
 
477
   -------------------------
478
   -- Equivalent_Elements --
479
   -------------------------
480
 
481
   function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
482
   begin
483
      if Left < Right
484
        or else Right < Left
485
      then
486
         return False;
487
      else
488
         return True;
489
      end if;
490
   end Equivalent_Elements;
491
 
492
   ---------------------
493
   -- Equivalent_Sets --
494
   ---------------------
495
 
496
   function Equivalent_Sets (Left, Right : Set) return Boolean is
497
 
498
      function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
499
      pragma Inline (Is_Equivalent_Node_Node);
500
 
501
      function Is_Equivalent is
502
         new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
503
 
504
      -----------------------------
505
      -- Is_Equivalent_Node_Node --
506
      -----------------------------
507
 
508
      function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
509
      begin
510
         if L.Element.all < R.Element.all then
511
            return False;
512
         elsif R.Element.all < L.Element.all then
513
            return False;
514
         else
515
            return True;
516
         end if;
517
      end Is_Equivalent_Node_Node;
518
 
519
   --  Start of processing for Equivalent_Sets
520
 
521
   begin
522
      return Is_Equivalent (Left.Tree, Right.Tree);
523
   end Equivalent_Sets;
524
 
525
   -------------
526
   -- Exclude --
527
   -------------
528
 
529
   procedure Exclude (Container : in out Set; Item : Element_Type) is
530
      X : Node_Access :=
531
            Element_Keys.Find (Container.Tree, Item);
532
 
533
   begin
534
      if X /= null then
535
         Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
536
         Free (X);
537
      end if;
538
   end Exclude;
539
 
540
   ----------
541
   -- Find --
542
   ----------
543
 
544
   function Find (Container : Set; Item : Element_Type) return Cursor is
545
      Node : constant Node_Access :=
546
               Element_Keys.Find (Container.Tree, Item);
547
 
548
   begin
549
      if Node = null then
550
         return No_Element;
551
      end if;
552
 
553
      return Cursor'(Container'Unrestricted_Access, Node);
554
   end Find;
555
 
556
   -----------
557
   -- First --
558
   -----------
559
 
560
   function First (Container : Set) return Cursor is
561
   begin
562
      if Container.Tree.First = null then
563
         return No_Element;
564
      end if;
565
 
566
      return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
567
   end First;
568
 
569
   -------------------
570
   -- First_Element --
571
   -------------------
572
 
573
   function First_Element (Container : Set) return Element_Type is
574
   begin
575
      if Container.Tree.First = null then
576
         raise Constraint_Error with "set is empty";
577
      end if;
578
 
579
      return Container.Tree.First.Element.all;
580
   end First_Element;
581
 
582
   -----------
583
   -- Floor --
584
   -----------
585
 
586
   function Floor (Container : Set; Item : Element_Type) return Cursor is
587
      Node : constant Node_Access :=
588
               Element_Keys.Floor (Container.Tree, Item);
589
 
590
   begin
591
      if Node = null then
592
         return No_Element;
593
      end if;
594
 
595
      return Cursor'(Container'Unrestricted_Access, Node);
596
   end Floor;
597
 
598
   ----------
599
   -- Free --
600
   ----------
601
 
602
   procedure Free (X : in out Node_Access) is
603
      procedure Deallocate is
604
        new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
605
 
606
   begin
607
      if X = null then
608
         return;
609
      end if;
610
 
611
      X.Parent := X;
612
      X.Left := X;
613
      X.Right := X;
614
 
615
      begin
616
         Free_Element (X.Element);
617
      exception
618
         when others =>
619
            X.Element := null;
620
            Deallocate (X);
621
            raise;
622
      end;
623
 
624
      Deallocate (X);
625
   end Free;
626
 
627
   ------------------
628
   -- Generic_Keys --
629
   ------------------
630
 
631
   package body Generic_Keys is
632
 
633
      -----------------------
634
      -- Local Subprograms --
635
      -----------------------
636
 
637
      function Is_Greater_Key_Node
638
        (Left  : Key_Type;
639
         Right : Node_Access) return Boolean;
640
      pragma Inline (Is_Greater_Key_Node);
641
 
642
      function Is_Less_Key_Node
643
        (Left  : Key_Type;
644
         Right : Node_Access) return Boolean;
645
      pragma Inline (Is_Less_Key_Node);
646
 
647
      --------------------------
648
      -- Local Instantiations --
649
      --------------------------
650
 
651
      package Key_Keys is
652
        new Red_Black_Trees.Generic_Keys
653
          (Tree_Operations     => Tree_Operations,
654
           Key_Type            => Key_Type,
655
           Is_Less_Key_Node    => Is_Less_Key_Node,
656
           Is_Greater_Key_Node => Is_Greater_Key_Node);
657
 
658
      -------------
659
      -- Ceiling --
660
      -------------
661
 
662
      function Ceiling (Container : Set; Key : Key_Type) return Cursor is
663
         Node : constant Node_Access :=
664
                  Key_Keys.Ceiling (Container.Tree, Key);
665
 
666
      begin
667
         if Node = null then
668
            return No_Element;
669
         end if;
670
 
671
         return Cursor'(Container'Unrestricted_Access, Node);
672
      end Ceiling;
673
 
674
      --------------
675
      -- Contains --
676
      --------------
677
 
678
      function Contains (Container : Set; Key : Key_Type) return Boolean is
679
      begin
680
         return Find (Container, Key) /= No_Element;
681
      end Contains;
682
 
683
      ------------
684
      -- Delete --
685
      ------------
686
 
687
      procedure Delete (Container : in out Set; Key : Key_Type) is
688
         X : Node_Access := Key_Keys.Find (Container.Tree, Key);
689
 
690
      begin
691
         if X = null then
692
            raise Constraint_Error with "attempt to delete key not in set";
693
         end if;
694
 
695
         Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
696
         Free (X);
697
      end Delete;
698
 
699
      -------------
700
      -- Element --
701
      -------------
702
 
703
      function Element (Container : Set; Key : Key_Type) return Element_Type is
704
         Node : constant Node_Access :=
705
                  Key_Keys.Find (Container.Tree, Key);
706
 
707
      begin
708
         if Node = null then
709
            raise Constraint_Error with "key not in set";
710
         end if;
711
 
712
         return Node.Element.all;
713
      end Element;
714
 
715
      ---------------------
716
      -- Equivalent_Keys --
717
      ---------------------
718
 
719
      function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
720
      begin
721
         if Left < Right
722
           or else Right < Left
723
         then
724
            return False;
725
         else
726
            return True;
727
         end if;
728
      end Equivalent_Keys;
729
 
730
      -------------
731
      -- Exclude --
732
      -------------
733
 
734
      procedure Exclude (Container : in out Set; Key : Key_Type) is
735
         X : Node_Access := Key_Keys.Find (Container.Tree, Key);
736
 
737
      begin
738
         if X /= null then
739
            Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
740
            Free (X);
741
         end if;
742
      end Exclude;
743
 
744
      ----------
745
      -- Find --
746
      ----------
747
 
748
      function Find (Container : Set; Key : Key_Type) return Cursor is
749
         Node : constant Node_Access :=
750
                  Key_Keys.Find (Container.Tree, Key);
751
 
752
      begin
753
         if Node = null then
754
            return No_Element;
755
         end if;
756
 
757
         return Cursor'(Container'Unrestricted_Access, Node);
758
      end Find;
759
 
760
      -----------
761
      -- Floor --
762
      -----------
763
 
764
      function Floor (Container : Set; Key : Key_Type) return Cursor is
765
         Node : constant Node_Access :=
766
                  Key_Keys.Floor (Container.Tree, Key);
767
 
768
      begin
769
         if Node = null then
770
            return No_Element;
771
         end if;
772
 
773
         return Cursor'(Container'Unrestricted_Access, Node);
774
      end Floor;
775
 
776
      -------------------------
777
      -- Is_Greater_Key_Node --
778
      -------------------------
779
 
780
      function Is_Greater_Key_Node
781
        (Left  : Key_Type;
782
         Right : Node_Access) return Boolean is
783
      begin
784
         return Key (Right.Element.all) < Left;
785
      end Is_Greater_Key_Node;
786
 
787
      ----------------------
788
      -- Is_Less_Key_Node --
789
      ----------------------
790
 
791
      function Is_Less_Key_Node
792
        (Left  : Key_Type;
793
         Right : Node_Access) return Boolean is
794
      begin
795
         return Left < Key (Right.Element.all);
796
      end Is_Less_Key_Node;
797
 
798
      ---------
799
      -- Key --
800
      ---------
801
 
802
      function Key (Position : Cursor) return Key_Type is
803
      begin
804
         if Position.Node = null then
805
            raise Constraint_Error with
806
              "Position cursor equals No_Element";
807
         end if;
808
 
809
         if Position.Node.Element = null then
810
            raise Program_Error with
811
              "Position cursor is bad";
812
         end if;
813
 
814
         pragma Assert (Vet (Position.Container.Tree, Position.Node),
815
                        "bad cursor in Key");
816
 
817
         return Key (Position.Node.Element.all);
818
      end Key;
819
 
820
      -------------
821
      -- Replace --
822
      -------------
823
 
824
      procedure Replace
825
        (Container : in out Set;
826
         Key       : Key_Type;
827
         New_Item  : Element_Type)
828
      is
829
         Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
830
 
831
      begin
832
         if Node = null then
833
            raise Constraint_Error with
834
              "attempt to replace key not in set";
835
         end if;
836
 
837
         Replace_Element (Container.Tree, Node, New_Item);
838
      end Replace;
839
 
840
      -----------------------------------
841
      -- Update_Element_Preserving_Key --
842
      -----------------------------------
843
 
844
      procedure Update_Element_Preserving_Key
845
        (Container : in out Set;
846
         Position  : Cursor;
847
         Process   : not null access
848
                        procedure (Element : in out Element_Type))
849
      is
850
         Tree : Tree_Type renames Container.Tree;
851
 
852
      begin
853
         if Position.Node = null then
854
            raise Constraint_Error with "Position cursor equals No_Element";
855
         end if;
856
 
857
         if Position.Node.Element = null then
858
            raise Program_Error with "Position cursor is bad";
859
         end if;
860
 
861
         if Position.Container /= Container'Unrestricted_Access then
862
            raise Program_Error with "Position cursor designates wrong set";
863
         end if;
864
 
865
         pragma Assert (Vet (Container.Tree, Position.Node),
866
                        "bad cursor in Update_Element_Preserving_Key");
867
 
868
         declare
869
            E : Element_Type renames Position.Node.Element.all;
870
            K : constant Key_Type := Key (E);
871
 
872
            B : Natural renames Tree.Busy;
873
            L : Natural renames Tree.Lock;
874
 
875
         begin
876
            B := B + 1;
877
            L := L + 1;
878
 
879
            begin
880
               Process (E);
881
            exception
882
               when others =>
883
                  L := L - 1;
884
                  B := B - 1;
885
                  raise;
886
            end;
887
 
888
            L := L - 1;
889
            B := B - 1;
890
 
891
            if Equivalent_Keys (K, Key (E)) then
892
               return;
893
            end if;
894
         end;
895
 
896
         declare
897
            X : Node_Access := Position.Node;
898
         begin
899
            Tree_Operations.Delete_Node_Sans_Free (Tree, X);
900
            Free (X);
901
         end;
902
 
903
         raise Program_Error with "key was modified";
904
      end Update_Element_Preserving_Key;
905
 
906
   end Generic_Keys;
907
 
908
   -----------------
909
   -- Has_Element --
910
   -----------------
911
 
912
   function Has_Element (Position : Cursor) return Boolean is
913
   begin
914
      return Position /= No_Element;
915
   end Has_Element;
916
 
917
   -------------
918
   -- Include --
919
   -------------
920
 
921
   procedure Include (Container : in out Set; New_Item  : Element_Type) is
922
      Position : Cursor;
923
      Inserted : Boolean;
924
 
925
      X : Element_Access;
926
 
927
   begin
928
      Insert (Container, New_Item, Position, Inserted);
929
 
930
      if not Inserted then
931
         if Container.Tree.Lock > 0 then
932
            raise Program_Error with
933
              "attempt to tamper with cursors (set is locked)";
934
         end if;
935
 
936
         X := Position.Node.Element;
937
         Position.Node.Element := new Element_Type'(New_Item);
938
         Free_Element (X);
939
      end if;
940
   end Include;
941
 
942
   ------------
943
   -- Insert --
944
   ------------
945
 
946
   procedure Insert
947
     (Container : in out Set;
948
      New_Item  : Element_Type;
949
      Position  : out Cursor;
950
      Inserted  : out Boolean)
951
   is
952
   begin
953
      Insert_Sans_Hint
954
        (Container.Tree,
955
         New_Item,
956
         Position.Node,
957
         Inserted);
958
 
959
      Position.Container := Container'Unrestricted_Access;
960
   end Insert;
961
 
962
   procedure Insert (Container : in out Set; New_Item  : Element_Type) is
963
      Position : Cursor;
964
      pragma Unreferenced (Position);
965
 
966
      Inserted : Boolean;
967
 
968
   begin
969
      Insert (Container, New_Item, Position, Inserted);
970
 
971
      if not Inserted then
972
         raise Constraint_Error with
973
           "attempt to insert element already in set";
974
      end if;
975
   end Insert;
976
 
977
   ----------------------
978
   -- Insert_Sans_Hint --
979
   ----------------------
980
 
981
   procedure Insert_Sans_Hint
982
     (Tree     : in out Tree_Type;
983
      New_Item : Element_Type;
984
      Node     : out Node_Access;
985
      Inserted : out Boolean)
986
   is
987
      function New_Node return Node_Access;
988
      pragma Inline (New_Node);
989
 
990
      procedure Insert_Post is
991
        new Element_Keys.Generic_Insert_Post (New_Node);
992
 
993
      procedure Conditional_Insert_Sans_Hint is
994
        new Element_Keys.Generic_Conditional_Insert (Insert_Post);
995
 
996
      --------------
997
      -- New_Node --
998
      --------------
999
 
1000
      function New_Node return Node_Access is
1001
         Element : Element_Access := new Element_Type'(New_Item);
1002
 
1003
      begin
1004
         return new Node_Type'(Parent  => null,
1005
                               Left    => null,
1006
                               Right   => null,
1007
                               Color   => Red_Black_Trees.Red,
1008
                               Element => Element);
1009
      exception
1010
         when others =>
1011
            Free_Element (Element);
1012
            raise;
1013
      end New_Node;
1014
 
1015
   --  Start of processing for Insert_Sans_Hint
1016
 
1017
   begin
1018
      Conditional_Insert_Sans_Hint
1019
        (Tree,
1020
         New_Item,
1021
         Node,
1022
         Inserted);
1023
   end Insert_Sans_Hint;
1024
 
1025
   ----------------------
1026
   -- Insert_With_Hint --
1027
   ----------------------
1028
 
1029
   procedure Insert_With_Hint
1030
     (Dst_Tree : in out Tree_Type;
1031
      Dst_Hint : Node_Access;
1032
      Src_Node : Node_Access;
1033
      Dst_Node : out Node_Access)
1034
   is
1035
      Success : Boolean;
1036
      pragma Unreferenced (Success);
1037
 
1038
      function New_Node return Node_Access;
1039
 
1040
      procedure Insert_Post is
1041
        new Element_Keys.Generic_Insert_Post (New_Node);
1042
 
1043
      procedure Insert_Sans_Hint is
1044
        new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1045
 
1046
      procedure Insert_With_Hint is
1047
         new Element_Keys.Generic_Conditional_Insert_With_Hint
1048
            (Insert_Post,
1049
             Insert_Sans_Hint);
1050
 
1051
      --------------
1052
      -- New_Node --
1053
      --------------
1054
 
1055
      function New_Node return Node_Access is
1056
         Element : Element_Access :=
1057
                     new Element_Type'(Src_Node.Element.all);
1058
         Node    : Node_Access;
1059
 
1060
      begin
1061
         begin
1062
            Node := new Node_Type;
1063
         exception
1064
            when others =>
1065
               Free_Element (Element);
1066
               raise;
1067
         end;
1068
 
1069
         Node.Element := Element;
1070
         return Node;
1071
      end New_Node;
1072
 
1073
   --  Start of processing for Insert_With_Hint
1074
 
1075
   begin
1076
      Insert_With_Hint
1077
        (Dst_Tree,
1078
         Dst_Hint,
1079
         Src_Node.Element.all,
1080
         Dst_Node,
1081
         Success);
1082
   end Insert_With_Hint;
1083
 
1084
   ------------------
1085
   -- Intersection --
1086
   ------------------
1087
 
1088
   procedure Intersection (Target : in out Set; Source : Set) is
1089
   begin
1090
      Set_Ops.Intersection (Target.Tree, Source.Tree);
1091
   end Intersection;
1092
 
1093
   function Intersection (Left, Right : Set) return Set is
1094
      Tree : constant Tree_Type :=
1095
               Set_Ops.Intersection (Left.Tree, Right.Tree);
1096
   begin
1097
      return Set'(Controlled with Tree);
1098
   end Intersection;
1099
 
1100
   --------------
1101
   -- Is_Empty --
1102
   --------------
1103
 
1104
   function Is_Empty (Container : Set) return Boolean is
1105
   begin
1106
      return Container.Tree.Length = 0;
1107
   end Is_Empty;
1108
 
1109
   -----------------------------
1110
   -- Is_Greater_Element_Node --
1111
   -----------------------------
1112
 
1113
   function Is_Greater_Element_Node
1114
     (Left  : Element_Type;
1115
      Right : Node_Access) return Boolean is
1116
   begin
1117
      --  e > node same as node < e
1118
 
1119
      return Right.Element.all < Left;
1120
   end Is_Greater_Element_Node;
1121
 
1122
   --------------------------
1123
   -- Is_Less_Element_Node --
1124
   --------------------------
1125
 
1126
   function Is_Less_Element_Node
1127
     (Left  : Element_Type;
1128
      Right : Node_Access) return Boolean is
1129
   begin
1130
      return Left < Right.Element.all;
1131
   end Is_Less_Element_Node;
1132
 
1133
   -----------------------
1134
   -- Is_Less_Node_Node --
1135
   -----------------------
1136
 
1137
   function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1138
   begin
1139
      return L.Element.all < R.Element.all;
1140
   end Is_Less_Node_Node;
1141
 
1142
   ---------------
1143
   -- Is_Subset --
1144
   ---------------
1145
 
1146
   function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1147
   begin
1148
      return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1149
   end Is_Subset;
1150
 
1151
   -------------
1152
   -- Iterate --
1153
   -------------
1154
 
1155
   procedure Iterate
1156
     (Container : Set;
1157
      Process   : not null access procedure (Position : Cursor))
1158
   is
1159
      procedure Process_Node (Node : Node_Access);
1160
      pragma Inline (Process_Node);
1161
 
1162
      procedure Local_Iterate is
1163
        new Tree_Operations.Generic_Iteration (Process_Node);
1164
 
1165
      ------------------
1166
      -- Process_Node --
1167
      ------------------
1168
 
1169
      procedure Process_Node (Node : Node_Access) is
1170
      begin
1171
         Process (Cursor'(Container'Unrestricted_Access, Node));
1172
      end Process_Node;
1173
 
1174
      T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1175
      B : Natural renames T.Busy;
1176
 
1177
   --  Start of processing for Iterate
1178
 
1179
   begin
1180
      B := B + 1;
1181
 
1182
      begin
1183
         Local_Iterate (T);
1184
      exception
1185
         when others =>
1186
            B := B - 1;
1187
            raise;
1188
      end;
1189
 
1190
      B := B - 1;
1191
   end Iterate;
1192
 
1193
   ----------
1194
   -- Last --
1195
   ----------
1196
 
1197
   function Last (Container : Set) return Cursor is
1198
   begin
1199
      if Container.Tree.Last = null then
1200
         return No_Element;
1201
      end if;
1202
 
1203
      return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
1204
   end Last;
1205
 
1206
   ------------------
1207
   -- Last_Element --
1208
   ------------------
1209
 
1210
   function Last_Element (Container : Set) return Element_Type is
1211
   begin
1212
      if Container.Tree.Last = null then
1213
         raise Constraint_Error with "set is empty";
1214
      end if;
1215
 
1216
      return Container.Tree.Last.Element.all;
1217
   end Last_Element;
1218
 
1219
   ----------
1220
   -- Left --
1221
   ----------
1222
 
1223
   function Left (Node : Node_Access) return Node_Access is
1224
   begin
1225
      return Node.Left;
1226
   end Left;
1227
 
1228
   ------------
1229
   -- Length --
1230
   ------------
1231
 
1232
   function Length (Container : Set) return Count_Type is
1233
   begin
1234
      return Container.Tree.Length;
1235
   end Length;
1236
 
1237
   ----------
1238
   -- Move --
1239
   ----------
1240
 
1241
   procedure Move is
1242
      new Tree_Operations.Generic_Move (Clear);
1243
 
1244
   procedure Move (Target : in out Set; Source : in out Set) is
1245
   begin
1246
      Move (Target => Target.Tree, Source => Source.Tree);
1247
   end Move;
1248
 
1249
   ----------
1250
   -- Next --
1251
   ----------
1252
 
1253
   procedure Next (Position : in out Cursor) is
1254
   begin
1255
      Position := Next (Position);
1256
   end Next;
1257
 
1258
   function Next (Position : Cursor) return Cursor is
1259
   begin
1260
      if Position = No_Element then
1261
         return No_Element;
1262
      end if;
1263
 
1264
      if Position.Node.Element = null then
1265
         raise Program_Error with "Position cursor is bad";
1266
      end if;
1267
 
1268
      pragma Assert (Vet (Position.Container.Tree, Position.Node),
1269
                     "bad cursor in Next");
1270
 
1271
      declare
1272
         Node : constant Node_Access :=
1273
                  Tree_Operations.Next (Position.Node);
1274
 
1275
      begin
1276
         if Node = null then
1277
            return No_Element;
1278
         end if;
1279
 
1280
         return Cursor'(Position.Container, Node);
1281
      end;
1282
   end Next;
1283
 
1284
   -------------
1285
   -- Overlap --
1286
   -------------
1287
 
1288
   function Overlap (Left, Right : Set) return Boolean is
1289
   begin
1290
      return Set_Ops.Overlap (Left.Tree, Right.Tree);
1291
   end Overlap;
1292
 
1293
   ------------
1294
   -- Parent --
1295
   ------------
1296
 
1297
   function Parent (Node : Node_Access) return Node_Access is
1298
   begin
1299
      return Node.Parent;
1300
   end Parent;
1301
 
1302
   --------------
1303
   -- Previous --
1304
   --------------
1305
 
1306
   procedure Previous (Position : in out Cursor) is
1307
   begin
1308
      Position := Previous (Position);
1309
   end Previous;
1310
 
1311
   function Previous (Position : Cursor) return Cursor is
1312
   begin
1313
      if Position = No_Element then
1314
         return No_Element;
1315
      end if;
1316
 
1317
      if Position.Node.Element = null then
1318
         raise Program_Error with "Position cursor is bad";
1319
      end if;
1320
 
1321
      pragma Assert (Vet (Position.Container.Tree, Position.Node),
1322
                     "bad cursor in Previous");
1323
 
1324
      declare
1325
         Node : constant Node_Access :=
1326
                  Tree_Operations.Previous (Position.Node);
1327
 
1328
      begin
1329
         if Node = null then
1330
            return No_Element;
1331
         end if;
1332
 
1333
         return Cursor'(Position.Container, Node);
1334
      end;
1335
   end Previous;
1336
 
1337
   -------------------
1338
   -- Query_Element --
1339
   -------------------
1340
 
1341
   procedure Query_Element
1342
     (Position  : Cursor;
1343
      Process   : not null access procedure (Element : Element_Type))
1344
   is
1345
   begin
1346
      if Position.Node = null then
1347
         raise Constraint_Error with "Position cursor equals No_Element";
1348
      end if;
1349
 
1350
      if Position.Node.Element = null then
1351
         raise Program_Error with "Position cursor is bad";
1352
      end if;
1353
 
1354
      pragma Assert (Vet (Position.Container.Tree, Position.Node),
1355
                     "bad cursor in Query_Element");
1356
 
1357
      declare
1358
         T : Tree_Type renames Position.Container.Tree;
1359
 
1360
         B : Natural renames T.Busy;
1361
         L : Natural renames T.Lock;
1362
 
1363
      begin
1364
         B := B + 1;
1365
         L := L + 1;
1366
 
1367
         begin
1368
            Process (Position.Node.Element.all);
1369
         exception
1370
            when others =>
1371
               L := L - 1;
1372
               B := B - 1;
1373
               raise;
1374
         end;
1375
 
1376
         L := L - 1;
1377
         B := B - 1;
1378
      end;
1379
   end Query_Element;
1380
 
1381
   ----------
1382
   -- Read --
1383
   ----------
1384
 
1385
   procedure Read
1386
     (Stream    : not null access Root_Stream_Type'Class;
1387
      Container : out Set)
1388
   is
1389
      function Read_Node
1390
        (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1391
      pragma Inline (Read_Node);
1392
 
1393
      procedure Read is
1394
         new Tree_Operations.Generic_Read (Clear, Read_Node);
1395
 
1396
      ---------------
1397
      -- Read_Node --
1398
      ---------------
1399
 
1400
      function Read_Node
1401
        (Stream : not null access Root_Stream_Type'Class) return Node_Access
1402
      is
1403
         Node : Node_Access := new Node_Type;
1404
 
1405
      begin
1406
         Node.Element := new Element_Type'(Element_Type'Input (Stream));
1407
         return Node;
1408
 
1409
      exception
1410
         when others =>
1411
            Free (Node);  --  Note that Free deallocates elem too
1412
            raise;
1413
      end Read_Node;
1414
 
1415
   --  Start of processing for Read
1416
 
1417
   begin
1418
      Read (Stream, Container.Tree);
1419
   end Read;
1420
 
1421
   procedure Read
1422
     (Stream : not null access Root_Stream_Type'Class;
1423
      Item   : out Cursor)
1424
   is
1425
   begin
1426
      raise Program_Error with "attempt to stream set cursor";
1427
   end Read;
1428
 
1429
   -------------
1430
   -- Replace --
1431
   -------------
1432
 
1433
   procedure Replace (Container : in out Set; New_Item : Element_Type) is
1434
      Node : constant Node_Access :=
1435
               Element_Keys.Find (Container.Tree, New_Item);
1436
 
1437
      X : Element_Access;
1438
      pragma Warnings (Off, X);
1439
 
1440
   begin
1441
      if Node = null then
1442
         raise Constraint_Error with "attempt to replace element not in set";
1443
      end if;
1444
 
1445
      if Container.Tree.Lock > 0 then
1446
         raise Program_Error with
1447
           "attempt to tamper with cursors (set is locked)";
1448
      end if;
1449
 
1450
      X := Node.Element;
1451
      Node.Element := new Element_Type'(New_Item);
1452
      Free_Element (X);
1453
   end Replace;
1454
 
1455
   ---------------------
1456
   -- Replace_Element --
1457
   ---------------------
1458
 
1459
   procedure Replace_Element
1460
     (Tree : in out Tree_Type;
1461
      Node : Node_Access;
1462
      Item : Element_Type)
1463
   is
1464
      pragma Assert (Node /= null);
1465
      pragma Assert (Node.Element /= null);
1466
 
1467
      function New_Node return Node_Access;
1468
      pragma Inline (New_Node);
1469
 
1470
      procedure Local_Insert_Post is
1471
         new Element_Keys.Generic_Insert_Post (New_Node);
1472
 
1473
      procedure Local_Insert_Sans_Hint is
1474
         new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
1475
 
1476
      procedure Local_Insert_With_Hint is
1477
         new Element_Keys.Generic_Conditional_Insert_With_Hint
1478
        (Local_Insert_Post,
1479
         Local_Insert_Sans_Hint);
1480
 
1481
      --------------
1482
      -- New_Node --
1483
      --------------
1484
 
1485
      function New_Node return Node_Access is
1486
      begin
1487
         Node.Element := new Element_Type'(Item);  -- OK if fails
1488
         Node.Color := Red;
1489
         Node.Parent := null;
1490
         Node.Right := null;
1491
         Node.Left := null;
1492
 
1493
         return Node;
1494
      end New_Node;
1495
 
1496
      Hint     : Node_Access;
1497
      Result   : Node_Access;
1498
      Inserted : Boolean;
1499
 
1500
      X : Element_Access := Node.Element;
1501
 
1502
      --  Start of processing for Insert
1503
 
1504
   begin
1505
      if Item < Node.Element.all
1506
        or else Node.Element.all < Item
1507
      then
1508
         null;
1509
 
1510
      else
1511
         if Tree.Lock > 0 then
1512
            raise Program_Error with
1513
              "attempt to tamper with cursors (set is locked)";
1514
         end if;
1515
 
1516
         Node.Element := new Element_Type'(Item);
1517
         Free_Element (X);
1518
 
1519
         return;
1520
      end if;
1521
 
1522
      Hint := Element_Keys.Ceiling (Tree, Item);
1523
 
1524
      if Hint = null then
1525
         null;
1526
 
1527
      elsif Item < Hint.Element.all then
1528
         if Hint = Node then
1529
            if Tree.Lock > 0 then
1530
               raise Program_Error with
1531
                 "attempt to tamper with cursors (set is locked)";
1532
            end if;
1533
 
1534
            Node.Element := new Element_Type'(Item);
1535
            Free_Element (X);
1536
 
1537
            return;
1538
         end if;
1539
 
1540
      else
1541
         pragma Assert (not (Hint.Element.all < Item));
1542
         raise Program_Error with "attempt to replace existing element";
1543
      end if;
1544
 
1545
      Tree_Operations.Delete_Node_Sans_Free (Tree, Node);  -- Checks busy-bit
1546
 
1547
      Local_Insert_With_Hint
1548
        (Tree     => Tree,
1549
         Position => Hint,
1550
         Key      => Item,
1551
         Node     => Result,
1552
         Inserted => Inserted);
1553
 
1554
      pragma Assert (Inserted);
1555
      pragma Assert (Result = Node);
1556
 
1557
      Free_Element (X);
1558
   end Replace_Element;
1559
 
1560
   procedure Replace_Element
1561
    (Container : in out Set;
1562
     Position  : Cursor;
1563
     New_Item  : Element_Type)
1564
   is
1565
   begin
1566
      if Position.Node = null then
1567
         raise Constraint_Error with "Position cursor equals No_Element";
1568
      end if;
1569
 
1570
      if Position.Node.Element = null then
1571
         raise Program_Error with "Position cursor is bad";
1572
      end if;
1573
 
1574
      if Position.Container /= Container'Unrestricted_Access then
1575
         raise Program_Error with "Position cursor designates wrong set";
1576
      end if;
1577
 
1578
      pragma Assert (Vet (Container.Tree, Position.Node),
1579
                     "bad cursor in Replace_Element");
1580
 
1581
      Replace_Element (Container.Tree, Position.Node, New_Item);
1582
   end Replace_Element;
1583
 
1584
   ---------------------
1585
   -- Reverse_Iterate --
1586
   ---------------------
1587
 
1588
   procedure Reverse_Iterate
1589
     (Container : Set;
1590
      Process   : not null access procedure (Position : Cursor))
1591
   is
1592
      procedure Process_Node (Node : Node_Access);
1593
      pragma Inline (Process_Node);
1594
 
1595
      procedure Local_Reverse_Iterate is
1596
         new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1597
 
1598
      ------------------
1599
      -- Process_Node --
1600
      ------------------
1601
 
1602
      procedure Process_Node (Node : Node_Access) is
1603
      begin
1604
         Process (Cursor'(Container'Unrestricted_Access, Node));
1605
      end Process_Node;
1606
 
1607
      T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
1608
      B : Natural renames T.Busy;
1609
 
1610
   --  Start of processing for Reverse_Iterate
1611
 
1612
   begin
1613
      B := B + 1;
1614
 
1615
      begin
1616
         Local_Reverse_Iterate (T);
1617
      exception
1618
         when others =>
1619
            B := B - 1;
1620
            raise;
1621
      end;
1622
 
1623
      B := B - 1;
1624
   end Reverse_Iterate;
1625
 
1626
   -----------
1627
   -- Right --
1628
   -----------
1629
 
1630
   function Right (Node : Node_Access) return Node_Access is
1631
   begin
1632
      return Node.Right;
1633
   end Right;
1634
 
1635
   ---------------
1636
   -- Set_Color --
1637
   ---------------
1638
 
1639
   procedure Set_Color (Node : Node_Access; Color : Color_Type) is
1640
   begin
1641
      Node.Color := Color;
1642
   end Set_Color;
1643
 
1644
   --------------
1645
   -- Set_Left --
1646
   --------------
1647
 
1648
   procedure Set_Left (Node : Node_Access; Left : Node_Access) is
1649
   begin
1650
      Node.Left := Left;
1651
   end Set_Left;
1652
 
1653
   ----------------
1654
   -- Set_Parent --
1655
   ----------------
1656
 
1657
   procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
1658
   begin
1659
      Node.Parent := Parent;
1660
   end Set_Parent;
1661
 
1662
   ---------------
1663
   -- Set_Right --
1664
   ---------------
1665
 
1666
   procedure Set_Right (Node : Node_Access; Right : Node_Access) is
1667
   begin
1668
      Node.Right := Right;
1669
   end Set_Right;
1670
 
1671
   --------------------------
1672
   -- Symmetric_Difference --
1673
   --------------------------
1674
 
1675
   procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1676
   begin
1677
      Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
1678
   end Symmetric_Difference;
1679
 
1680
   function Symmetric_Difference (Left, Right : Set) return Set is
1681
      Tree : constant Tree_Type :=
1682
               Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
1683
   begin
1684
      return Set'(Controlled with Tree);
1685
   end Symmetric_Difference;
1686
 
1687
   ------------
1688
   -- To_Set --
1689
   ------------
1690
 
1691
   function To_Set (New_Item : Element_Type) return Set is
1692
      Tree : Tree_Type;
1693
 
1694
      Node     : Node_Access;
1695
      Inserted : Boolean;
1696
      pragma Unreferenced (Node, Inserted);
1697
 
1698
   begin
1699
      Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
1700
      return Set'(Controlled with Tree);
1701
   end To_Set;
1702
 
1703
   -----------
1704
   -- Union --
1705
   -----------
1706
 
1707
   procedure Union (Target : in out Set; Source : Set) is
1708
   begin
1709
      Set_Ops.Union (Target.Tree, Source.Tree);
1710
   end Union;
1711
 
1712
   function Union (Left, Right : Set) return Set is
1713
      Tree : constant Tree_Type :=
1714
               Set_Ops.Union (Left.Tree, Right.Tree);
1715
   begin
1716
      return Set'(Controlled with Tree);
1717
   end Union;
1718
 
1719
   -----------
1720
   -- Write --
1721
   -----------
1722
 
1723
   procedure Write
1724
     (Stream    : not null access Root_Stream_Type'Class;
1725
      Container : Set)
1726
   is
1727
      procedure Write_Node
1728
        (Stream : not null access Root_Stream_Type'Class;
1729
         Node   : Node_Access);
1730
      pragma Inline (Write_Node);
1731
 
1732
      procedure Write is
1733
         new Tree_Operations.Generic_Write (Write_Node);
1734
 
1735
      ----------------
1736
      -- Write_Node --
1737
      ----------------
1738
 
1739
      procedure Write_Node
1740
        (Stream : not null access Root_Stream_Type'Class;
1741
         Node   : Node_Access)
1742
      is
1743
      begin
1744
         Element_Type'Output (Stream, Node.Element.all);
1745
      end Write_Node;
1746
 
1747
   --  Start of processing for Write
1748
 
1749
   begin
1750
      Write (Stream, Container.Tree);
1751
   end Write;
1752
 
1753
   procedure Write
1754
     (Stream : not null access Root_Stream_Type'Class;
1755
      Item   : Cursor)
1756
   is
1757
   begin
1758
      raise Program_Error with "attempt to stream set cursor";
1759
   end Write;
1760
 
1761
end Ada.Containers.Indefinite_Ordered_Sets;

powered by: WebSVN 2.1.0

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