OSDN Git Service

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