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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT LIBRARY COMPONENTS                          --
4
--                                                                          --
5
--   A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ S E T S  --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- This unit was originally developed by Matthew J Heaney.                  --
28
------------------------------------------------------------------------------
29
 
30
with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
31
pragma Elaborate_All
32
  (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
33
 
34
with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
35
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
36
 
37
with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
38
pragma Elaborate_All
39
  (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations);
40
 
41
with Ada.Finalization; use Ada.Finalization;
42
 
43
with System; use type System.Address;
44
 
45
package body Ada.Containers.Bounded_Ordered_Sets is
46
 
47
   type Iterator is new Limited_Controlled and
48
     Set_Iterator_Interfaces.Reversible_Iterator with
49
   record
50
      Container : Set_Access;
51
      Node      : Count_Type;
52
   end record;
53
 
54
   overriding procedure Finalize (Object : in out Iterator);
55
 
56
   overriding function First (Object : Iterator) return Cursor;
57
   overriding function Last  (Object : Iterator) return Cursor;
58
 
59
   overriding function Next
60
     (Object   : Iterator;
61
      Position : Cursor) return Cursor;
62
 
63
   overriding function Previous
64
     (Object   : Iterator;
65
      Position : Cursor) return Cursor;
66
 
67
   ------------------------------
68
   -- Access to Fields of Node --
69
   ------------------------------
70
 
71
   --  These subprograms provide functional notation for access to fields
72
   --  of a node, and procedural notation for modifying these fields.
73
 
74
   function Color (Node : Node_Type) return Red_Black_Trees.Color_Type;
75
   pragma Inline (Color);
76
 
77
   function Left (Node : Node_Type) return Count_Type;
78
   pragma Inline (Left);
79
 
80
   function Parent (Node : Node_Type) return Count_Type;
81
   pragma Inline (Parent);
82
 
83
   function Right (Node : Node_Type) return Count_Type;
84
   pragma Inline (Right);
85
 
86
   procedure Set_Color
87
     (Node  : in out Node_Type;
88
      Color : Red_Black_Trees.Color_Type);
89
   pragma Inline (Set_Color);
90
 
91
   procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
92
   pragma Inline (Set_Left);
93
 
94
   procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
95
   pragma Inline (Set_Right);
96
 
97
   procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
98
   pragma Inline (Set_Parent);
99
 
100
   -----------------------
101
   -- Local Subprograms --
102
   -----------------------
103
 
104
   procedure Insert_Sans_Hint
105
     (Container : in out Set;
106
      New_Item  : Element_Type;
107
      Node      : out Count_Type;
108
      Inserted  : out Boolean);
109
 
110
   procedure Insert_With_Hint
111
     (Dst_Set  : in out Set;
112
      Dst_Hint : Count_Type;
113
      Src_Node : Node_Type;
114
      Dst_Node : out Count_Type);
115
 
116
   function Is_Greater_Element_Node
117
     (Left  : Element_Type;
118
      Right : Node_Type) return Boolean;
119
   pragma Inline (Is_Greater_Element_Node);
120
 
121
   function Is_Less_Element_Node
122
     (Left  : Element_Type;
123
      Right : Node_Type) return Boolean;
124
   pragma Inline (Is_Less_Element_Node);
125
 
126
   function Is_Less_Node_Node (L, R : Node_Type) return Boolean;
127
   pragma Inline (Is_Less_Node_Node);
128
 
129
   procedure Replace_Element
130
     (Container : in out Set;
131
      Index     : Count_Type;
132
      Item      : Element_Type);
133
 
134
   --------------------------
135
   -- Local Instantiations --
136
   --------------------------
137
 
138
   package Tree_Operations is
139
      new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types);
140
 
141
   use Tree_Operations;
142
 
143
   package Element_Keys is
144
      new Red_Black_Trees.Generic_Bounded_Keys
145
        (Tree_Operations     => Tree_Operations,
146
         Key_Type            => Element_Type,
147
         Is_Less_Key_Node    => Is_Less_Element_Node,
148
         Is_Greater_Key_Node => Is_Greater_Element_Node);
149
 
150
   package Set_Ops is
151
      new Red_Black_Trees.Generic_Bounded_Set_Operations
152
        (Tree_Operations  => Tree_Operations,
153
         Set_Type         => Set,
154
         Assign           => Assign,
155
         Insert_With_Hint => Insert_With_Hint,
156
         Is_Less          => Is_Less_Node_Node);
157
 
158
   ---------
159
   -- "<" --
160
   ---------
161
 
162
   function "<" (Left, Right : Cursor) return Boolean is
163
   begin
164
      if Left.Node = 0 then
165
         raise Constraint_Error with "Left cursor equals No_Element";
166
      end if;
167
 
168
      if Right.Node = 0 then
169
         raise Constraint_Error with "Right cursor equals No_Element";
170
      end if;
171
 
172
      pragma Assert (Vet (Left.Container.all, Left.Node),
173
                     "bad Left cursor in ""<""");
174
 
175
      pragma Assert (Vet (Right.Container.all, Right.Node),
176
                     "bad Right cursor in ""<""");
177
 
178
      declare
179
         LN : Nodes_Type renames Left.Container.Nodes;
180
         RN : Nodes_Type renames Right.Container.Nodes;
181
      begin
182
         return LN (Left.Node).Element < RN (Right.Node).Element;
183
      end;
184
   end "<";
185
 
186
   function "<" (Left : Cursor; Right : Element_Type) return Boolean is
187
   begin
188
      if Left.Node = 0 then
189
         raise Constraint_Error with "Left cursor equals No_Element";
190
      end if;
191
 
192
      pragma Assert (Vet (Left.Container.all, Left.Node),
193
                     "bad Left cursor in ""<""");
194
 
195
      return Left.Container.Nodes (Left.Node).Element < Right;
196
   end "<";
197
 
198
   function "<" (Left : Element_Type; Right : Cursor) return Boolean is
199
   begin
200
      if Right.Node = 0 then
201
         raise Constraint_Error with "Right cursor equals No_Element";
202
      end if;
203
 
204
      pragma Assert (Vet (Right.Container.all, Right.Node),
205
                     "bad Right cursor in ""<""");
206
 
207
      return Left < Right.Container.Nodes (Right.Node).Element;
208
   end "<";
209
 
210
   ---------
211
   -- "=" --
212
   ---------
213
 
214
   function "=" (Left, Right : Set) return Boolean is
215
      function Is_Equal_Node_Node (L, R : Node_Type) return Boolean;
216
      pragma Inline (Is_Equal_Node_Node);
217
 
218
      function Is_Equal is
219
         new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
220
 
221
      ------------------------
222
      -- Is_Equal_Node_Node --
223
      ------------------------
224
 
225
      function Is_Equal_Node_Node (L, R : Node_Type) return Boolean is
226
      begin
227
         return L.Element = R.Element;
228
      end Is_Equal_Node_Node;
229
 
230
   --  Start of processing for Is_Equal
231
 
232
   begin
233
      return Is_Equal (Left, Right);
234
   end "=";
235
 
236
   ---------
237
   -- ">" --
238
   ---------
239
 
240
   function ">" (Left, Right : Cursor) return Boolean is
241
   begin
242
      if Left.Node = 0 then
243
         raise Constraint_Error with "Left cursor equals No_Element";
244
      end if;
245
 
246
      if Right.Node = 0 then
247
         raise Constraint_Error with "Right cursor equals No_Element";
248
      end if;
249
 
250
      pragma Assert (Vet (Left.Container.all, Left.Node),
251
                     "bad Left cursor in "">""");
252
 
253
      pragma Assert (Vet (Right.Container.all, Right.Node),
254
                     "bad Right cursor in "">""");
255
 
256
      --  L > R same as R < L
257
 
258
      declare
259
         LN : Nodes_Type renames Left.Container.Nodes;
260
         RN : Nodes_Type renames Right.Container.Nodes;
261
      begin
262
         return RN (Right.Node).Element < LN (Left.Node).Element;
263
      end;
264
   end ">";
265
 
266
   function ">" (Left : Element_Type; Right : Cursor) return Boolean is
267
   begin
268
      if Right.Node = 0 then
269
         raise Constraint_Error with "Right cursor equals No_Element";
270
      end if;
271
 
272
      pragma Assert (Vet (Right.Container.all, Right.Node),
273
                     "bad Right cursor in "">""");
274
 
275
      return Right.Container.Nodes (Right.Node).Element < Left;
276
   end ">";
277
 
278
   function ">" (Left : Cursor; Right : Element_Type) return Boolean is
279
   begin
280
      if Left.Node = 0 then
281
         raise Constraint_Error with "Left cursor equals No_Element";
282
      end if;
283
 
284
      pragma Assert (Vet (Left.Container.all, Left.Node),
285
                     "bad Left cursor in "">""");
286
 
287
      return Right < Left.Container.Nodes (Left.Node).Element;
288
   end ">";
289
 
290
   ------------
291
   -- Assign --
292
   ------------
293
 
294
   procedure Assign (Target : in out Set; Source : Set) is
295
      procedure Append_Element (Source_Node : Count_Type);
296
 
297
      procedure Append_Elements is
298
         new Tree_Operations.Generic_Iteration (Append_Element);
299
 
300
      --------------------
301
      -- Append_Element --
302
      --------------------
303
 
304
      procedure Append_Element (Source_Node : Count_Type) is
305
         SN : Node_Type renames Source.Nodes (Source_Node);
306
 
307
         procedure Set_Element (Node : in out Node_Type);
308
         pragma Inline (Set_Element);
309
 
310
         function New_Node return Count_Type;
311
         pragma Inline (New_Node);
312
 
313
         procedure Insert_Post is
314
            new Element_Keys.Generic_Insert_Post (New_Node);
315
 
316
         procedure Unconditional_Insert_Sans_Hint is
317
            new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
318
 
319
         procedure Unconditional_Insert_Avec_Hint is
320
            new Element_Keys.Generic_Unconditional_Insert_With_Hint
321
              (Insert_Post,
322
               Unconditional_Insert_Sans_Hint);
323
 
324
         procedure Allocate is
325
            new Tree_Operations.Generic_Allocate (Set_Element);
326
 
327
         --------------
328
         -- New_Node --
329
         --------------
330
 
331
         function New_Node return Count_Type is
332
            Result : Count_Type;
333
         begin
334
            Allocate (Target, Result);
335
            return Result;
336
         end New_Node;
337
 
338
         -----------------
339
         -- Set_Element --
340
         -----------------
341
 
342
         procedure Set_Element (Node : in out Node_Type) is
343
         begin
344
            Node.Element := SN.Element;
345
         end Set_Element;
346
 
347
         Target_Node : Count_Type;
348
 
349
      --  Start of processing for Append_Element
350
 
351
      begin
352
         Unconditional_Insert_Avec_Hint
353
           (Tree  => Target,
354
            Hint  => 0,
355
            Key   => SN.Element,
356
            Node  => Target_Node);
357
      end Append_Element;
358
 
359
   --  Start of processing for Assign
360
 
361
   begin
362
      if Target'Address = Source'Address then
363
         return;
364
      end if;
365
 
366
      if Target.Capacity < Source.Length then
367
         raise Capacity_Error
368
           with "Target capacity is less than Source length";
369
      end if;
370
 
371
      Target.Clear;
372
      Append_Elements (Source);
373
   end Assign;
374
 
375
   -------------
376
   -- Ceiling --
377
   -------------
378
 
379
   function Ceiling (Container : Set; Item : Element_Type) return Cursor is
380
      Node : constant Count_Type :=
381
               Element_Keys.Ceiling (Container, Item);
382
   begin
383
      return (if Node = 0 then No_Element
384
              else Cursor'(Container'Unrestricted_Access, Node));
385
   end Ceiling;
386
 
387
   -----------
388
   -- Clear --
389
   -----------
390
 
391
   procedure Clear (Container : in out Set) is
392
   begin
393
      Tree_Operations.Clear_Tree (Container);
394
   end Clear;
395
 
396
   -----------
397
   -- Color --
398
   -----------
399
 
400
   function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is
401
   begin
402
      return Node.Color;
403
   end Color;
404
 
405
   ------------------------
406
   -- Constant_Reference --
407
   ------------------------
408
 
409
   function Constant_Reference
410
     (Container : aliased Set;
411
      Position  : Cursor) return Constant_Reference_Type
412
   is
413
   begin
414
      if Position.Container = null then
415
         raise Constraint_Error with "Position cursor has no element";
416
      end if;
417
 
418
      if Position.Container /= Container'Unrestricted_Access then
419
         raise Program_Error with
420
           "Position cursor designates wrong container";
421
      end if;
422
 
423
      pragma Assert
424
        (Vet (Container, Position.Node),
425
         "bad cursor in Constant_Reference");
426
 
427
      declare
428
         N : Node_Type renames Container.Nodes (Position.Node);
429
      begin
430
         return (Element => N.Element'Access);
431
      end;
432
   end Constant_Reference;
433
 
434
   --------------
435
   -- Contains --
436
   --------------
437
 
438
   function Contains
439
     (Container : Set;
440
      Item      : Element_Type) return Boolean
441
   is
442
   begin
443
      return Find (Container, Item) /= No_Element;
444
   end Contains;
445
 
446
   ----------
447
   -- Copy --
448
   ----------
449
 
450
   function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
451
      C : Count_Type;
452
 
453
   begin
454
      if Capacity = 0 then
455
         C := Source.Length;
456
      elsif Capacity >= Source.Length then
457
         C := Capacity;
458
      else
459
         raise Capacity_Error with "Capacity value too small";
460
      end if;
461
 
462
      return Target : Set (Capacity => C) do
463
         Assign (Target => Target, Source => Source);
464
      end return;
465
   end Copy;
466
 
467
   ------------
468
   -- Delete --
469
   ------------
470
 
471
   procedure Delete (Container : in out Set; Position : in out Cursor) is
472
   begin
473
      if Position.Node = 0 then
474
         raise Constraint_Error with "Position cursor equals No_Element";
475
      end if;
476
 
477
      if Position.Container /= Container'Unrestricted_Access then
478
         raise Program_Error with "Position cursor designates wrong set";
479
      end if;
480
 
481
      pragma Assert (Vet (Container, Position.Node),
482
                     "bad cursor in Delete");
483
 
484
      Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
485
      Tree_Operations.Free (Container, Position.Node);
486
 
487
      Position := No_Element;
488
   end Delete;
489
 
490
   procedure Delete (Container : in out Set; Item : Element_Type) is
491
      X : constant Count_Type := Element_Keys.Find (Container, Item);
492
 
493
   begin
494
      if X = 0 then
495
         raise Constraint_Error with "attempt to delete element not in set";
496
      end if;
497
 
498
      Tree_Operations.Delete_Node_Sans_Free (Container, X);
499
      Tree_Operations.Free (Container, X);
500
   end Delete;
501
 
502
   ------------------
503
   -- Delete_First --
504
   ------------------
505
 
506
   procedure Delete_First (Container : in out Set) is
507
      X : constant Count_Type := Container.First;
508
   begin
509
      if X /= 0 then
510
         Tree_Operations.Delete_Node_Sans_Free (Container, X);
511
         Tree_Operations.Free (Container, X);
512
      end if;
513
   end Delete_First;
514
 
515
   -----------------
516
   -- Delete_Last --
517
   -----------------
518
 
519
   procedure Delete_Last (Container : in out Set) is
520
      X : constant Count_Type := Container.Last;
521
   begin
522
      if X /= 0 then
523
         Tree_Operations.Delete_Node_Sans_Free (Container, X);
524
         Tree_Operations.Free (Container, X);
525
      end if;
526
   end Delete_Last;
527
 
528
   ----------------
529
   -- Difference --
530
   ----------------
531
 
532
   procedure Difference (Target : in out Set; Source : Set)
533
      renames Set_Ops.Set_Difference;
534
 
535
   function Difference (Left, Right : Set) return Set
536
      renames Set_Ops.Set_Difference;
537
 
538
   -------------
539
   -- Element --
540
   -------------
541
 
542
   function Element (Position : Cursor) return Element_Type is
543
   begin
544
      if Position.Node = 0 then
545
         raise Constraint_Error with "Position cursor equals No_Element";
546
      end if;
547
 
548
      pragma Assert (Vet (Position.Container.all, Position.Node),
549
                     "bad cursor in Element");
550
 
551
      return Position.Container.Nodes (Position.Node).Element;
552
   end Element;
553
 
554
   -------------------------
555
   -- Equivalent_Elements --
556
   -------------------------
557
 
558
   function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
559
   begin
560
      return (if Left < Right or else Right < Left then False else True);
561
   end Equivalent_Elements;
562
 
563
   ---------------------
564
   -- Equivalent_Sets --
565
   ---------------------
566
 
567
   function Equivalent_Sets (Left, Right : Set) return Boolean is
568
      function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean;
569
      pragma Inline (Is_Equivalent_Node_Node);
570
 
571
      function Is_Equivalent is
572
         new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
573
 
574
      -----------------------------
575
      -- Is_Equivalent_Node_Node --
576
      -----------------------------
577
 
578
      function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is
579
      begin
580
         return (if L.Element < R.Element then False
581
                 elsif R.Element < L.Element then False
582
                 else True);
583
      end Is_Equivalent_Node_Node;
584
 
585
   --  Start of processing for Equivalent_Sets
586
 
587
   begin
588
      return Is_Equivalent (Left, Right);
589
   end Equivalent_Sets;
590
 
591
   -------------
592
   -- Exclude --
593
   -------------
594
 
595
   procedure Exclude (Container : in out Set; Item : Element_Type) is
596
      X : constant Count_Type := Element_Keys.Find (Container, Item);
597
   begin
598
      if X /= 0 then
599
         Tree_Operations.Delete_Node_Sans_Free (Container, X);
600
         Tree_Operations.Free (Container, X);
601
      end if;
602
   end Exclude;
603
 
604
   --------------
605
   -- Finalize --
606
   --------------
607
 
608
   procedure Finalize (Object : in out Iterator) is
609
   begin
610
      if Object.Container /= null then
611
         declare
612
            B : Natural renames Object.Container.all.Busy;
613
         begin
614
            B := B - 1;
615
         end;
616
      end if;
617
   end Finalize;
618
 
619
   ----------
620
   -- Find --
621
   ----------
622
 
623
   function Find (Container : Set; Item : Element_Type) return Cursor is
624
      Node : constant Count_Type := Element_Keys.Find (Container, Item);
625
   begin
626
      return (if Node = 0 then No_Element
627
              else Cursor'(Container'Unrestricted_Access, Node));
628
   end Find;
629
 
630
   -----------
631
   -- First --
632
   -----------
633
 
634
   function First (Container : Set) return Cursor is
635
   begin
636
      return (if Container.First = 0 then No_Element
637
              else Cursor'(Container'Unrestricted_Access, Container.First));
638
   end First;
639
 
640
   function First (Object : Iterator) return Cursor is
641
   begin
642
      --  The value of the iterator object's Node component influences the
643
      --  behavior of the First (and Last) selector function.
644
 
645
      --  When the Node component is 0, this means the iterator object was
646
      --  constructed without a start expression, in which case the (forward)
647
      --  iteration starts from the (logical) beginning of the entire sequence
648
      --  of items (corresponding to Container.First, for a forward iterator).
649
 
650
      --  Otherwise, this is iteration over a partial sequence of items. When
651
      --  the Node component is positive, the iterator object was constructed
652
      --  with a start expression, that specifies the position from which the
653
      --  (forward) partial iteration begins.
654
 
655
      if Object.Node = 0 then
656
         return Bounded_Ordered_Sets.First (Object.Container.all);
657
      else
658
         return Cursor'(Object.Container, Object.Node);
659
      end if;
660
   end First;
661
 
662
   -------------------
663
   -- First_Element --
664
   -------------------
665
 
666
   function First_Element (Container : Set) return Element_Type is
667
   begin
668
      if Container.First = 0 then
669
         raise Constraint_Error with "set is empty";
670
      end if;
671
 
672
      return Container.Nodes (Container.First).Element;
673
   end First_Element;
674
 
675
   -----------
676
   -- Floor --
677
   -----------
678
 
679
   function Floor (Container : Set; Item : Element_Type) return Cursor is
680
      Node : constant Count_Type := Element_Keys.Floor (Container, Item);
681
   begin
682
      return (if Node = 0 then No_Element
683
              else Cursor'(Container'Unrestricted_Access, Node));
684
   end Floor;
685
 
686
   ------------------
687
   -- Generic_Keys --
688
   ------------------
689
 
690
   package body Generic_Keys is
691
 
692
      -----------------------
693
      -- Local Subprograms --
694
      -----------------------
695
 
696
      function Is_Greater_Key_Node
697
        (Left  : Key_Type;
698
         Right : Node_Type) return Boolean;
699
      pragma Inline (Is_Greater_Key_Node);
700
 
701
      function Is_Less_Key_Node
702
        (Left  : Key_Type;
703
         Right : Node_Type) return Boolean;
704
      pragma Inline (Is_Less_Key_Node);
705
 
706
      --------------------------
707
      -- Local Instantiations --
708
      --------------------------
709
 
710
      package Key_Keys is
711
        new Red_Black_Trees.Generic_Bounded_Keys
712
          (Tree_Operations     => Tree_Operations,
713
           Key_Type            => Key_Type,
714
           Is_Less_Key_Node    => Is_Less_Key_Node,
715
           Is_Greater_Key_Node => Is_Greater_Key_Node);
716
 
717
      -------------
718
      -- Ceiling --
719
      -------------
720
 
721
      function Ceiling (Container : Set; Key : Key_Type) return Cursor is
722
         Node : constant Count_Type :=
723
                  Key_Keys.Ceiling (Container, Key);
724
      begin
725
         return (if Node = 0 then No_Element
726
                 else Cursor'(Container'Unrestricted_Access, Node));
727
      end Ceiling;
728
 
729
      ------------------------
730
      -- Constant_Reference --
731
      ------------------------
732
 
733
      function Constant_Reference
734
        (Container : aliased Set;
735
         Key       : Key_Type) return Constant_Reference_Type
736
      is
737
         Node : constant Count_Type := Key_Keys.Find (Container, Key);
738
 
739
      begin
740
         if Node = 0 then
741
            raise Constraint_Error with "key not in set";
742
         end if;
743
 
744
         declare
745
            N : Node_Type renames Container.Nodes (Node);
746
         begin
747
            return (Element => N.Element'Access);
748
         end;
749
      end Constant_Reference;
750
 
751
      --------------
752
      -- Contains --
753
      --------------
754
 
755
      function Contains (Container : Set; Key : Key_Type) return Boolean is
756
      begin
757
         return Find (Container, Key) /= No_Element;
758
      end Contains;
759
 
760
      ------------
761
      -- Delete --
762
      ------------
763
 
764
      procedure Delete (Container : in out Set; Key : Key_Type) is
765
         X : constant Count_Type := Key_Keys.Find (Container, Key);
766
 
767
      begin
768
         if X = 0 then
769
            raise Constraint_Error with "attempt to delete key not in set";
770
         end if;
771
 
772
         Tree_Operations.Delete_Node_Sans_Free (Container, X);
773
         Tree_Operations.Free (Container, X);
774
      end Delete;
775
 
776
      -------------
777
      -- Element --
778
      -------------
779
 
780
      function Element (Container : Set; Key : Key_Type) return Element_Type is
781
         Node : constant Count_Type := Key_Keys.Find (Container, Key);
782
 
783
      begin
784
         if Node = 0 then
785
            raise Constraint_Error with "key not in set";
786
         end if;
787
 
788
         return Container.Nodes (Node).Element;
789
      end Element;
790
 
791
      ---------------------
792
      -- Equivalent_Keys --
793
      ---------------------
794
 
795
      function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
796
      begin
797
         return (if Left < Right or else Right < Left then False else True);
798
      end Equivalent_Keys;
799
 
800
      -------------
801
      -- Exclude --
802
      -------------
803
 
804
      procedure Exclude (Container : in out Set; Key : Key_Type) is
805
         X : constant Count_Type := Key_Keys.Find (Container, Key);
806
      begin
807
         if X /= 0 then
808
            Tree_Operations.Delete_Node_Sans_Free (Container, X);
809
            Tree_Operations.Free (Container, X);
810
         end if;
811
      end Exclude;
812
 
813
      ----------
814
      -- Find --
815
      ----------
816
 
817
      function Find (Container : Set; Key : Key_Type) return Cursor is
818
         Node : constant Count_Type := Key_Keys.Find (Container, Key);
819
      begin
820
         return (if Node = 0 then No_Element
821
                 else Cursor'(Container'Unrestricted_Access, Node));
822
      end Find;
823
 
824
      -----------
825
      -- Floor --
826
      -----------
827
 
828
      function Floor (Container : Set; Key : Key_Type) return Cursor is
829
         Node : constant Count_Type := Key_Keys.Floor (Container, Key);
830
      begin
831
         return (if Node = 0 then No_Element
832
                 else Cursor'(Container'Unrestricted_Access, Node));
833
      end Floor;
834
 
835
      -------------------------
836
      -- Is_Greater_Key_Node --
837
      -------------------------
838
 
839
      function Is_Greater_Key_Node
840
        (Left  : Key_Type;
841
         Right : Node_Type) return Boolean
842
      is
843
      begin
844
         return Key (Right.Element) < Left;
845
      end Is_Greater_Key_Node;
846
 
847
      ----------------------
848
      -- Is_Less_Key_Node --
849
      ----------------------
850
 
851
      function Is_Less_Key_Node
852
        (Left  : Key_Type;
853
         Right : Node_Type) return Boolean
854
      is
855
      begin
856
         return Left < Key (Right.Element);
857
      end Is_Less_Key_Node;
858
 
859
      ---------
860
      -- Key --
861
      ---------
862
 
863
      function Key (Position : Cursor) return Key_Type is
864
      begin
865
         if Position.Node = 0 then
866
            raise Constraint_Error with
867
              "Position cursor equals No_Element";
868
         end if;
869
 
870
         pragma Assert (Vet (Position.Container.all, Position.Node),
871
                        "bad cursor in Key");
872
 
873
         return Key (Position.Container.Nodes (Position.Node).Element);
874
      end Key;
875
 
876
      ----------
877
      -- Read --
878
      ----------
879
 
880
      procedure  Read
881
        (Stream : not null access Root_Stream_Type'Class;
882
         Item   : out Reference_Type)
883
      is
884
      begin
885
         raise Program_Error with "attempt to stream reference";
886
      end Read;
887
 
888
      ------------------------------
889
      -- Reference_Preserving_Key --
890
      ------------------------------
891
 
892
      function Reference_Preserving_Key
893
        (Container : aliased in out Set;
894
         Position  : Cursor) return Reference_Type
895
      is
896
      begin
897
         if Position.Container = null then
898
            raise Constraint_Error with "Position cursor has no element";
899
         end if;
900
 
901
         if Position.Container /= Container'Unrestricted_Access then
902
            raise Program_Error with
903
              "Position cursor designates wrong container";
904
         end if;
905
 
906
         pragma Assert
907
           (Vet (Container, Position.Node),
908
            "bad cursor in function Reference_Preserving_Key");
909
 
910
         --  Some form of finalization will be required in order to actually
911
         --  check that the key-part of the element designated by Position has
912
         --  not changed.  ???
913
 
914
         declare
915
            N : Node_Type renames Container.Nodes (Position.Node);
916
         begin
917
            return (Element => N.Element'Access);
918
         end;
919
      end Reference_Preserving_Key;
920
 
921
      function Reference_Preserving_Key
922
        (Container : aliased in out Set;
923
         Key       : Key_Type) return Reference_Type
924
      is
925
         Node : constant Count_Type := Key_Keys.Find (Container, Key);
926
 
927
      begin
928
         if Node = 0 then
929
            raise Constraint_Error with "key not in set";
930
         end if;
931
 
932
         declare
933
            N : Node_Type renames Container.Nodes (Node);
934
         begin
935
            return (Element => N.Element'Access);
936
         end;
937
      end Reference_Preserving_Key;
938
 
939
      -------------
940
      -- Replace --
941
      -------------
942
 
943
      procedure Replace
944
        (Container : in out Set;
945
         Key       : Key_Type;
946
         New_Item  : Element_Type)
947
      is
948
         Node : constant Count_Type := Key_Keys.Find (Container, Key);
949
 
950
      begin
951
         if Node = 0 then
952
            raise Constraint_Error with
953
              "attempt to replace key not in set";
954
         end if;
955
 
956
         Replace_Element (Container, Node, New_Item);
957
      end Replace;
958
 
959
      -----------------------------------
960
      -- Update_Element_Preserving_Key --
961
      -----------------------------------
962
 
963
      procedure Update_Element_Preserving_Key
964
        (Container : in out Set;
965
         Position  : Cursor;
966
         Process   : not null access procedure (Element : in out Element_Type))
967
      is
968
      begin
969
         if Position.Node = 0 then
970
            raise Constraint_Error with
971
              "Position cursor equals No_Element";
972
         end if;
973
 
974
         if Position.Container /= Container'Unrestricted_Access then
975
            raise Program_Error with
976
              "Position cursor designates wrong set";
977
         end if;
978
 
979
         pragma Assert (Vet (Container, Position.Node),
980
                        "bad cursor in Update_Element_Preserving_Key");
981
 
982
         declare
983
            N : Node_Type renames Container.Nodes (Position.Node);
984
            E : Element_Type renames N.Element;
985
            K : constant Key_Type := Key (E);
986
 
987
            B : Natural renames Container.Busy;
988
            L : Natural renames Container.Lock;
989
 
990
         begin
991
            B := B + 1;
992
            L := L + 1;
993
 
994
            begin
995
               Process (E);
996
            exception
997
               when others =>
998
                  L := L - 1;
999
                  B := B - 1;
1000
                  raise;
1001
            end;
1002
 
1003
            L := L - 1;
1004
            B := B - 1;
1005
 
1006
            if Equivalent_Keys (K, Key (E)) then
1007
               return;
1008
            end if;
1009
         end;
1010
 
1011
         Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
1012
         Tree_Operations.Free (Container, Position.Node);
1013
 
1014
         raise Program_Error with "key was modified";
1015
      end Update_Element_Preserving_Key;
1016
 
1017
      -----------
1018
      -- Write --
1019
      -----------
1020
 
1021
      procedure Write
1022
        (Stream : not null access Root_Stream_Type'Class;
1023
         Item   : Reference_Type)
1024
      is
1025
      begin
1026
         raise Program_Error with "attempt to stream reference";
1027
      end Write;
1028
   end Generic_Keys;
1029
 
1030
   -----------------
1031
   -- Has_Element --
1032
   -----------------
1033
 
1034
   function Has_Element (Position : Cursor) return Boolean is
1035
   begin
1036
      return Position /= No_Element;
1037
   end Has_Element;
1038
 
1039
   -------------
1040
   -- Include --
1041
   -------------
1042
 
1043
   procedure Include (Container : in out Set; New_Item : Element_Type) is
1044
      Position : Cursor;
1045
      Inserted : Boolean;
1046
 
1047
   begin
1048
      Insert (Container, New_Item, Position, Inserted);
1049
 
1050
      if not Inserted then
1051
         if Container.Lock > 0 then
1052
            raise Program_Error with
1053
              "attempt to tamper with elements (set is locked)";
1054
         end if;
1055
 
1056
         Container.Nodes (Position.Node).Element := New_Item;
1057
      end if;
1058
   end Include;
1059
 
1060
   ------------
1061
   -- Insert --
1062
   ------------
1063
 
1064
   procedure Insert
1065
     (Container : in out Set;
1066
      New_Item  : Element_Type;
1067
      Position  : out Cursor;
1068
      Inserted  : out Boolean)
1069
   is
1070
   begin
1071
      Insert_Sans_Hint
1072
        (Container,
1073
         New_Item,
1074
         Position.Node,
1075
         Inserted);
1076
 
1077
      Position.Container := Container'Unrestricted_Access;
1078
   end Insert;
1079
 
1080
   procedure Insert
1081
     (Container : in out Set;
1082
      New_Item  : Element_Type)
1083
   is
1084
      Position : Cursor;
1085
      pragma Unreferenced (Position);
1086
 
1087
      Inserted : Boolean;
1088
 
1089
   begin
1090
      Insert (Container, New_Item, Position, Inserted);
1091
 
1092
      if not Inserted then
1093
         raise Constraint_Error with
1094
           "attempt to insert element already in set";
1095
      end if;
1096
   end Insert;
1097
 
1098
   ----------------------
1099
   -- Insert_Sans_Hint --
1100
   ----------------------
1101
 
1102
   procedure Insert_Sans_Hint
1103
     (Container : in out Set;
1104
      New_Item  : Element_Type;
1105
      Node      : out Count_Type;
1106
      Inserted  : out Boolean)
1107
   is
1108
      procedure Set_Element (Node : in out Node_Type);
1109
      pragma Inline (Set_Element);
1110
 
1111
      function New_Node return Count_Type;
1112
      pragma Inline (New_Node);
1113
 
1114
      procedure Insert_Post is
1115
        new Element_Keys.Generic_Insert_Post (New_Node);
1116
 
1117
      procedure Conditional_Insert_Sans_Hint is
1118
        new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1119
 
1120
      procedure Allocate is
1121
         new Tree_Operations.Generic_Allocate (Set_Element);
1122
 
1123
      --------------
1124
      -- New_Node --
1125
      --------------
1126
 
1127
      function New_Node return Count_Type is
1128
         Result : Count_Type;
1129
      begin
1130
         Allocate (Container, Result);
1131
         return Result;
1132
      end New_Node;
1133
 
1134
      -----------------
1135
      -- Set_Element --
1136
      -----------------
1137
 
1138
      procedure Set_Element (Node : in out Node_Type) is
1139
      begin
1140
         Node.Element := New_Item;
1141
      end Set_Element;
1142
 
1143
   --  Start of processing for Insert_Sans_Hint
1144
 
1145
   begin
1146
      Conditional_Insert_Sans_Hint
1147
        (Container,
1148
         New_Item,
1149
         Node,
1150
         Inserted);
1151
   end Insert_Sans_Hint;
1152
 
1153
   ----------------------
1154
   -- Insert_With_Hint --
1155
   ----------------------
1156
 
1157
   procedure Insert_With_Hint
1158
     (Dst_Set  : in out Set;
1159
      Dst_Hint : Count_Type;
1160
      Src_Node : Node_Type;
1161
      Dst_Node : out Count_Type)
1162
   is
1163
      Success : Boolean;
1164
      pragma Unreferenced (Success);
1165
 
1166
      procedure Set_Element (Node : in out Node_Type);
1167
      pragma Inline (Set_Element);
1168
 
1169
      function New_Node return Count_Type;
1170
      pragma Inline (New_Node);
1171
 
1172
      procedure Insert_Post is
1173
         new Element_Keys.Generic_Insert_Post (New_Node);
1174
 
1175
      procedure Insert_Sans_Hint is
1176
         new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1177
 
1178
      procedure Local_Insert_With_Hint is
1179
         new Element_Keys.Generic_Conditional_Insert_With_Hint
1180
           (Insert_Post,
1181
            Insert_Sans_Hint);
1182
 
1183
      procedure Allocate is
1184
         new Tree_Operations.Generic_Allocate (Set_Element);
1185
 
1186
      --------------
1187
      -- New_Node --
1188
      --------------
1189
 
1190
      function New_Node return Count_Type is
1191
         Result : Count_Type;
1192
      begin
1193
         Allocate (Dst_Set, Result);
1194
         return Result;
1195
      end New_Node;
1196
 
1197
      -----------------
1198
      -- Set_Element --
1199
      -----------------
1200
 
1201
      procedure Set_Element (Node : in out Node_Type) is
1202
      begin
1203
         Node.Element := Src_Node.Element;
1204
      end Set_Element;
1205
 
1206
   --  Start of processing for Insert_With_Hint
1207
 
1208
   begin
1209
      Local_Insert_With_Hint
1210
        (Dst_Set,
1211
         Dst_Hint,
1212
         Src_Node.Element,
1213
         Dst_Node,
1214
         Success);
1215
   end Insert_With_Hint;
1216
 
1217
   ------------------
1218
   -- Intersection --
1219
   ------------------
1220
 
1221
   procedure Intersection (Target : in out Set; Source : Set)
1222
      renames Set_Ops.Set_Intersection;
1223
 
1224
   function Intersection (Left, Right : Set) return Set
1225
      renames Set_Ops.Set_Intersection;
1226
 
1227
   --------------
1228
   -- Is_Empty --
1229
   --------------
1230
 
1231
   function Is_Empty (Container : Set) return Boolean is
1232
   begin
1233
      return Container.Length = 0;
1234
   end Is_Empty;
1235
 
1236
   -----------------------------
1237
   -- Is_Greater_Element_Node --
1238
   -----------------------------
1239
 
1240
   function Is_Greater_Element_Node
1241
     (Left  : Element_Type;
1242
      Right : Node_Type) return Boolean
1243
   is
1244
   begin
1245
      --  Compute e > node same as node < e
1246
 
1247
      return Right.Element < Left;
1248
   end Is_Greater_Element_Node;
1249
 
1250
   --------------------------
1251
   -- Is_Less_Element_Node --
1252
   --------------------------
1253
 
1254
   function Is_Less_Element_Node
1255
     (Left  : Element_Type;
1256
      Right : Node_Type) return Boolean
1257
   is
1258
   begin
1259
      return Left < Right.Element;
1260
   end Is_Less_Element_Node;
1261
 
1262
   -----------------------
1263
   -- Is_Less_Node_Node --
1264
   -----------------------
1265
 
1266
   function Is_Less_Node_Node (L, R : Node_Type) return Boolean is
1267
   begin
1268
      return L.Element < R.Element;
1269
   end Is_Less_Node_Node;
1270
 
1271
   ---------------
1272
   -- Is_Subset --
1273
   ---------------
1274
 
1275
   function Is_Subset (Subset : Set; Of_Set : Set) return Boolean
1276
      renames Set_Ops.Set_Subset;
1277
 
1278
   -------------
1279
   -- Iterate --
1280
   -------------
1281
 
1282
   procedure Iterate
1283
     (Container : Set;
1284
      Process   : not null access procedure (Position : Cursor))
1285
   is
1286
      procedure Process_Node (Node : Count_Type);
1287
      pragma Inline (Process_Node);
1288
 
1289
      procedure Local_Iterate is
1290
        new Tree_Operations.Generic_Iteration (Process_Node);
1291
 
1292
      ------------------
1293
      -- Process_Node --
1294
      ------------------
1295
 
1296
      procedure Process_Node (Node : Count_Type) is
1297
      begin
1298
         Process (Cursor'(Container'Unrestricted_Access, Node));
1299
      end Process_Node;
1300
 
1301
      S : Set renames Container'Unrestricted_Access.all;
1302
      B : Natural renames S.Busy;
1303
 
1304
   --  Start of processing for Iterate
1305
 
1306
   begin
1307
      B := B + 1;
1308
 
1309
      begin
1310
         Local_Iterate (S);
1311
      exception
1312
         when others =>
1313
            B := B - 1;
1314
            raise;
1315
      end;
1316
 
1317
      B := B - 1;
1318
   end Iterate;
1319
 
1320
   function Iterate (Container : Set)
1321
     return Set_Iterator_Interfaces.Reversible_Iterator'class
1322
   is
1323
      B : Natural renames Container'Unrestricted_Access.all.Busy;
1324
 
1325
   begin
1326
      --  The value of the Node component influences the behavior of the First
1327
      --  and Last selector functions of the iterator object. When the Node
1328
      --  component is 0 (as is the case here), this means the iterator object
1329
      --  was constructed without a start expression. This is a complete
1330
      --  iterator, meaning that the iteration starts from the (logical)
1331
      --  beginning of the sequence of items.
1332
 
1333
      --  Note: For a forward iterator, Container.First is the beginning, and
1334
      --  for a reverse iterator, Container.Last is the beginning.
1335
 
1336
      return It : constant Iterator :=
1337
                    Iterator'(Limited_Controlled with
1338
                                Container => Container'Unrestricted_Access,
1339
                                Node      => 0)
1340
      do
1341
         B := B + 1;
1342
      end return;
1343
   end Iterate;
1344
 
1345
   function Iterate (Container : Set; Start : Cursor)
1346
     return Set_Iterator_Interfaces.Reversible_Iterator'class
1347
   is
1348
      B  : Natural renames Container'Unrestricted_Access.all.Busy;
1349
 
1350
   begin
1351
      --  It was formerly the case that when Start = No_Element, the partial
1352
      --  iterator was defined to behave the same as for a complete iterator,
1353
      --  and iterate over the entire sequence of items. However, those
1354
      --  semantics were unintuitive and arguably error-prone (it is too easy
1355
      --  to accidentally create an endless loop), and so they were changed,
1356
      --  per the ARG meeting in Denver on 2011/11. However, there was no
1357
      --  consensus about what positive meaning this corner case should have,
1358
      --  and so it was decided to simply raise an exception. This does imply,
1359
      --  however, that it is not possible to use a partial iterator to specify
1360
      --  an empty sequence of items.
1361
 
1362
      if Start = No_Element then
1363
         raise Constraint_Error with
1364
           "Start position for iterator equals No_Element";
1365
      end if;
1366
 
1367
      if Start.Container /= Container'Unrestricted_Access then
1368
         raise Program_Error with
1369
           "Start cursor of Iterate designates wrong set";
1370
      end if;
1371
 
1372
      pragma Assert (Vet (Container, Start.Node),
1373
                     "Start cursor of Iterate is bad");
1374
 
1375
      --  The value of the Node component influences the behavior of the First
1376
      --  and Last selector functions of the iterator object. When the Node
1377
      --  component is positive (as is the case here), it means that this
1378
      --  is a partial iteration, over a subset of the complete sequence of
1379
      --  items. The iterator object was constructed with a start expression,
1380
      --  indicating the position from which the iteration begins. (Note that
1381
      --  the start position has the same value irrespective of whether this
1382
      --  is a forward or reverse iteration.)
1383
 
1384
      return It : constant Iterator :=
1385
                    Iterator'(Limited_Controlled with
1386
                                Container => Container'Unrestricted_Access,
1387
                                Node      => Start.Node)
1388
      do
1389
         B := B + 1;
1390
      end return;
1391
   end Iterate;
1392
 
1393
   ----------
1394
   -- Last --
1395
   ----------
1396
 
1397
   function Last (Container : Set) return Cursor is
1398
   begin
1399
      return (if Container.Last = 0 then No_Element
1400
              else Cursor'(Container'Unrestricted_Access, Container.Last));
1401
   end Last;
1402
 
1403
   function Last (Object : Iterator) return Cursor is
1404
   begin
1405
      --  The value of the iterator object's Node component influences the
1406
      --  behavior of the Last (and First) selector function.
1407
 
1408
      --  When the Node component is 0, this means the iterator object was
1409
      --  constructed without a start expression, in which case the (reverse)
1410
      --  iteration starts from the (logical) beginning of the entire sequence
1411
      --  (corresponding to Container.Last, for a reverse iterator).
1412
 
1413
      --  Otherwise, this is iteration over a partial sequence of items. When
1414
      --  the Node component is positive, the iterator object was constructed
1415
      --  with a start expression, that specifies the position from which the
1416
      --  (reverse) partial iteration begins.
1417
 
1418
      if Object.Node = 0 then
1419
         return Bounded_Ordered_Sets.Last (Object.Container.all);
1420
      else
1421
         return Cursor'(Object.Container, Object.Node);
1422
      end if;
1423
   end Last;
1424
 
1425
   ------------------
1426
   -- Last_Element --
1427
   ------------------
1428
 
1429
   function Last_Element (Container : Set) return Element_Type is
1430
   begin
1431
      if Container.Last = 0 then
1432
         raise Constraint_Error with "set is empty";
1433
      end if;
1434
 
1435
      return Container.Nodes (Container.Last).Element;
1436
   end Last_Element;
1437
 
1438
   ----------
1439
   -- Left --
1440
   ----------
1441
 
1442
   function Left (Node : Node_Type) return Count_Type is
1443
   begin
1444
      return Node.Left;
1445
   end Left;
1446
 
1447
   ------------
1448
   -- Length --
1449
   ------------
1450
 
1451
   function Length (Container : Set) return Count_Type is
1452
   begin
1453
      return Container.Length;
1454
   end Length;
1455
 
1456
   ----------
1457
   -- Move --
1458
   ----------
1459
 
1460
   procedure Move (Target : in out Set; Source : in out Set) is
1461
   begin
1462
      if Target'Address = Source'Address then
1463
         return;
1464
      end if;
1465
 
1466
      if Source.Busy > 0 then
1467
         raise Program_Error with
1468
           "attempt to tamper with cursors (container is busy)";
1469
      end if;
1470
 
1471
      Target.Assign (Source);
1472
      Source.Clear;
1473
   end Move;
1474
 
1475
   ----------
1476
   -- Next --
1477
   ----------
1478
 
1479
   function Next (Position : Cursor) return Cursor is
1480
   begin
1481
      if Position = No_Element then
1482
         return No_Element;
1483
      end if;
1484
 
1485
      pragma Assert (Vet (Position.Container.all, Position.Node),
1486
                     "bad cursor in Next");
1487
 
1488
      declare
1489
         Node : constant Count_Type :=
1490
                  Tree_Operations.Next (Position.Container.all, Position.Node);
1491
 
1492
      begin
1493
         if Node = 0 then
1494
            return No_Element;
1495
         end if;
1496
 
1497
         return Cursor'(Position.Container, Node);
1498
      end;
1499
   end Next;
1500
 
1501
   procedure Next (Position : in out Cursor) is
1502
   begin
1503
      Position := Next (Position);
1504
   end Next;
1505
 
1506
   function Next (Object : Iterator; Position : Cursor) return Cursor is
1507
   begin
1508
      if Position.Container = null then
1509
         return No_Element;
1510
      end if;
1511
 
1512
      if Position.Container /= Object.Container then
1513
         raise Program_Error with
1514
           "Position cursor of Next designates wrong set";
1515
      end if;
1516
 
1517
      return Next (Position);
1518
   end Next;
1519
 
1520
   -------------
1521
   -- Overlap --
1522
   -------------
1523
 
1524
   function Overlap (Left, Right : Set) return Boolean
1525
      renames Set_Ops.Set_Overlap;
1526
 
1527
   ------------
1528
   -- Parent --
1529
   ------------
1530
 
1531
   function Parent (Node : Node_Type) return Count_Type is
1532
   begin
1533
      return Node.Parent;
1534
   end Parent;
1535
 
1536
   --------------
1537
   -- Previous --
1538
   --------------
1539
 
1540
   function Previous (Position : Cursor) return Cursor is
1541
   begin
1542
      if Position = No_Element then
1543
         return No_Element;
1544
      end if;
1545
 
1546
      pragma Assert (Vet (Position.Container.all, Position.Node),
1547
                     "bad cursor in Previous");
1548
 
1549
      declare
1550
         Node : constant Count_Type :=
1551
                  Tree_Operations.Previous
1552
                    (Position.Container.all,
1553
                     Position.Node);
1554
      begin
1555
         return (if Node = 0 then No_Element
1556
                 else Cursor'(Position.Container, Node));
1557
      end;
1558
   end Previous;
1559
 
1560
   procedure Previous (Position : in out Cursor) is
1561
   begin
1562
      Position := Previous (Position);
1563
   end Previous;
1564
 
1565
   function Previous (Object : Iterator; Position : Cursor) return Cursor is
1566
   begin
1567
      if Position.Container = null then
1568
         return No_Element;
1569
      end if;
1570
 
1571
      if Position.Container /= Object.Container then
1572
         raise Program_Error with
1573
           "Position cursor of Previous designates wrong set";
1574
      end if;
1575
 
1576
      return Previous (Position);
1577
   end Previous;
1578
 
1579
   -------------------
1580
   -- Query_Element --
1581
   -------------------
1582
 
1583
   procedure Query_Element
1584
     (Position : Cursor;
1585
      Process  : not null access procedure (Element : Element_Type))
1586
   is
1587
   begin
1588
      if Position.Node = 0 then
1589
         raise Constraint_Error with "Position cursor equals No_Element";
1590
      end if;
1591
 
1592
      pragma Assert (Vet (Position.Container.all, Position.Node),
1593
                     "bad cursor in Query_Element");
1594
 
1595
      declare
1596
         S : Set renames Position.Container.all;
1597
         B : Natural renames S.Busy;
1598
         L : Natural renames S.Lock;
1599
 
1600
      begin
1601
         B := B + 1;
1602
         L := L + 1;
1603
 
1604
         begin
1605
            Process (S.Nodes (Position.Node).Element);
1606
         exception
1607
            when others =>
1608
               L := L - 1;
1609
               B := B - 1;
1610
               raise;
1611
         end;
1612
 
1613
         L := L - 1;
1614
         B := B - 1;
1615
      end;
1616
   end Query_Element;
1617
 
1618
   ----------
1619
   -- Read --
1620
   ----------
1621
 
1622
   procedure Read
1623
     (Stream    : not null access Root_Stream_Type'Class;
1624
      Container : out Set)
1625
   is
1626
      procedure Read_Element (Node : in out Node_Type);
1627
      pragma Inline (Read_Element);
1628
 
1629
      procedure Allocate is
1630
         new Tree_Operations.Generic_Allocate (Read_Element);
1631
 
1632
      procedure Read_Elements is
1633
         new Tree_Operations.Generic_Read (Allocate);
1634
 
1635
      ------------------
1636
      -- Read_Element --
1637
      ------------------
1638
 
1639
      procedure Read_Element (Node : in out Node_Type) is
1640
      begin
1641
         Element_Type'Read (Stream, Node.Element);
1642
      end Read_Element;
1643
 
1644
   --  Start of processing for Read
1645
 
1646
   begin
1647
      Read_Elements (Stream, Container);
1648
   end Read;
1649
 
1650
   procedure Read
1651
     (Stream : not null access Root_Stream_Type'Class;
1652
      Item   : out Cursor)
1653
   is
1654
   begin
1655
      raise Program_Error with "attempt to stream set cursor";
1656
   end Read;
1657
 
1658
   procedure Read
1659
     (Stream : not null access Root_Stream_Type'Class;
1660
      Item   : out Constant_Reference_Type)
1661
   is
1662
   begin
1663
      raise Program_Error with "attempt to stream reference";
1664
   end Read;
1665
 
1666
   -------------
1667
   -- Replace --
1668
   -------------
1669
 
1670
   procedure Replace (Container : in out Set; New_Item : Element_Type) is
1671
      Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
1672
 
1673
   begin
1674
      if Node = 0 then
1675
         raise Constraint_Error with
1676
           "attempt to replace element not in set";
1677
      end if;
1678
 
1679
      if Container.Lock > 0 then
1680
         raise Program_Error with
1681
           "attempt to tamper with elements (set is locked)";
1682
      end if;
1683
 
1684
      Container.Nodes (Node).Element := New_Item;
1685
   end Replace;
1686
 
1687
   ---------------------
1688
   -- Replace_Element --
1689
   ---------------------
1690
 
1691
   procedure Replace_Element
1692
     (Container : in out Set;
1693
      Index     : Count_Type;
1694
      Item      : Element_Type)
1695
   is
1696
      pragma Assert (Index /= 0);
1697
 
1698
      function New_Node return Count_Type;
1699
      pragma Inline (New_Node);
1700
 
1701
      procedure Local_Insert_Post is
1702
         new Element_Keys.Generic_Insert_Post (New_Node);
1703
 
1704
      procedure Local_Insert_Sans_Hint is
1705
         new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
1706
 
1707
      procedure Local_Insert_With_Hint is
1708
         new Element_Keys.Generic_Conditional_Insert_With_Hint
1709
           (Local_Insert_Post,
1710
            Local_Insert_Sans_Hint);
1711
 
1712
      Nodes : Nodes_Type renames Container.Nodes;
1713
      Node  : Node_Type renames Nodes (Index);
1714
 
1715
      --------------
1716
      -- New_Node --
1717
      --------------
1718
 
1719
      function New_Node return Count_Type is
1720
      begin
1721
         Node.Element := Item;
1722
         Node.Color   := Red_Black_Trees.Red;
1723
         Node.Parent  := 0;
1724
         Node.Right   := 0;
1725
         Node.Left    := 0;
1726
         return Index;
1727
      end New_Node;
1728
 
1729
      Hint      : Count_Type;
1730
      Result    : Count_Type;
1731
      Inserted  : Boolean;
1732
 
1733
   --  Start of processing for Replace_Element
1734
 
1735
   begin
1736
      if Item < Node.Element
1737
        or else Node.Element < Item
1738
      then
1739
         null;
1740
 
1741
      else
1742
         if Container.Lock > 0 then
1743
            raise Program_Error with
1744
              "attempt to tamper with elements (set is locked)";
1745
         end if;
1746
 
1747
         Node.Element := Item;
1748
         return;
1749
      end if;
1750
 
1751
      Hint := Element_Keys.Ceiling (Container, Item);
1752
 
1753
      if Hint = 0 then
1754
         null;
1755
 
1756
      elsif Item < Nodes (Hint).Element then
1757
         if Hint = Index then
1758
            if Container.Lock > 0 then
1759
               raise Program_Error with
1760
                 "attempt to tamper with elements (set is locked)";
1761
            end if;
1762
 
1763
            Node.Element := Item;
1764
            return;
1765
         end if;
1766
 
1767
      else
1768
         pragma Assert (not (Nodes (Hint).Element < Item));
1769
         raise Program_Error with "attempt to replace existing element";
1770
      end if;
1771
 
1772
      Tree_Operations.Delete_Node_Sans_Free (Container, Index);
1773
 
1774
      Local_Insert_With_Hint
1775
        (Tree     => Container,
1776
         Position => Hint,
1777
         Key      => Item,
1778
         Node     => Result,
1779
         Inserted => Inserted);
1780
 
1781
      pragma Assert (Inserted);
1782
      pragma Assert (Result = Index);
1783
   end Replace_Element;
1784
 
1785
   procedure Replace_Element
1786
     (Container : in out Set;
1787
      Position  : Cursor;
1788
      New_Item  : Element_Type)
1789
   is
1790
   begin
1791
      if Position.Node = 0 then
1792
         raise Constraint_Error with
1793
           "Position cursor equals No_Element";
1794
      end if;
1795
 
1796
      if Position.Container /= Container'Unrestricted_Access then
1797
         raise Program_Error with
1798
           "Position cursor designates wrong set";
1799
      end if;
1800
 
1801
      pragma Assert (Vet (Container, Position.Node),
1802
                     "bad cursor in Replace_Element");
1803
 
1804
      Replace_Element (Container, Position.Node, New_Item);
1805
   end Replace_Element;
1806
 
1807
   ---------------------
1808
   -- Reverse_Iterate --
1809
   ---------------------
1810
 
1811
   procedure Reverse_Iterate
1812
     (Container : Set;
1813
      Process   : not null access procedure (Position : Cursor))
1814
   is
1815
      procedure Process_Node (Node : Count_Type);
1816
      pragma Inline (Process_Node);
1817
 
1818
      procedure Local_Reverse_Iterate is
1819
         new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
1820
 
1821
      ------------------
1822
      -- Process_Node --
1823
      ------------------
1824
 
1825
      procedure Process_Node (Node : Count_Type) is
1826
      begin
1827
         Process (Cursor'(Container'Unrestricted_Access, Node));
1828
      end Process_Node;
1829
 
1830
      S : Set renames Container'Unrestricted_Access.all;
1831
      B : Natural renames S.Busy;
1832
 
1833
   --  Start of processing for Reverse_Iterate
1834
 
1835
   begin
1836
      B := B + 1;
1837
 
1838
      begin
1839
         Local_Reverse_Iterate (S);
1840
      exception
1841
         when others =>
1842
            B := B - 1;
1843
            raise;
1844
      end;
1845
 
1846
      B := B - 1;
1847
   end Reverse_Iterate;
1848
 
1849
   -----------
1850
   -- Right --
1851
   -----------
1852
 
1853
   function Right (Node : Node_Type) return Count_Type is
1854
   begin
1855
      return Node.Right;
1856
   end Right;
1857
 
1858
   ---------------
1859
   -- Set_Color --
1860
   ---------------
1861
 
1862
   procedure Set_Color
1863
     (Node  : in out Node_Type;
1864
      Color : Red_Black_Trees.Color_Type)
1865
   is
1866
   begin
1867
      Node.Color := Color;
1868
   end Set_Color;
1869
 
1870
   --------------
1871
   -- Set_Left --
1872
   --------------
1873
 
1874
   procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
1875
   begin
1876
      Node.Left := Left;
1877
   end Set_Left;
1878
 
1879
   ----------------
1880
   -- Set_Parent --
1881
   ----------------
1882
 
1883
   procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
1884
   begin
1885
      Node.Parent := Parent;
1886
   end Set_Parent;
1887
 
1888
   ---------------
1889
   -- Set_Right --
1890
   ---------------
1891
 
1892
   procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
1893
   begin
1894
      Node.Right := Right;
1895
   end Set_Right;
1896
 
1897
   --------------------------
1898
   -- Symmetric_Difference --
1899
   --------------------------
1900
 
1901
   procedure Symmetric_Difference (Target : in out Set; Source : Set)
1902
      renames Set_Ops.Set_Symmetric_Difference;
1903
 
1904
   function Symmetric_Difference (Left, Right : Set) return Set
1905
      renames Set_Ops.Set_Symmetric_Difference;
1906
 
1907
   ------------
1908
   -- To_Set --
1909
   ------------
1910
 
1911
   function To_Set (New_Item : Element_Type) return Set is
1912
      Node     : Count_Type;
1913
      Inserted : Boolean;
1914
   begin
1915
      return S : Set (1) do
1916
         Insert_Sans_Hint (S, New_Item, Node, Inserted);
1917
         pragma Assert (Inserted);
1918
      end return;
1919
   end To_Set;
1920
 
1921
   -----------
1922
   -- Union --
1923
   -----------
1924
 
1925
   procedure Union (Target : in out Set; Source : Set)
1926
      renames Set_Ops.Set_Union;
1927
 
1928
   function Union (Left, Right : Set) return Set
1929
      renames Set_Ops.Set_Union;
1930
 
1931
   -----------
1932
   -- Write --
1933
   -----------
1934
 
1935
   procedure Write
1936
     (Stream    : not null access Root_Stream_Type'Class;
1937
      Container : Set)
1938
   is
1939
      procedure Write_Element
1940
        (Stream : not null access Root_Stream_Type'Class;
1941
         Node   : Node_Type);
1942
      pragma Inline (Write_Element);
1943
 
1944
      procedure Write_Elements is
1945
         new Tree_Operations.Generic_Write (Write_Element);
1946
 
1947
      -------------------
1948
      -- Write_Element --
1949
      -------------------
1950
 
1951
      procedure Write_Element
1952
        (Stream : not null access Root_Stream_Type'Class;
1953
         Node   : Node_Type)
1954
      is
1955
      begin
1956
         Element_Type'Write (Stream, Node.Element);
1957
      end Write_Element;
1958
 
1959
   --  Start of processing for Write
1960
 
1961
   begin
1962
      Write_Elements (Stream, Container);
1963
   end Write;
1964
 
1965
   procedure Write
1966
     (Stream : not null access Root_Stream_Type'Class;
1967
      Item   : Cursor)
1968
   is
1969
   begin
1970
      raise Program_Error with "attempt to stream set cursor";
1971
   end Write;
1972
 
1973
   procedure Write
1974
     (Stream : not null access Root_Stream_Type'Class;
1975
      Item   : Constant_Reference_Type)
1976
   is
1977
   begin
1978
      raise Program_Error with "attempt to stream reference";
1979
   end Write;
1980
 
1981
end Ada.Containers.Bounded_Ordered_Sets;

powered by: WebSVN 2.1.0

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