1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S --
9 -- Copyright (C) 2010-2014, Free Software Foundation, Inc. --
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. --
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. --
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 ------------------------------------------------------------------------------
28 with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
30 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
32 with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
33 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
35 with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
37 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations);
39 with System; use type System.Address;
41 package body Ada.Containers.Formal_Ordered_Sets with
44 pragma Annotate (CodePeer, Skip_Analysis);
46 ------------------------------
47 -- Access to Fields of Node --
48 ------------------------------
50 -- These subprograms provide functional notation for access to fields
51 -- of a node, and procedural notation for modifiying these fields.
53 function Color (Node : Node_Type) return Red_Black_Trees.Color_Type;
54 pragma Inline (Color);
56 function Left_Son (Node : Node_Type) return Count_Type;
57 pragma Inline (Left_Son);
59 function Parent (Node : Node_Type) return Count_Type;
60 pragma Inline (Parent);
62 function Right_Son (Node : Node_Type) return Count_Type;
63 pragma Inline (Right_Son);
66 (Node : in out Node_Type;
67 Color : Red_Black_Trees.Color_Type);
68 pragma Inline (Set_Color);
70 procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
71 pragma Inline (Set_Left);
73 procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
74 pragma Inline (Set_Right);
76 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
77 pragma Inline (Set_Parent);
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
86 with procedure Set_Element (Node : in out Node_Type);
87 procedure Generic_Allocate
88 (Tree : in out Tree_Types.Tree_Type'Class;
89 Node : out Count_Type);
91 procedure Free (Tree : in out Set; X : Count_Type);
93 procedure Insert_Sans_Hint
94 (Container : in out Set;
95 New_Item : Element_Type;
96 Node : out Count_Type;
97 Inserted : out Boolean);
99 procedure Insert_With_Hint
100 (Dst_Set : in out Set;
101 Dst_Hint : Count_Type;
102 Src_Node : Node_Type;
103 Dst_Node : out Count_Type);
105 function Is_Greater_Element_Node
106 (Left : Element_Type;
107 Right : Node_Type) return Boolean;
108 pragma Inline (Is_Greater_Element_Node);
110 function Is_Less_Element_Node
111 (Left : Element_Type;
112 Right : Node_Type) return Boolean;
113 pragma Inline (Is_Less_Element_Node);
115 function Is_Less_Node_Node (L, R : Node_Type) return Boolean;
116 pragma Inline (Is_Less_Node_Node);
118 procedure Replace_Element
121 Item : Element_Type);
123 --------------------------
124 -- Local Instantiations --
125 --------------------------
127 package Tree_Operations is
128 new Red_Black_Trees.Generic_Bounded_Operations
135 package Element_Keys is
136 new Red_Black_Trees.Generic_Bounded_Keys
137 (Tree_Operations => Tree_Operations,
138 Key_Type => Element_Type,
139 Is_Less_Key_Node => Is_Less_Element_Node,
140 Is_Greater_Key_Node => Is_Greater_Element_Node);
143 new Red_Black_Trees.Generic_Bounded_Set_Operations
144 (Tree_Operations => Tree_Operations,
147 Insert_With_Hint => Insert_With_Hint,
148 Is_Less => Is_Less_Node_Node);
154 function "=" (Left, Right : Set) return Boolean is
160 if Length (Left) /= Length (Right) then
164 if Is_Empty (Left) then
168 Lst := Next (Left, Last (Left).Node);
170 Node := First (Left).Node;
171 while Node /= Lst loop
172 ENode := Find (Right, Left.Nodes (Node).Element).Node;
174 or else Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
179 Node := Next (Left, Node);
189 procedure Assign (Target : in out Set; Source : Set) is
190 procedure Append_Element (Source_Node : Count_Type);
192 procedure Append_Elements is
193 new Tree_Operations.Generic_Iteration (Append_Element);
199 procedure Append_Element (Source_Node : Count_Type) is
200 SN : Node_Type renames Source.Nodes (Source_Node);
202 procedure Set_Element (Node : in out Node_Type);
203 pragma Inline (Set_Element);
205 function New_Node return Count_Type;
206 pragma Inline (New_Node);
208 procedure Insert_Post is
209 new Element_Keys.Generic_Insert_Post (New_Node);
211 procedure Unconditional_Insert_Sans_Hint is
212 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
214 procedure Unconditional_Insert_Avec_Hint is
215 new Element_Keys.Generic_Unconditional_Insert_With_Hint
217 Unconditional_Insert_Sans_Hint);
219 procedure Allocate is new Generic_Allocate (Set_Element);
225 function New_Node return Count_Type is
228 Allocate (Target, Result);
236 procedure Set_Element (Node : in out Node_Type) is
238 Node.Element := SN.Element;
243 Target_Node : Count_Type;
245 -- Start of processing for Append_Element
248 Unconditional_Insert_Avec_Hint
252 Node => Target_Node);
255 -- Start of processing for Assign
258 if Target'Address = Source'Address then
262 if Target.Capacity < Source.Length then
263 raise Constraint_Error
264 with "Target capacity is less than Source length";
267 Tree_Operations.Clear_Tree (Target);
268 Append_Elements (Source);
275 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
276 Node : constant Count_Type := Element_Keys.Ceiling (Container, Item);
283 return (Node => Node);
290 procedure Clear (Container : in out Set) is
292 Tree_Operations.Clear_Tree (Container);
299 function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is
310 Item : Element_Type) return Boolean
313 return Find (Container, Item) /= No_Element;
320 function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
323 Target : Set (Count_Type'Max (Source.Capacity, Capacity));
326 if 0 < Capacity and then Capacity < Source.Capacity then
327 raise Capacity_Error;
330 if Length (Source) > 0 then
331 Target.Length := Source.Length;
332 Target.Root := Source.Root;
333 Target.First := Source.First;
334 Target.Last := Source.Last;
335 Target.Free := Source.Free;
338 while Node <= Source.Capacity loop
339 Target.Nodes (Node).Element :=
340 Source.Nodes (Node).Element;
341 Target.Nodes (Node).Parent :=
342 Source.Nodes (Node).Parent;
343 Target.Nodes (Node).Left :=
344 Source.Nodes (Node).Left;
345 Target.Nodes (Node).Right :=
346 Source.Nodes (Node).Right;
347 Target.Nodes (Node).Color :=
348 Source.Nodes (Node).Color;
349 Target.Nodes (Node).Has_Element :=
350 Source.Nodes (Node).Has_Element;
354 while Node <= Target.Capacity loop
356 Formal_Ordered_Sets.Free (Tree => Target, X => N);
364 ---------------------
365 -- Current_To_Last --
366 ---------------------
368 function Current_To_Last (Container : Set; Current : Cursor) return Set is
369 Curs : Cursor := First (Container);
370 C : Set (Container.Capacity) := Copy (Container, Container.Capacity);
374 if Curs = No_Element then
379 if Current /= No_Element and not Has_Element (Container, Current) then
380 raise Constraint_Error;
383 while Curs.Node /= Current.Node loop
386 Curs := Next (Container, (Node => Node));
396 procedure Delete (Container : in out Set; Position : in out Cursor) is
398 if not Has_Element (Container, Position) then
399 raise Constraint_Error with "Position cursor has no element";
402 pragma Assert (Vet (Container, Position.Node),
403 "bad cursor in Delete");
405 Tree_Operations.Delete_Node_Sans_Free (Container,
407 Formal_Ordered_Sets.Free (Container, Position.Node);
408 Position := No_Element;
411 procedure Delete (Container : in out Set; Item : Element_Type) is
412 X : constant Count_Type := Element_Keys.Find (Container, Item);
416 raise Constraint_Error with "attempt to delete element not in set";
419 Tree_Operations.Delete_Node_Sans_Free (Container, X);
420 Formal_Ordered_Sets.Free (Container, X);
427 procedure Delete_First (Container : in out Set) is
428 X : constant Count_Type := Container.First;
431 Tree_Operations.Delete_Node_Sans_Free (Container, X);
432 Formal_Ordered_Sets.Free (Container, X);
440 procedure Delete_Last (Container : in out Set) is
441 X : constant Count_Type := Container.Last;
444 Tree_Operations.Delete_Node_Sans_Free (Container, X);
445 Formal_Ordered_Sets.Free (Container, X);
453 procedure Difference (Target : in out Set; Source : Set) is
455 Set_Ops.Set_Difference (Target, Source);
458 function Difference (Left, Right : Set) return Set is
460 if Left'Address = Right'Address then
464 if Length (Left) = 0 then
468 if Length (Right) = 0 then
472 return S : Set (Length (Left)) do
473 Assign (S, Set_Ops.Set_Difference (Left, Right));
481 function Element (Container : Set; Position : Cursor) return Element_Type is
483 if not Has_Element (Container, Position) then
484 raise Constraint_Error with "Position cursor has no element";
487 pragma Assert (Vet (Container, Position.Node),
488 "bad cursor in Element");
490 return Container.Nodes (Position.Node).Element;
493 -------------------------
494 -- Equivalent_Elements --
495 -------------------------
497 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
506 end Equivalent_Elements;
508 ---------------------
509 -- Equivalent_Sets --
510 ---------------------
512 function Equivalent_Sets (Left, Right : Set) return Boolean is
513 function Is_Equivalent_Node_Node
514 (L, R : Node_Type) return Boolean;
515 pragma Inline (Is_Equivalent_Node_Node);
517 function Is_Equivalent is
518 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
520 -----------------------------
521 -- Is_Equivalent_Node_Node --
522 -----------------------------
524 function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is
526 if L.Element < R.Element then
528 elsif R.Element < L.Element then
533 end Is_Equivalent_Node_Node;
535 -- Start of processing for Equivalent_Sets
538 return Is_Equivalent (Left, Right);
545 procedure Exclude (Container : in out Set; Item : Element_Type) is
546 X : constant Count_Type := Element_Keys.Find (Container, Item);
549 Tree_Operations.Delete_Node_Sans_Free (Container, X);
550 Formal_Ordered_Sets.Free (Container, X);
558 function Find (Container : Set; Item : Element_Type) return Cursor is
559 Node : constant Count_Type := Element_Keys.Find (Container, Item);
566 return (Node => Node);
573 function First (Container : Set) return Cursor is
575 if Length (Container) = 0 then
579 return (Node => Container.First);
586 function First_Element (Container : Set) return Element_Type is
587 Fst : constant Count_Type := First (Container).Node;
590 raise Constraint_Error with "set is empty";
594 N : Tree_Types.Nodes_Type renames Container.Nodes;
596 return N (Fst).Element;
600 -----------------------
601 -- First_To_Previous --
602 -----------------------
604 function First_To_Previous
606 Current : Cursor) return Set
608 Curs : Cursor := Current;
609 C : Set (Container.Capacity) := Copy (Container, Container.Capacity);
613 if Curs = No_Element then
616 elsif not Has_Element (Container, Curs) then
617 raise Constraint_Error;
620 while Curs.Node /= 0 loop
623 Curs := Next (Container, (Node => Node));
628 end First_To_Previous;
634 function Floor (Container : Set; Item : Element_Type) return Cursor is
637 Node : constant Count_Type := Element_Keys.Floor (Container, Item);
644 return (Node => Node);
652 procedure Free (Tree : in out Set; X : Count_Type) is
654 Tree.Nodes (X).Has_Element := False;
655 Tree_Operations.Free (Tree, X);
658 ----------------------
659 -- Generic_Allocate --
660 ----------------------
662 procedure Generic_Allocate
663 (Tree : in out Tree_Types.Tree_Type'Class;
664 Node : out Count_Type)
666 procedure Allocate is
667 new Tree_Operations.Generic_Allocate (Set_Element);
669 Allocate (Tree, Node);
670 Tree.Nodes (Node).Has_Element := True;
671 end Generic_Allocate;
677 package body Generic_Keys is
679 -----------------------
680 -- Local Subprograms --
681 -----------------------
683 function Is_Greater_Key_Node
685 Right : Node_Type) return Boolean;
686 pragma Inline (Is_Greater_Key_Node);
688 function Is_Less_Key_Node
690 Right : Node_Type) return Boolean;
691 pragma Inline (Is_Less_Key_Node);
693 --------------------------
694 -- Local Instantiations --
695 --------------------------
698 new Red_Black_Trees.Generic_Bounded_Keys
699 (Tree_Operations => Tree_Operations,
700 Key_Type => Key_Type,
701 Is_Less_Key_Node => Is_Less_Key_Node,
702 Is_Greater_Key_Node => Is_Greater_Key_Node);
708 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
709 Node : constant Count_Type := Key_Keys.Ceiling (Container, Key);
716 return (Node => Node);
723 function Contains (Container : Set; Key : Key_Type) return Boolean is
725 return Find (Container, Key) /= No_Element;
732 procedure Delete (Container : in out Set; Key : Key_Type) is
733 X : constant Count_Type := Key_Keys.Find (Container, Key);
737 raise Constraint_Error with "attempt to delete key not in set";
740 Delete_Node_Sans_Free (Container, X);
741 Formal_Ordered_Sets.Free (Container, X);
748 function Element (Container : Set; Key : Key_Type) return Element_Type is
749 Node : constant Count_Type := Key_Keys.Find (Container, Key);
753 raise Constraint_Error with "key not in set";
757 N : Tree_Types.Nodes_Type renames Container.Nodes;
759 return N (Node).Element;
763 ---------------------
764 -- Equivalent_Keys --
765 ---------------------
767 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
782 procedure Exclude (Container : in out Set; Key : Key_Type) is
783 X : constant Count_Type := Key_Keys.Find (Container, Key);
786 Delete_Node_Sans_Free (Container, X);
787 Formal_Ordered_Sets.Free (Container, X);
795 function Find (Container : Set; Key : Key_Type) return Cursor is
796 Node : constant Count_Type := Key_Keys.Find (Container, Key);
798 return (if Node = 0 then No_Element else (Node => Node));
805 function Floor (Container : Set; Key : Key_Type) return Cursor is
806 Node : constant Count_Type := Key_Keys.Floor (Container, Key);
808 return (if Node = 0 then No_Element else (Node => Node));
811 -------------------------
812 -- Is_Greater_Key_Node --
813 -------------------------
815 function Is_Greater_Key_Node
817 Right : Node_Type) return Boolean
820 return Key (Right.Element) < Left;
821 end Is_Greater_Key_Node;
823 ----------------------
824 -- Is_Less_Key_Node --
825 ----------------------
827 function Is_Less_Key_Node
829 Right : Node_Type) return Boolean
832 return Left < Key (Right.Element);
833 end Is_Less_Key_Node;
839 function Key (Container : Set; Position : Cursor) return Key_Type is
841 if not Has_Element (Container, Position) then
842 raise Constraint_Error with
843 "Position cursor has no element";
846 pragma Assert (Vet (Container, Position.Node),
847 "bad cursor in Key");
850 N : Tree_Types.Nodes_Type renames Container.Nodes;
852 return Key (N (Position.Node).Element);
861 (Container : in out Set;
863 New_Item : Element_Type)
865 Node : constant Count_Type := Key_Keys.Find (Container, Key);
867 if not Has_Element (Container, (Node => Node)) then
868 raise Constraint_Error with
869 "attempt to replace key not in set";
871 Replace_Element (Container, Node, New_Item);
881 function Has_Element (Container : Set; Position : Cursor) return Boolean is
883 if Position.Node = 0 then
886 return Container.Nodes (Position.Node).Has_Element;
894 procedure Include (Container : in out Set; New_Item : Element_Type) is
899 Insert (Container, New_Item, Position, Inserted);
903 N : Tree_Types.Nodes_Type renames Container.Nodes;
905 N (Position.Node).Element := New_Item;
915 (Container : in out Set;
916 New_Item : Element_Type;
917 Position : out Cursor;
918 Inserted : out Boolean)
921 Insert_Sans_Hint (Container, New_Item, Position.Node, Inserted);
925 (Container : in out Set;
926 New_Item : Element_Type)
932 Insert (Container, New_Item, Position, Inserted);
935 raise Constraint_Error with
936 "attempt to insert element already in set";
940 ----------------------
941 -- Insert_Sans_Hint --
942 ----------------------
944 procedure Insert_Sans_Hint
945 (Container : in out Set;
946 New_Item : Element_Type;
947 Node : out Count_Type;
948 Inserted : out Boolean)
950 procedure Set_Element (Node : in out Node_Type);
952 function New_Node return Count_Type;
953 pragma Inline (New_Node);
955 procedure Insert_Post is
956 new Element_Keys.Generic_Insert_Post (New_Node);
958 procedure Conditional_Insert_Sans_Hint is
959 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
961 procedure Allocate is new Generic_Allocate (Set_Element);
967 function New_Node return Count_Type is
970 Allocate (Container, Result);
978 procedure Set_Element (Node : in out Node_Type) is
980 Node.Element := New_Item;
983 -- Start of processing for Insert_Sans_Hint
986 Conditional_Insert_Sans_Hint
991 end Insert_Sans_Hint;
993 ----------------------
994 -- Insert_With_Hint --
995 ----------------------
997 procedure Insert_With_Hint
998 (Dst_Set : in out Set;
999 Dst_Hint : Count_Type;
1000 Src_Node : Node_Type;
1001 Dst_Node : out Count_Type)
1004 pragma Unreferenced (Success);
1006 procedure Set_Element (Node : in out Node_Type);
1008 function New_Node return Count_Type;
1009 pragma Inline (New_Node);
1011 procedure Insert_Post is
1012 new Element_Keys.Generic_Insert_Post (New_Node);
1014 procedure Insert_Sans_Hint is
1015 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1017 procedure Local_Insert_With_Hint is
1018 new Element_Keys.Generic_Conditional_Insert_With_Hint
1019 (Insert_Post, Insert_Sans_Hint);
1021 procedure Allocate is new Generic_Allocate (Set_Element);
1027 function New_Node return Count_Type is
1028 Result : Count_Type;
1030 Allocate (Dst_Set, Result);
1038 procedure Set_Element (Node : in out Node_Type) is
1040 Node.Element := Src_Node.Element;
1043 -- Start of processing for Insert_With_Hint
1046 Local_Insert_With_Hint
1052 end Insert_With_Hint;
1058 procedure Intersection (Target : in out Set; Source : Set) is
1060 Set_Ops.Set_Intersection (Target, Source);
1063 function Intersection (Left, Right : Set) return Set is
1065 if Left'Address = Right'Address then
1069 return S : Set (Count_Type'Min (Length (Left), Length (Right))) do
1070 Assign (S, Set_Ops.Set_Intersection (Left, Right));
1078 function Is_Empty (Container : Set) return Boolean is
1080 return Length (Container) = 0;
1083 -----------------------------
1084 -- Is_Greater_Element_Node --
1085 -----------------------------
1087 function Is_Greater_Element_Node
1088 (Left : Element_Type;
1089 Right : Node_Type) return Boolean
1092 -- Compute e > node same as node < e
1094 return Right.Element < Left;
1095 end Is_Greater_Element_Node;
1097 --------------------------
1098 -- Is_Less_Element_Node --
1099 --------------------------
1101 function Is_Less_Element_Node
1102 (Left : Element_Type;
1103 Right : Node_Type) return Boolean
1106 return Left < Right.Element;
1107 end Is_Less_Element_Node;
1109 -----------------------
1110 -- Is_Less_Node_Node --
1111 -----------------------
1113 function Is_Less_Node_Node (L, R : Node_Type) return Boolean is
1115 return L.Element < R.Element;
1116 end Is_Less_Node_Node;
1122 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1124 return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set);
1131 function Last (Container : Set) return Cursor is
1133 return (if Length (Container) = 0
1135 else (Node => Container.Last));
1142 function Last_Element (Container : Set) return Element_Type is
1144 if Last (Container).Node = 0 then
1145 raise Constraint_Error with "set is empty";
1149 N : Tree_Types.Nodes_Type renames Container.Nodes;
1151 return N (Last (Container).Node).Element;
1159 function Left_Son (Node : Node_Type) return Count_Type is
1168 function Length (Container : Set) return Count_Type is
1170 return Container.Length;
1177 procedure Move (Target : in out Set; Source : in out Set) is
1178 N : Tree_Types.Nodes_Type renames Source.Nodes;
1182 if Target'Address = Source'Address then
1186 if Target.Capacity < Length (Source) then
1187 raise Constraint_Error with -- ???
1188 "Source length exceeds Target capacity";
1197 Insert (Target, N (X).Element); -- optimize???
1199 Tree_Operations.Delete_Node_Sans_Free (Source, X);
1200 Formal_Ordered_Sets.Free (Source, X);
1208 function Next (Container : Set; Position : Cursor) return Cursor is
1210 if Position = No_Element then
1214 if not Has_Element (Container, Position) then
1215 raise Constraint_Error;
1218 pragma Assert (Vet (Container, Position.Node),
1219 "bad cursor in Next");
1220 return (Node => Tree_Operations.Next (Container, Position.Node));
1223 procedure Next (Container : Set; Position : in out Cursor) is
1225 Position := Next (Container, Position);
1232 function Overlap (Left, Right : Set) return Boolean is
1234 return Set_Ops.Set_Overlap (Left, Right);
1241 function Parent (Node : Node_Type) return Count_Type is
1250 function Previous (Container : Set; Position : Cursor) return Cursor is
1252 if Position = No_Element then
1256 if not Has_Element (Container, Position) then
1257 raise Constraint_Error;
1260 pragma Assert (Vet (Container, Position.Node),
1261 "bad cursor in Previous");
1264 Node : constant Count_Type :=
1265 Tree_Operations.Previous (Container, Position.Node);
1267 return (if Node = 0 then No_Element else (Node => Node));
1271 procedure Previous (Container : Set; Position : in out Cursor) is
1273 Position := Previous (Container, Position);
1280 procedure Replace (Container : in out Set; New_Item : Element_Type) is
1281 Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
1285 raise Constraint_Error with
1286 "attempt to replace element not in set";
1289 Container.Nodes (Node).Element := New_Item;
1292 ---------------------
1293 -- Replace_Element --
1294 ---------------------
1296 procedure Replace_Element
1299 Item : Element_Type)
1301 pragma Assert (Node /= 0);
1303 function New_Node return Count_Type;
1304 pragma Inline (New_Node);
1306 procedure Local_Insert_Post is
1307 new Element_Keys.Generic_Insert_Post (New_Node);
1309 procedure Local_Insert_Sans_Hint is
1310 new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
1312 procedure Local_Insert_With_Hint is
1313 new Element_Keys.Generic_Conditional_Insert_With_Hint
1315 Local_Insert_Sans_Hint);
1317 NN : Tree_Types.Nodes_Type renames Tree.Nodes;
1323 function New_Node return Count_Type is
1324 N : Node_Type renames NN (Node);
1335 Result : Count_Type;
1338 -- Start of processing for Insert
1341 if Item < NN (Node).Element
1342 or else NN (Node).Element < Item
1347 NN (Node).Element := Item;
1351 Hint := Element_Keys.Ceiling (Tree, Item);
1356 elsif Item < NN (Hint).Element then
1358 NN (Node).Element := Item;
1363 pragma Assert (not (NN (Hint).Element < Item));
1364 raise Program_Error with "attempt to replace existing element";
1367 Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
1369 Local_Insert_With_Hint
1374 Inserted => Inserted);
1376 pragma Assert (Inserted);
1377 pragma Assert (Result = Node);
1378 end Replace_Element;
1380 procedure Replace_Element
1381 (Container : in out Set;
1383 New_Item : Element_Type)
1386 if not Has_Element (Container, Position) then
1387 raise Constraint_Error with
1388 "Position cursor has no element";
1391 pragma Assert (Vet (Container, Position.Node),
1392 "bad cursor in Replace_Element");
1394 Replace_Element (Container, Position.Node, New_Item);
1395 end Replace_Element;
1401 function Right_Son (Node : Node_Type) return Count_Type is
1411 (Node : in out Node_Type;
1412 Color : Red_Black_Trees.Color_Type)
1415 Node.Color := Color;
1422 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
1431 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
1433 Node.Parent := Parent;
1440 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
1442 Node.Right := Right;
1449 function Strict_Equal (Left, Right : Set) return Boolean is
1450 LNode : Count_Type := First (Left).Node;
1451 RNode : Count_Type := First (Right).Node;
1454 if Length (Left) /= Length (Right) then
1458 while LNode = RNode loop
1463 if Left.Nodes (LNode).Element /= Right.Nodes (RNode).Element then
1467 LNode := Next (Left, LNode);
1468 RNode := Next (Right, RNode);
1474 --------------------------
1475 -- Symmetric_Difference --
1476 --------------------------
1478 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
1480 Set_Ops.Set_Symmetric_Difference (Target, Source);
1481 end Symmetric_Difference;
1483 function Symmetric_Difference (Left, Right : Set) return Set is
1485 if Left'Address = Right'Address then
1489 if Length (Right) = 0 then
1493 if Length (Left) = 0 then
1497 return S : Set (Length (Left) + Length (Right)) do
1498 Assign (S, Set_Ops.Set_Symmetric_Difference (Left, Right));
1500 end Symmetric_Difference;
1506 function To_Set (New_Item : Element_Type) return Set is
1510 return S : Set (Capacity => 1) do
1511 Insert_Sans_Hint (S, New_Item, Node, Inserted);
1512 pragma Assert (Inserted);
1520 procedure Union (Target : in out Set; Source : Set) is
1522 Set_Ops.Set_Union (Target, Source);
1525 function Union (Left, Right : Set) return Set is
1527 if Left'Address = Right'Address then
1531 if Length (Left) = 0 then
1535 if Length (Right) = 0 then
1539 return S : Set (Length (Left) + Length (Right)) do
1540 Assign (S, Source => Left);
1545 end Ada.Containers.Formal_Ordered_Sets;