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-coorse.adb] - Blame information for rev 316

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

powered by: WebSVN 2.1.0

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