PR rtl-optimization/57003
[official-gcc.git] / gcc / ada / a-ciorse.adb
blob7c14cac72cb90e663f65077c9443840722653646
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2014, 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 ------------------------------------------------------------------------------
30 with Ada.Containers.Red_Black_Trees.Generic_Operations;
31 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations);
33 with Ada.Containers.Red_Black_Trees.Generic_Keys;
34 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
36 with Ada.Containers.Red_Black_Trees.Generic_Set_Operations;
37 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
39 with Ada.Unchecked_Deallocation;
41 with System; use type System.Address;
43 package body Ada.Containers.Indefinite_Ordered_Sets is
45 -----------------------
46 -- Local Subprograms --
47 -----------------------
49 function Color (Node : Node_Access) return Color_Type;
50 pragma Inline (Color);
52 function Copy_Node (Source : Node_Access) return Node_Access;
53 pragma Inline (Copy_Node);
55 procedure Free (X : in out Node_Access);
57 procedure Insert_Sans_Hint
58 (Tree : in out Tree_Type;
59 New_Item : Element_Type;
60 Node : out Node_Access;
61 Inserted : out Boolean);
63 procedure Insert_With_Hint
64 (Dst_Tree : in out Tree_Type;
65 Dst_Hint : Node_Access;
66 Src_Node : Node_Access;
67 Dst_Node : out Node_Access);
69 function Is_Greater_Element_Node
70 (Left : Element_Type;
71 Right : Node_Access) return Boolean;
72 pragma Inline (Is_Greater_Element_Node);
74 function Is_Less_Element_Node
75 (Left : Element_Type;
76 Right : Node_Access) return Boolean;
77 pragma Inline (Is_Less_Element_Node);
79 function Is_Less_Node_Node (L, R : Node_Access) return Boolean;
80 pragma Inline (Is_Less_Node_Node);
82 function Left (Node : Node_Access) return Node_Access;
83 pragma Inline (Left);
85 function Parent (Node : Node_Access) return Node_Access;
86 pragma Inline (Parent);
88 procedure Replace_Element
89 (Tree : in out Tree_Type;
90 Node : Node_Access;
91 Item : Element_Type);
93 function Right (Node : Node_Access) return Node_Access;
94 pragma Inline (Right);
96 procedure Set_Color (Node : Node_Access; Color : Color_Type);
97 pragma Inline (Set_Color);
99 procedure Set_Left (Node : Node_Access; Left : Node_Access);
100 pragma Inline (Set_Left);
102 procedure Set_Parent (Node : Node_Access; Parent : Node_Access);
103 pragma Inline (Set_Parent);
105 procedure Set_Right (Node : Node_Access; Right : Node_Access);
106 pragma Inline (Set_Right);
108 --------------------------
109 -- Local Instantiations --
110 --------------------------
112 procedure Free_Element is
113 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
115 package Tree_Operations is
116 new Red_Black_Trees.Generic_Operations (Tree_Types);
118 procedure Delete_Tree is
119 new Tree_Operations.Generic_Delete_Tree (Free);
121 function Copy_Tree is
122 new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree);
124 use Tree_Operations;
126 package Element_Keys is
127 new Red_Black_Trees.Generic_Keys
128 (Tree_Operations => Tree_Operations,
129 Key_Type => Element_Type,
130 Is_Less_Key_Node => Is_Less_Element_Node,
131 Is_Greater_Key_Node => Is_Greater_Element_Node);
133 package Set_Ops is
134 new Generic_Set_Operations
135 (Tree_Operations => Tree_Operations,
136 Insert_With_Hint => Insert_With_Hint,
137 Copy_Tree => Copy_Tree,
138 Delete_Tree => Delete_Tree,
139 Is_Less => Is_Less_Node_Node,
140 Free => Free);
142 ---------
143 -- "<" --
144 ---------
146 function "<" (Left, Right : Cursor) return Boolean is
147 begin
148 if Left.Node = null then
149 raise Constraint_Error with "Left cursor equals No_Element";
150 end if;
152 if Right.Node = null then
153 raise Constraint_Error with "Right cursor equals No_Element";
154 end if;
156 if Left.Node.Element = null then
157 raise Program_Error with "Left cursor is bad";
158 end if;
160 if Right.Node.Element = null then
161 raise Program_Error with "Right cursor is bad";
162 end if;
164 pragma Assert (Vet (Left.Container.Tree, Left.Node),
165 "bad Left cursor in ""<""");
167 pragma Assert (Vet (Right.Container.Tree, Right.Node),
168 "bad Right cursor in ""<""");
170 return Left.Node.Element.all < Right.Node.Element.all;
171 end "<";
173 function "<" (Left : Cursor; Right : Element_Type) return Boolean is
174 begin
175 if Left.Node = null then
176 raise Constraint_Error with "Left cursor equals No_Element";
177 end if;
179 if Left.Node.Element = null then
180 raise Program_Error with "Left cursor is bad";
181 end if;
183 pragma Assert (Vet (Left.Container.Tree, Left.Node),
184 "bad Left cursor in ""<""");
186 return Left.Node.Element.all < Right;
187 end "<";
189 function "<" (Left : Element_Type; Right : Cursor) return Boolean is
190 begin
191 if Right.Node = null then
192 raise Constraint_Error with "Right cursor equals No_Element";
193 end if;
195 if Right.Node.Element = null then
196 raise Program_Error with "Right cursor is bad";
197 end if;
199 pragma Assert (Vet (Right.Container.Tree, Right.Node),
200 "bad Right cursor in ""<""");
202 return Left < Right.Node.Element.all;
203 end "<";
205 ---------
206 -- "=" --
207 ---------
209 function "=" (Left, Right : Set) return Boolean is
211 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean;
212 pragma Inline (Is_Equal_Node_Node);
214 function Is_Equal is
215 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
217 ------------------------
218 -- Is_Equal_Node_Node --
219 ------------------------
221 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is
222 begin
223 return L.Element.all = R.Element.all;
224 end Is_Equal_Node_Node;
226 -- Start of processing for "="
228 begin
229 return Is_Equal (Left.Tree, Right.Tree);
230 end "=";
232 ---------
233 -- ">" --
234 ---------
236 function ">" (Left, Right : Cursor) return Boolean is
237 begin
238 if Left.Node = null then
239 raise Constraint_Error with "Left cursor equals No_Element";
240 end if;
242 if Right.Node = null then
243 raise Constraint_Error with "Right cursor equals No_Element";
244 end if;
246 if Left.Node.Element = null then
247 raise Program_Error with "Left cursor is bad";
248 end if;
250 if Right.Node.Element = null then
251 raise Program_Error with "Right cursor is bad";
252 end if;
254 pragma Assert (Vet (Left.Container.Tree, Left.Node),
255 "bad Left cursor in "">""");
257 pragma Assert (Vet (Right.Container.Tree, Right.Node),
258 "bad Right cursor in "">""");
260 -- L > R same as R < L
262 return Right.Node.Element.all < Left.Node.Element.all;
263 end ">";
265 function ">" (Left : Cursor; Right : Element_Type) return Boolean is
266 begin
267 if Left.Node = null then
268 raise Constraint_Error with "Left cursor equals No_Element";
269 end if;
271 if Left.Node.Element = null then
272 raise Program_Error with "Left cursor is bad";
273 end if;
275 pragma Assert (Vet (Left.Container.Tree, Left.Node),
276 "bad Left cursor in "">""");
278 return Right < Left.Node.Element.all;
279 end ">";
281 function ">" (Left : Element_Type; Right : Cursor) return Boolean is
282 begin
283 if Right.Node = null then
284 raise Constraint_Error with "Right cursor equals No_Element";
285 end if;
287 if Right.Node.Element = null then
288 raise Program_Error with "Right cursor is bad";
289 end if;
291 pragma Assert (Vet (Right.Container.Tree, Right.Node),
292 "bad Right cursor in "">""");
294 return Right.Node.Element.all < Left;
295 end ">";
297 ------------
298 -- Adjust --
299 ------------
301 procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree);
303 procedure Adjust (Container : in out Set) is
304 begin
305 Adjust (Container.Tree);
306 end Adjust;
308 procedure Adjust (Control : in out Reference_Control_Type) is
309 begin
310 if Control.Container /= null then
311 declare
312 Tree : Tree_Type renames Control.Container.all.Tree;
313 B : Natural renames Tree.Busy;
314 L : Natural renames Tree.Lock;
315 begin
316 B := B + 1;
317 L := L + 1;
318 end;
319 end if;
320 end Adjust;
322 ------------
323 -- Assign --
324 ------------
326 procedure Assign (Target : in out Set; Source : Set) is
327 begin
328 if Target'Address = Source'Address then
329 return;
330 end if;
332 Target.Clear;
333 Target.Union (Source);
334 end Assign;
336 -------------
337 -- Ceiling --
338 -------------
340 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
341 Node : constant Node_Access :=
342 Element_Keys.Ceiling (Container.Tree, Item);
343 begin
344 return (if Node = null then No_Element
345 else Cursor'(Container'Unrestricted_Access, Node));
346 end Ceiling;
348 -----------
349 -- Clear --
350 -----------
352 procedure Clear is
353 new Tree_Operations.Generic_Clear (Delete_Tree);
355 procedure Clear (Container : in out Set) is
356 begin
357 Clear (Container.Tree);
358 end Clear;
360 -----------
361 -- Color --
362 -----------
364 function Color (Node : Node_Access) return Color_Type is
365 begin
366 return Node.Color;
367 end Color;
369 ------------------------
370 -- Constant_Reference --
371 ------------------------
373 function Constant_Reference
374 (Container : aliased Set;
375 Position : Cursor) return Constant_Reference_Type
377 begin
378 if Position.Container = null then
379 raise Constraint_Error with "Position cursor has no element";
380 end if;
382 if Position.Container /= Container'Unrestricted_Access then
383 raise Program_Error with
384 "Position cursor designates wrong container";
385 end if;
387 if Position.Node.Element = null then
388 raise Program_Error with "Node has no element";
389 end if;
391 pragma Assert
392 (Vet (Container.Tree, Position.Node),
393 "bad cursor in Constant_Reference");
395 declare
396 Tree : Tree_Type renames Position.Container.all.Tree;
397 B : Natural renames Tree.Busy;
398 L : Natural renames Tree.Lock;
399 begin
400 return R : constant Constant_Reference_Type :=
401 (Element => Position.Node.Element.all'Access,
402 Control => (Controlled with Container'Unrestricted_Access))
404 B := B + 1;
405 L := L + 1;
406 end return;
407 end;
408 end Constant_Reference;
410 --------------
411 -- Contains --
412 --------------
414 function Contains (Container : Set; Item : Element_Type) return Boolean is
415 begin
416 return Find (Container, Item) /= No_Element;
417 end Contains;
419 ----------
420 -- Copy --
421 ----------
423 function Copy (Source : Set) return Set is
424 begin
425 return Target : Set do
426 Target.Assign (Source);
427 end return;
428 end Copy;
430 ---------------
431 -- Copy_Node --
432 ---------------
434 function Copy_Node (Source : Node_Access) return Node_Access is
435 Element : Element_Access := new Element_Type'(Source.Element.all);
437 begin
438 return new Node_Type'(Parent => null,
439 Left => null,
440 Right => null,
441 Color => Source.Color,
442 Element => Element);
444 exception
445 when others =>
446 Free_Element (Element);
447 raise;
448 end Copy_Node;
450 ------------
451 -- Delete --
452 ------------
454 procedure Delete (Container : in out Set; Position : in out Cursor) is
455 begin
456 if Position.Node = null then
457 raise Constraint_Error with "Position cursor equals No_Element";
458 end if;
460 if Position.Node.Element = null then
461 raise Program_Error with "Position cursor is bad";
462 end if;
464 if Position.Container /= Container'Unrestricted_Access then
465 raise Program_Error with "Position cursor designates wrong set";
466 end if;
468 pragma Assert (Vet (Container.Tree, Position.Node),
469 "bad cursor in Delete");
471 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node);
472 Free (Position.Node);
473 Position.Container := null;
474 end Delete;
476 procedure Delete (Container : in out Set; Item : Element_Type) is
477 X : Node_Access := Element_Keys.Find (Container.Tree, Item);
478 begin
479 if X = null then
480 raise Constraint_Error with "attempt to delete element not in set";
481 else
482 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
483 Free (X);
484 end if;
485 end Delete;
487 ------------------
488 -- Delete_First --
489 ------------------
491 procedure Delete_First (Container : in out Set) is
492 Tree : Tree_Type renames Container.Tree;
493 X : Node_Access := Tree.First;
494 begin
495 if X /= null then
496 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
497 Free (X);
498 end if;
499 end Delete_First;
501 -----------------
502 -- Delete_Last --
503 -----------------
505 procedure Delete_Last (Container : in out Set) is
506 Tree : Tree_Type renames Container.Tree;
507 X : Node_Access := Tree.Last;
508 begin
509 if X /= null then
510 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
511 Free (X);
512 end if;
513 end Delete_Last;
515 ----------------
516 -- Difference --
517 ----------------
519 procedure Difference (Target : in out Set; Source : Set) is
520 begin
521 Set_Ops.Difference (Target.Tree, Source.Tree);
522 end Difference;
524 function Difference (Left, Right : Set) return Set is
525 Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree);
526 begin
527 return Set'(Controlled with Tree);
528 end Difference;
530 -------------
531 -- Element --
532 -------------
534 function Element (Position : Cursor) return Element_Type is
535 begin
536 if Position.Node = null then
537 raise Constraint_Error with "Position cursor equals No_Element";
538 end if;
540 if Position.Node.Element = null then
541 raise Program_Error with "Position cursor is bad";
542 end if;
544 pragma Assert (Vet (Position.Container.Tree, Position.Node),
545 "bad cursor in Element");
547 return Position.Node.Element.all;
548 end Element;
550 -------------------------
551 -- Equivalent_Elements --
552 -------------------------
554 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
555 begin
556 if Left < Right or else Right < Left then
557 return False;
558 else
559 return True;
560 end if;
561 end Equivalent_Elements;
563 ---------------------
564 -- Equivalent_Sets --
565 ---------------------
567 function Equivalent_Sets (Left, Right : Set) return Boolean is
569 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean;
570 pragma Inline (Is_Equivalent_Node_Node);
572 function Is_Equivalent is
573 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
575 -----------------------------
576 -- Is_Equivalent_Node_Node --
577 -----------------------------
579 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
580 begin
581 if L.Element.all < R.Element.all then
582 return False;
583 elsif R.Element.all < L.Element.all then
584 return False;
585 else
586 return True;
587 end if;
588 end Is_Equivalent_Node_Node;
590 -- Start of processing for Equivalent_Sets
592 begin
593 return Is_Equivalent (Left.Tree, Right.Tree);
594 end Equivalent_Sets;
596 -------------
597 -- Exclude --
598 -------------
600 procedure Exclude (Container : in out Set; Item : Element_Type) is
601 X : Node_Access := Element_Keys.Find (Container.Tree, Item);
602 begin
603 if X /= null then
604 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
605 Free (X);
606 end if;
607 end Exclude;
609 --------------
610 -- Finalize --
611 --------------
613 procedure Finalize (Object : in out Iterator) is
614 begin
615 if Object.Container /= null then
616 declare
617 B : Natural renames Object.Container.all.Tree.Busy;
618 begin
619 B := B - 1;
620 end;
621 end if;
622 end Finalize;
624 procedure Finalize (Control : in out Reference_Control_Type) is
625 begin
626 if Control.Container /= null then
627 declare
628 Tree : Tree_Type renames Control.Container.all.Tree;
629 B : Natural renames Tree.Busy;
630 L : Natural renames Tree.Lock;
631 begin
632 B := B - 1;
633 L := L - 1;
634 end;
636 Control.Container := null;
637 end if;
638 end Finalize;
640 ----------
641 -- Find --
642 ----------
644 function Find (Container : Set; Item : Element_Type) return Cursor is
645 Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item);
646 begin
647 if Node = null then
648 return No_Element;
649 else
650 return Cursor'(Container'Unrestricted_Access, Node);
651 end if;
652 end Find;
654 -----------
655 -- First --
656 -----------
658 function First (Container : Set) return Cursor is
659 begin
660 return
661 (if Container.Tree.First = null then No_Element
662 else Cursor'(Container'Unrestricted_Access, Container.Tree.First));
663 end First;
665 function First (Object : Iterator) return Cursor is
666 begin
667 -- The value of the iterator object's Node component influences the
668 -- behavior of the First (and Last) selector function.
670 -- When the Node component is null, this means the iterator object was
671 -- constructed without a start expression, in which case the (forward)
672 -- iteration starts from the (logical) beginning of the entire sequence
673 -- of items (corresponding to Container.First, for a forward iterator).
675 -- Otherwise, this is iteration over a partial sequence of items. When
676 -- the Node component is non-null, the iterator object was constructed
677 -- with a start expression, that specifies the position from which the
678 -- (forward) partial iteration begins.
680 if Object.Node = null then
681 return Object.Container.First;
682 else
683 return Cursor'(Object.Container, Object.Node);
684 end if;
685 end First;
687 -------------------
688 -- First_Element --
689 -------------------
691 function First_Element (Container : Set) return Element_Type is
692 begin
693 if Container.Tree.First = null then
694 raise Constraint_Error with "set is empty";
695 else
696 return Container.Tree.First.Element.all;
697 end if;
698 end First_Element;
700 -----------
701 -- Floor --
702 -----------
704 function Floor (Container : Set; Item : Element_Type) return Cursor is
705 Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item);
706 begin
707 return (if Node = null then No_Element
708 else Cursor'(Container'Unrestricted_Access, Node));
709 end Floor;
711 ----------
712 -- Free --
713 ----------
715 procedure Free (X : in out Node_Access) is
716 procedure Deallocate is
717 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
719 begin
720 if X = null then
721 return;
722 end if;
724 X.Parent := X;
725 X.Left := X;
726 X.Right := X;
728 begin
729 Free_Element (X.Element);
730 exception
731 when others =>
732 X.Element := null;
733 Deallocate (X);
734 raise;
735 end;
737 Deallocate (X);
738 end Free;
740 ------------------
741 -- Generic_Keys --
742 ------------------
744 package body Generic_Keys is
746 -----------------------
747 -- Local Subprograms --
748 -----------------------
750 function Is_Greater_Key_Node
751 (Left : Key_Type;
752 Right : Node_Access) return Boolean;
753 pragma Inline (Is_Greater_Key_Node);
755 function Is_Less_Key_Node
756 (Left : Key_Type;
757 Right : Node_Access) return Boolean;
758 pragma Inline (Is_Less_Key_Node);
760 --------------------------
761 -- Local Instantiations --
762 --------------------------
764 package Key_Keys is
765 new Red_Black_Trees.Generic_Keys
766 (Tree_Operations => Tree_Operations,
767 Key_Type => Key_Type,
768 Is_Less_Key_Node => Is_Less_Key_Node,
769 Is_Greater_Key_Node => Is_Greater_Key_Node);
771 ------------
772 -- Adjust --
773 ------------
775 procedure Adjust (Control : in out Reference_Control_Type) is
776 begin
777 if Control.Container /= null then
778 declare
779 Tree : Tree_Type renames Control.Container.Tree;
780 B : Natural renames Tree.Busy;
781 L : Natural renames Tree.Lock;
782 begin
783 B := B + 1;
784 L := L + 1;
785 end;
786 end if;
787 end Adjust;
789 -------------
790 -- Ceiling --
791 -------------
793 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
794 Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key);
795 begin
796 return (if Node = null then No_Element
797 else Cursor'(Container'Unrestricted_Access, Node));
798 end Ceiling;
800 ------------------------
801 -- Constant_Reference --
802 ------------------------
804 function Constant_Reference
805 (Container : aliased Set;
806 Key : Key_Type) return Constant_Reference_Type
808 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
810 begin
811 if Node = null then
812 raise Constraint_Error with "Key not in set";
813 end if;
815 if Node.Element = null then
816 raise Program_Error with "Node has no element";
817 end if;
819 declare
820 Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
821 B : Natural renames Tree.Busy;
822 L : Natural renames Tree.Lock;
823 begin
824 return R : constant Constant_Reference_Type :=
825 (Element => Node.Element.all'Access,
826 Control => (Controlled with Container'Unrestricted_Access))
828 B := B + 1;
829 L := L + 1;
830 end return;
831 end;
832 end Constant_Reference;
834 --------------
835 -- Contains --
836 --------------
838 function Contains (Container : Set; Key : Key_Type) return Boolean is
839 begin
840 return Find (Container, Key) /= No_Element;
841 end Contains;
843 ------------
844 -- Delete --
845 ------------
847 procedure Delete (Container : in out Set; Key : Key_Type) is
848 X : Node_Access := Key_Keys.Find (Container.Tree, Key);
850 begin
851 if X = null then
852 raise Constraint_Error with "attempt to delete key not in set";
853 end if;
855 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
856 Free (X);
857 end Delete;
859 -------------
860 -- Element --
861 -------------
863 function Element (Container : Set; Key : Key_Type) return Element_Type is
864 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
865 begin
866 if Node = null then
867 raise Constraint_Error with "key not in set";
868 else
869 return Node.Element.all;
870 end if;
871 end Element;
873 ---------------------
874 -- Equivalent_Keys --
875 ---------------------
877 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
878 begin
879 if Left < Right or else Right < Left then
880 return False;
881 else
882 return True;
883 end if;
884 end Equivalent_Keys;
886 -------------
887 -- Exclude --
888 -------------
890 procedure Exclude (Container : in out Set; Key : Key_Type) is
891 X : Node_Access := Key_Keys.Find (Container.Tree, Key);
892 begin
893 if X /= null then
894 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
895 Free (X);
896 end if;
897 end Exclude;
899 --------------
900 -- Finalize --
901 --------------
903 procedure Finalize (Control : in out Reference_Control_Type) is
904 begin
905 if Control.Container /= null then
906 declare
907 Tree : Tree_Type renames Control.Container.Tree;
908 B : Natural renames Tree.Busy;
909 L : Natural renames Tree.Lock;
910 begin
911 B := B - 1;
912 L := L - 1;
913 end;
915 if not (Key (Control.Pos) = Control.Old_Key.all) then
916 Delete (Control.Container.all, Key (Control.Pos));
917 raise Program_Error;
918 end if;
920 Control.Container := null;
921 Control.Old_Key := null;
922 end if;
923 end Finalize;
925 ----------
926 -- Find --
927 ----------
929 function Find (Container : Set; Key : Key_Type) return Cursor is
930 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
931 begin
932 return (if Node = null then No_Element
933 else Cursor'(Container'Unrestricted_Access, Node));
934 end Find;
936 -----------
937 -- Floor --
938 -----------
940 function Floor (Container : Set; Key : Key_Type) return Cursor is
941 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key);
942 begin
943 return (if Node = null then No_Element
944 else Cursor'(Container'Unrestricted_Access, Node));
945 end Floor;
947 -------------------------
948 -- Is_Greater_Key_Node --
949 -------------------------
951 function Is_Greater_Key_Node
952 (Left : Key_Type;
953 Right : Node_Access) return Boolean
955 begin
956 return Key (Right.Element.all) < Left;
957 end Is_Greater_Key_Node;
959 ----------------------
960 -- Is_Less_Key_Node --
961 ----------------------
963 function Is_Less_Key_Node
964 (Left : Key_Type;
965 Right : Node_Access) return Boolean
967 begin
968 return Left < Key (Right.Element.all);
969 end Is_Less_Key_Node;
971 ---------
972 -- Key --
973 ---------
975 function Key (Position : Cursor) return Key_Type is
976 begin
977 if Position.Node = null then
978 raise Constraint_Error with
979 "Position cursor equals No_Element";
980 end if;
982 if Position.Node.Element = null then
983 raise Program_Error with
984 "Position cursor is bad";
985 end if;
987 pragma Assert (Vet (Position.Container.Tree, Position.Node),
988 "bad cursor in Key");
990 return Key (Position.Node.Element.all);
991 end Key;
993 -------------
994 -- Replace --
995 -------------
997 procedure Replace
998 (Container : in out Set;
999 Key : Key_Type;
1000 New_Item : Element_Type)
1002 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
1004 begin
1005 if Node = null then
1006 raise Constraint_Error with
1007 "attempt to replace key not in set";
1008 end if;
1010 Replace_Element (Container.Tree, Node, New_Item);
1011 end Replace;
1013 ----------
1014 -- Read --
1015 ----------
1017 procedure Read
1018 (Stream : not null access Root_Stream_Type'Class;
1019 Item : out Reference_Type)
1021 begin
1022 raise Program_Error with "attempt to stream reference";
1023 end Read;
1025 ------------------------------
1026 -- Reference_Preserving_Key --
1027 ------------------------------
1029 function Reference_Preserving_Key
1030 (Container : aliased in out Set;
1031 Position : Cursor) return Reference_Type
1033 begin
1034 if Position.Container = null then
1035 raise Constraint_Error with "Position cursor has no element";
1036 end if;
1038 if Position.Container /= Container'Unrestricted_Access then
1039 raise Program_Error with
1040 "Position cursor designates wrong container";
1041 end if;
1043 if Position.Node.Element = null then
1044 raise Program_Error with "Node has no element";
1045 end if;
1047 pragma Assert
1048 (Vet (Container.Tree, Position.Node),
1049 "bad cursor in function Reference_Preserving_Key");
1051 declare
1052 Tree : Tree_Type renames Container.Tree;
1053 B : Natural renames Tree.Busy;
1054 L : Natural renames Tree.Lock;
1055 begin
1056 return R : constant Reference_Type :=
1057 (Element => Position.Node.Element.all'Unchecked_Access,
1058 Control =>
1059 (Controlled with
1060 Container => Container'Access,
1061 Pos => Position,
1062 Old_Key => new Key_Type'(Key (Position))))
1064 B := B + 1;
1065 L := L + 1;
1066 end return;
1067 end;
1068 end Reference_Preserving_Key;
1070 function Reference_Preserving_Key
1071 (Container : aliased in out Set;
1072 Key : Key_Type) return Reference_Type
1074 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key);
1076 begin
1077 if Node = null then
1078 raise Constraint_Error with "Key not in set";
1079 end if;
1081 if Node.Element = null then
1082 raise Program_Error with "Node has no element";
1083 end if;
1085 declare
1086 Tree : Tree_Type renames Container.Tree;
1087 B : Natural renames Tree.Busy;
1088 L : Natural renames Tree.Lock;
1089 begin
1090 return R : constant Reference_Type :=
1091 (Element => Node.Element.all'Unchecked_Access,
1092 Control =>
1093 (Controlled with
1094 Container => Container'Access,
1095 Pos => Find (Container, Key),
1096 Old_Key => new Key_Type'(Key)))
1098 B := B + 1;
1099 L := L + 1;
1100 end return;
1101 end;
1102 end Reference_Preserving_Key;
1104 -----------------------------------
1105 -- Update_Element_Preserving_Key --
1106 -----------------------------------
1108 procedure Update_Element_Preserving_Key
1109 (Container : in out Set;
1110 Position : Cursor;
1111 Process : not null access
1112 procedure (Element : in out Element_Type))
1114 Tree : Tree_Type renames Container.Tree;
1116 begin
1117 if Position.Node = null then
1118 raise Constraint_Error with "Position cursor equals No_Element";
1119 end if;
1121 if Position.Node.Element = null then
1122 raise Program_Error with "Position cursor is bad";
1123 end if;
1125 if Position.Container /= Container'Unrestricted_Access then
1126 raise Program_Error with "Position cursor designates wrong set";
1127 end if;
1129 pragma Assert (Vet (Container.Tree, Position.Node),
1130 "bad cursor in Update_Element_Preserving_Key");
1132 declare
1133 E : Element_Type renames Position.Node.Element.all;
1134 K : constant Key_Type := Key (E);
1136 B : Natural renames Tree.Busy;
1137 L : Natural renames Tree.Lock;
1139 Eq : Boolean;
1141 begin
1142 B := B + 1;
1143 L := L + 1;
1145 begin
1146 Process (E);
1147 Eq := Equivalent_Keys (K, Key (E));
1148 exception
1149 when others =>
1150 L := L - 1;
1151 B := B - 1;
1152 raise;
1153 end;
1155 L := L - 1;
1156 B := B - 1;
1158 if Eq then
1159 return;
1160 end if;
1161 end;
1163 declare
1164 X : Node_Access := Position.Node;
1165 begin
1166 Tree_Operations.Delete_Node_Sans_Free (Tree, X);
1167 Free (X);
1168 end;
1170 raise Program_Error with "key was modified";
1171 end Update_Element_Preserving_Key;
1173 -----------
1174 -- Write --
1175 -----------
1177 procedure Write
1178 (Stream : not null access Root_Stream_Type'Class;
1179 Item : Reference_Type)
1181 begin
1182 raise Program_Error with "attempt to stream reference";
1183 end Write;
1185 end Generic_Keys;
1187 -----------------
1188 -- Has_Element --
1189 -----------------
1191 function Has_Element (Position : Cursor) return Boolean is
1192 begin
1193 return Position /= No_Element;
1194 end Has_Element;
1196 -------------
1197 -- Include --
1198 -------------
1200 procedure Include (Container : in out Set; New_Item : Element_Type) is
1201 Position : Cursor;
1202 Inserted : Boolean;
1204 X : Element_Access;
1206 begin
1207 Insert (Container, New_Item, Position, Inserted);
1209 if not Inserted then
1210 if Container.Tree.Lock > 0 then
1211 raise Program_Error with
1212 "attempt to tamper with elements (set is locked)";
1213 end if;
1215 declare
1216 -- The element allocator may need an accessibility check in the
1217 -- case the actual type is class-wide or has access discriminants
1218 -- (see RM 4.8(10.1) and AI12-0035).
1220 pragma Unsuppress (Accessibility_Check);
1222 begin
1223 X := Position.Node.Element;
1224 Position.Node.Element := new Element_Type'(New_Item);
1225 Free_Element (X);
1226 end;
1227 end if;
1228 end Include;
1230 ------------
1231 -- Insert --
1232 ------------
1234 procedure Insert
1235 (Container : in out Set;
1236 New_Item : Element_Type;
1237 Position : out Cursor;
1238 Inserted : out Boolean)
1240 begin
1241 Insert_Sans_Hint
1242 (Container.Tree,
1243 New_Item,
1244 Position.Node,
1245 Inserted);
1247 Position.Container := Container'Unrestricted_Access;
1248 end Insert;
1250 procedure Insert (Container : in out Set; New_Item : Element_Type) is
1251 Position : Cursor;
1252 pragma Unreferenced (Position);
1254 Inserted : Boolean;
1256 begin
1257 Insert (Container, New_Item, Position, Inserted);
1259 if not Inserted then
1260 raise Constraint_Error with
1261 "attempt to insert element already in set";
1262 end if;
1263 end Insert;
1265 ----------------------
1266 -- Insert_Sans_Hint --
1267 ----------------------
1269 procedure Insert_Sans_Hint
1270 (Tree : in out Tree_Type;
1271 New_Item : Element_Type;
1272 Node : out Node_Access;
1273 Inserted : out Boolean)
1275 function New_Node return Node_Access;
1276 pragma Inline (New_Node);
1278 procedure Insert_Post is
1279 new Element_Keys.Generic_Insert_Post (New_Node);
1281 procedure Conditional_Insert_Sans_Hint is
1282 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1284 --------------
1285 -- New_Node --
1286 --------------
1288 function New_Node return Node_Access is
1289 -- The element allocator may need an accessibility check in the case
1290 -- the actual type is class-wide or has access discriminants (see
1291 -- RM 4.8(10.1) and AI12-0035).
1293 pragma Unsuppress (Accessibility_Check);
1295 Element : Element_Access := new Element_Type'(New_Item);
1297 begin
1298 return new Node_Type'(Parent => null,
1299 Left => null,
1300 Right => null,
1301 Color => Red_Black_Trees.Red,
1302 Element => Element);
1304 exception
1305 when others =>
1306 Free_Element (Element);
1307 raise;
1308 end New_Node;
1310 -- Start of processing for Insert_Sans_Hint
1312 begin
1313 Conditional_Insert_Sans_Hint
1314 (Tree,
1315 New_Item,
1316 Node,
1317 Inserted);
1318 end Insert_Sans_Hint;
1320 ----------------------
1321 -- Insert_With_Hint --
1322 ----------------------
1324 procedure Insert_With_Hint
1325 (Dst_Tree : in out Tree_Type;
1326 Dst_Hint : Node_Access;
1327 Src_Node : Node_Access;
1328 Dst_Node : out Node_Access)
1330 Success : Boolean;
1331 pragma Unreferenced (Success);
1333 function New_Node return Node_Access;
1335 procedure Insert_Post is
1336 new Element_Keys.Generic_Insert_Post (New_Node);
1338 procedure Insert_Sans_Hint is
1339 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
1341 procedure Insert_With_Hint is
1342 new Element_Keys.Generic_Conditional_Insert_With_Hint
1343 (Insert_Post,
1344 Insert_Sans_Hint);
1346 --------------
1347 -- New_Node --
1348 --------------
1350 function New_Node return Node_Access is
1351 Element : Element_Access := new Element_Type'(Src_Node.Element.all);
1352 Node : Node_Access;
1354 begin
1355 begin
1356 Node := new Node_Type;
1357 exception
1358 when others =>
1359 Free_Element (Element);
1360 raise;
1361 end;
1363 Node.Element := Element;
1364 return Node;
1365 end New_Node;
1367 -- Start of processing for Insert_With_Hint
1369 begin
1370 Insert_With_Hint
1371 (Dst_Tree,
1372 Dst_Hint,
1373 Src_Node.Element.all,
1374 Dst_Node,
1375 Success);
1376 end Insert_With_Hint;
1378 ------------------
1379 -- Intersection --
1380 ------------------
1382 procedure Intersection (Target : in out Set; Source : Set) is
1383 begin
1384 Set_Ops.Intersection (Target.Tree, Source.Tree);
1385 end Intersection;
1387 function Intersection (Left, Right : Set) return Set is
1388 Tree : constant Tree_Type :=
1389 Set_Ops.Intersection (Left.Tree, Right.Tree);
1390 begin
1391 return Set'(Controlled with Tree);
1392 end Intersection;
1394 --------------
1395 -- Is_Empty --
1396 --------------
1398 function Is_Empty (Container : Set) return Boolean is
1399 begin
1400 return Container.Tree.Length = 0;
1401 end Is_Empty;
1403 -----------------------------
1404 -- Is_Greater_Element_Node --
1405 -----------------------------
1407 function Is_Greater_Element_Node
1408 (Left : Element_Type;
1409 Right : Node_Access) return Boolean
1411 begin
1412 -- e > node same as node < e
1414 return Right.Element.all < Left;
1415 end Is_Greater_Element_Node;
1417 --------------------------
1418 -- Is_Less_Element_Node --
1419 --------------------------
1421 function Is_Less_Element_Node
1422 (Left : Element_Type;
1423 Right : Node_Access) return Boolean
1425 begin
1426 return Left < Right.Element.all;
1427 end Is_Less_Element_Node;
1429 -----------------------
1430 -- Is_Less_Node_Node --
1431 -----------------------
1433 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is
1434 begin
1435 return L.Element.all < R.Element.all;
1436 end Is_Less_Node_Node;
1438 ---------------
1439 -- Is_Subset --
1440 ---------------
1442 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
1443 begin
1444 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree);
1445 end Is_Subset;
1447 -------------
1448 -- Iterate --
1449 -------------
1451 procedure Iterate
1452 (Container : Set;
1453 Process : not null access procedure (Position : Cursor))
1455 procedure Process_Node (Node : Node_Access);
1456 pragma Inline (Process_Node);
1458 procedure Local_Iterate is
1459 new Tree_Operations.Generic_Iteration (Process_Node);
1461 ------------------
1462 -- Process_Node --
1463 ------------------
1465 procedure Process_Node (Node : Node_Access) is
1466 begin
1467 Process (Cursor'(Container'Unrestricted_Access, Node));
1468 end Process_Node;
1470 T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
1471 B : Natural renames T.Busy;
1473 -- Start of processing for Iterate
1475 begin
1476 B := B + 1;
1478 begin
1479 Local_Iterate (T);
1480 exception
1481 when others =>
1482 B := B - 1;
1483 raise;
1484 end;
1486 B := B - 1;
1487 end Iterate;
1489 function Iterate
1490 (Container : Set)
1491 return Set_Iterator_Interfaces.Reversible_Iterator'class
1493 B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1495 begin
1496 -- The value of the Node component influences the behavior of the First
1497 -- and Last selector functions of the iterator object. When the Node
1498 -- component is null (as is the case here), this means the iterator
1499 -- object was constructed without a start expression. This is a complete
1500 -- iterator, meaning that the iteration starts from the (logical)
1501 -- beginning of the sequence of items.
1503 -- Note: For a forward iterator, Container.First is the beginning, and
1504 -- for a reverse iterator, Container.Last is the beginning.
1506 return It : constant Iterator :=
1507 Iterator'(Limited_Controlled with
1508 Container => Container'Unrestricted_Access,
1509 Node => null)
1511 B := B + 1;
1512 end return;
1513 end Iterate;
1515 function Iterate
1516 (Container : Set;
1517 Start : Cursor)
1518 return Set_Iterator_Interfaces.Reversible_Iterator'class
1520 B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
1522 begin
1523 -- It was formerly the case that when Start = No_Element, the partial
1524 -- iterator was defined to behave the same as for a complete iterator,
1525 -- and iterate over the entire sequence of items. However, those
1526 -- semantics were unintuitive and arguably error-prone (it is too easy
1527 -- to accidentally create an endless loop), and so they were changed,
1528 -- per the ARG meeting in Denver on 2011/11. However, there was no
1529 -- consensus about what positive meaning this corner case should have,
1530 -- and so it was decided to simply raise an exception. This does imply,
1531 -- however, that it is not possible to use a partial iterator to specify
1532 -- an empty sequence of items.
1534 if Start = No_Element then
1535 raise Constraint_Error with
1536 "Start position for iterator equals No_Element";
1537 end if;
1539 if Start.Container /= Container'Unrestricted_Access then
1540 raise Program_Error with
1541 "Start cursor of Iterate designates wrong set";
1542 end if;
1544 pragma Assert (Vet (Container.Tree, Start.Node),
1545 "Start cursor of Iterate is bad");
1547 -- The value of the Node component influences the behavior of the First
1548 -- and Last selector functions of the iterator object. When the Node
1549 -- component is non-null (as is the case here), it means that this is a
1550 -- partial iteration, over a subset of the complete sequence of
1551 -- items. The iterator object was constructed with a start expression,
1552 -- indicating the position from which the iteration begins. Note that
1553 -- the start position has the same value irrespective of whether this is
1554 -- a forward or reverse iteration.
1556 return It : constant Iterator :=
1557 (Limited_Controlled with
1558 Container => Container'Unrestricted_Access,
1559 Node => Start.Node)
1561 B := B + 1;
1562 end return;
1563 end Iterate;
1565 ----------
1566 -- Last --
1567 ----------
1569 function Last (Container : Set) return Cursor is
1570 begin
1571 return
1572 (if Container.Tree.Last = null then No_Element
1573 else Cursor'(Container'Unrestricted_Access, Container.Tree.Last));
1574 end Last;
1576 function Last (Object : Iterator) return Cursor is
1577 begin
1578 -- The value of the iterator object's Node component influences the
1579 -- behavior of the Last (and First) selector function.
1581 -- When the Node component is null, this means the iterator object was
1582 -- constructed without a start expression, in which case the (reverse)
1583 -- iteration starts from the (logical) beginning of the entire sequence
1584 -- (corresponding to Container.Last, for a reverse iterator).
1586 -- Otherwise, this is iteration over a partial sequence of items. When
1587 -- the Node component is non-null, the iterator object was constructed
1588 -- with a start expression, that specifies the position from which the
1589 -- (reverse) partial iteration begins.
1591 if Object.Node = null then
1592 return Object.Container.Last;
1593 else
1594 return Cursor'(Object.Container, Object.Node);
1595 end if;
1596 end Last;
1598 ------------------
1599 -- Last_Element --
1600 ------------------
1602 function Last_Element (Container : Set) return Element_Type is
1603 begin
1604 if Container.Tree.Last = null then
1605 raise Constraint_Error with "set is empty";
1606 else
1607 return Container.Tree.Last.Element.all;
1608 end if;
1609 end Last_Element;
1611 ----------
1612 -- Left --
1613 ----------
1615 function Left (Node : Node_Access) return Node_Access is
1616 begin
1617 return Node.Left;
1618 end Left;
1620 ------------
1621 -- Length --
1622 ------------
1624 function Length (Container : Set) return Count_Type is
1625 begin
1626 return Container.Tree.Length;
1627 end Length;
1629 ----------
1630 -- Move --
1631 ----------
1633 procedure Move is new Tree_Operations.Generic_Move (Clear);
1635 procedure Move (Target : in out Set; Source : in out Set) is
1636 begin
1637 Move (Target => Target.Tree, Source => Source.Tree);
1638 end Move;
1640 ----------
1641 -- Next --
1642 ----------
1644 procedure Next (Position : in out Cursor) is
1645 begin
1646 Position := Next (Position);
1647 end Next;
1649 function Next (Position : Cursor) return Cursor is
1650 begin
1651 if Position = No_Element then
1652 return No_Element;
1653 end if;
1655 if Position.Node.Element = null then
1656 raise Program_Error with "Position cursor is bad";
1657 end if;
1659 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1660 "bad cursor in Next");
1662 declare
1663 Node : constant Node_Access := Tree_Operations.Next (Position.Node);
1664 begin
1665 return (if Node = null then No_Element
1666 else Cursor'(Position.Container, Node));
1667 end;
1668 end Next;
1670 function Next
1671 (Object : Iterator;
1672 Position : Cursor) return Cursor
1674 begin
1675 if Position.Container = null then
1676 return No_Element;
1677 end if;
1679 if Position.Container /= Object.Container then
1680 raise Program_Error with
1681 "Position cursor of Next designates wrong set";
1682 end if;
1684 return Next (Position);
1685 end Next;
1687 -------------
1688 -- Overlap --
1689 -------------
1691 function Overlap (Left, Right : Set) return Boolean is
1692 begin
1693 return Set_Ops.Overlap (Left.Tree, Right.Tree);
1694 end Overlap;
1696 ------------
1697 -- Parent --
1698 ------------
1700 function Parent (Node : Node_Access) return Node_Access is
1701 begin
1702 return Node.Parent;
1703 end Parent;
1705 --------------
1706 -- Previous --
1707 --------------
1709 procedure Previous (Position : in out Cursor) is
1710 begin
1711 Position := Previous (Position);
1712 end Previous;
1714 function Previous (Position : Cursor) return Cursor is
1715 begin
1716 if Position = No_Element then
1717 return No_Element;
1718 end if;
1720 if Position.Node.Element = null then
1721 raise Program_Error with "Position cursor is bad";
1722 end if;
1724 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1725 "bad cursor in Previous");
1727 declare
1728 Node : constant Node_Access :=
1729 Tree_Operations.Previous (Position.Node);
1730 begin
1731 return (if Node = null then No_Element
1732 else Cursor'(Position.Container, Node));
1733 end;
1734 end Previous;
1736 function Previous
1737 (Object : Iterator;
1738 Position : Cursor) return Cursor
1740 begin
1741 if Position.Container = null then
1742 return No_Element;
1743 end if;
1745 if Position.Container /= Object.Container then
1746 raise Program_Error with
1747 "Position cursor of Previous designates wrong set";
1748 end if;
1750 return Previous (Position);
1751 end Previous;
1753 -------------------
1754 -- Query_Element --
1755 -------------------
1757 procedure Query_Element
1758 (Position : Cursor;
1759 Process : not null access procedure (Element : Element_Type))
1761 begin
1762 if Position.Node = null then
1763 raise Constraint_Error with "Position cursor equals No_Element";
1764 end if;
1766 if Position.Node.Element = null then
1767 raise Program_Error with "Position cursor is bad";
1768 end if;
1770 pragma Assert (Vet (Position.Container.Tree, Position.Node),
1771 "bad cursor in Query_Element");
1773 declare
1774 T : Tree_Type renames Position.Container.Tree;
1776 B : Natural renames T.Busy;
1777 L : Natural renames T.Lock;
1779 begin
1780 B := B + 1;
1781 L := L + 1;
1783 begin
1784 Process (Position.Node.Element.all);
1785 exception
1786 when others =>
1787 L := L - 1;
1788 B := B - 1;
1789 raise;
1790 end;
1792 L := L - 1;
1793 B := B - 1;
1794 end;
1795 end Query_Element;
1797 ----------
1798 -- Read --
1799 ----------
1801 procedure Read
1802 (Stream : not null access Root_Stream_Type'Class;
1803 Container : out Set)
1805 function Read_Node
1806 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
1807 pragma Inline (Read_Node);
1809 procedure Read is
1810 new Tree_Operations.Generic_Read (Clear, Read_Node);
1812 ---------------
1813 -- Read_Node --
1814 ---------------
1816 function Read_Node
1817 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1819 Node : Node_Access := new Node_Type;
1821 begin
1822 Node.Element := new Element_Type'(Element_Type'Input (Stream));
1823 return Node;
1825 exception
1826 when others =>
1827 Free (Node); -- Note that Free deallocates elem too
1828 raise;
1829 end Read_Node;
1831 -- Start of processing for Read
1833 begin
1834 Read (Stream, Container.Tree);
1835 end Read;
1837 procedure Read
1838 (Stream : not null access Root_Stream_Type'Class;
1839 Item : out Cursor)
1841 begin
1842 raise Program_Error with "attempt to stream set cursor";
1843 end Read;
1845 procedure Read
1846 (Stream : not null access Root_Stream_Type'Class;
1847 Item : out Constant_Reference_Type)
1849 begin
1850 raise Program_Error with "attempt to stream reference";
1851 end Read;
1853 -------------
1854 -- Replace --
1855 -------------
1857 procedure Replace (Container : in out Set; New_Item : Element_Type) is
1858 Node : constant Node_Access :=
1859 Element_Keys.Find (Container.Tree, New_Item);
1861 X : Element_Access;
1862 pragma Warnings (Off, X);
1864 begin
1865 if Node = null then
1866 raise Constraint_Error with "attempt to replace element not in set";
1867 end if;
1869 if Container.Tree.Lock > 0 then
1870 raise Program_Error with
1871 "attempt to tamper with elements (set is locked)";
1872 end if;
1874 declare
1875 -- The element allocator may need an accessibility check in the case
1876 -- the actual type is class-wide or has access discriminants (see
1877 -- RM 4.8(10.1) and AI12-0035).
1879 pragma Unsuppress (Accessibility_Check);
1881 begin
1882 X := Node.Element;
1883 Node.Element := new Element_Type'(New_Item);
1884 Free_Element (X);
1885 end;
1886 end Replace;
1888 ---------------------
1889 -- Replace_Element --
1890 ---------------------
1892 procedure Replace_Element
1893 (Tree : in out Tree_Type;
1894 Node : Node_Access;
1895 Item : Element_Type)
1897 pragma Assert (Node /= null);
1898 pragma Assert (Node.Element /= null);
1900 function New_Node return Node_Access;
1901 pragma Inline (New_Node);
1903 procedure Local_Insert_Post is
1904 new Element_Keys.Generic_Insert_Post (New_Node);
1906 procedure Local_Insert_Sans_Hint is
1907 new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
1909 procedure Local_Insert_With_Hint is
1910 new Element_Keys.Generic_Conditional_Insert_With_Hint
1911 (Local_Insert_Post,
1912 Local_Insert_Sans_Hint);
1914 --------------
1915 -- New_Node --
1916 --------------
1918 function New_Node return Node_Access is
1920 -- The element allocator may need an accessibility check in the case
1921 -- the actual type is class-wide or has access discriminants (see
1922 -- RM 4.8(10.1) and AI12-0035).
1924 pragma Unsuppress (Accessibility_Check);
1926 begin
1927 Node.Element := new Element_Type'(Item); -- OK if fails
1928 Node.Color := Red;
1929 Node.Parent := null;
1930 Node.Right := null;
1931 Node.Left := null;
1932 return Node;
1933 end New_Node;
1935 Hint : Node_Access;
1936 Result : Node_Access;
1937 Inserted : Boolean;
1938 Compare : Boolean;
1940 X : Element_Access := Node.Element;
1942 -- Per AI05-0022, the container implementation is required to detect
1943 -- element tampering by a generic actual subprogram.
1945 B : Natural renames Tree.Busy;
1946 L : Natural renames Tree.Lock;
1948 -- Start of processing for Replace_Element
1950 begin
1951 -- Replace_Element assigns value Item to the element designated by Node,
1952 -- per certain semantic constraints, described as follows.
1954 -- If Item is equivalent to the element, then element is replaced and
1955 -- there's nothing else to do. This is the easy case.
1957 -- If Item is not equivalent, then the node will (possibly) have to move
1958 -- to some other place in the tree. This is slighly more complicated,
1959 -- because we must ensure that Item is not equivalent to some other
1960 -- element in the tree (in which case, the replacement is not allowed).
1962 -- Determine whether Item is equivalent to element on the specified
1963 -- node.
1965 begin
1966 B := B + 1;
1967 L := L + 1;
1969 Compare := (if Item < Node.Element.all then False
1970 elsif Node.Element.all < Item then False
1971 else True);
1973 L := L - 1;
1974 B := B - 1;
1976 exception
1977 when others =>
1978 L := L - 1;
1979 B := B - 1;
1981 raise;
1982 end;
1984 if Compare then
1985 -- Item is equivalent to the node's element, so we will not have to
1986 -- move the node.
1988 if Tree.Lock > 0 then
1989 raise Program_Error with
1990 "attempt to tamper with elements (set is locked)";
1991 end if;
1993 declare
1994 -- The element allocator may need an accessibility check in the
1995 -- case the actual type is class-wide or has access discriminants
1996 -- (see RM 4.8(10.1) and AI12-0035).
1998 pragma Unsuppress (Accessibility_Check);
2000 begin
2001 Node.Element := new Element_Type'(Item);
2002 Free_Element (X);
2003 end;
2005 return;
2006 end if;
2008 -- The replacement Item is not equivalent to the element on the
2009 -- specified node, which means that it will need to be re-inserted in a
2010 -- different position in the tree. We must now determine whether Item is
2011 -- equivalent to some other element in the tree (which would prohibit
2012 -- the assignment and hence the move).
2014 -- Ceiling returns the smallest element equivalent or greater than the
2015 -- specified Item; if there is no such element, then it returns null.
2017 Hint := Element_Keys.Ceiling (Tree, Item);
2019 if Hint /= null then
2020 begin
2021 B := B + 1;
2022 L := L + 1;
2024 Compare := Item < Hint.Element.all;
2026 L := L - 1;
2027 B := B - 1;
2029 exception
2030 when others =>
2031 L := L - 1;
2032 B := B - 1;
2034 raise;
2035 end;
2037 -- Item >= Hint.Element
2039 if not Compare then
2041 -- Ceiling returns an element that is equivalent or greater
2042 -- than Item. If Item is "not less than" the element, then
2043 -- by elimination we know that Item is equivalent to the element.
2045 -- But this means that it is not possible to assign the value of
2046 -- Item to the specified element (on Node), because a different
2047 -- element (on Hint) equivalent to Item already exsits. (Were we
2048 -- to change Node's element value, we would have to move Node, but
2049 -- we would be unable to move the Node, because its new position
2050 -- in the tree is already occupied by an equivalent element.)
2052 raise Program_Error with "attempt to replace existing element";
2053 end if;
2055 -- Item is not equivalent to any other element in the tree, so it is
2056 -- safe to assign the value of Item to Node.Element. This means that
2057 -- the node will have to move to a different position in the tree
2058 -- (because its element will have a different value).
2060 -- The nearest (greater) neighbor of Item is Hint. This will be the
2061 -- insertion position of Node (because its element will have Item as
2062 -- its new value).
2064 -- If Node equals Hint, the relative position of Node does not
2065 -- change. This allows us to perform an optimization: we need not
2066 -- remove Node from the tree and then reinsert it with its new value,
2067 -- because it would only be placed in the exact same position.
2069 if Hint = Node then
2070 if Tree.Lock > 0 then
2071 raise Program_Error with
2072 "attempt to tamper with elements (set is locked)";
2073 end if;
2075 declare
2076 -- The element allocator may need an accessibility check in the
2077 -- case actual type is class-wide or has access discriminants
2078 -- (see RM 4.8(10.1) and AI12-0035).
2080 pragma Unsuppress (Accessibility_Check);
2082 begin
2083 Node.Element := new Element_Type'(Item);
2084 Free_Element (X);
2085 end;
2087 return;
2088 end if;
2089 end if;
2091 -- If we get here, it is because Item was greater than all elements in
2092 -- the tree (Hint = null), or because Item was less than some element at
2093 -- a different place in the tree (Item < Hint.Element.all). In either
2094 -- case, we remove Node from the tree (without actually deallocating
2095 -- it), and then insert Item into the tree, onto the same Node (so no
2096 -- new node is actually allocated).
2098 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
2100 Local_Insert_With_Hint
2101 (Tree => Tree,
2102 Position => Hint,
2103 Key => Item,
2104 Node => Result,
2105 Inserted => Inserted);
2107 pragma Assert (Inserted);
2108 pragma Assert (Result = Node);
2110 Free_Element (X);
2111 end Replace_Element;
2113 procedure Replace_Element
2114 (Container : in out Set;
2115 Position : Cursor;
2116 New_Item : Element_Type)
2118 begin
2119 if Position.Node = null then
2120 raise Constraint_Error with "Position cursor equals No_Element";
2121 end if;
2123 if Position.Node.Element = null then
2124 raise Program_Error with "Position cursor is bad";
2125 end if;
2127 if Position.Container /= Container'Unrestricted_Access then
2128 raise Program_Error with "Position cursor designates wrong set";
2129 end if;
2131 pragma Assert (Vet (Container.Tree, Position.Node),
2132 "bad cursor in Replace_Element");
2134 Replace_Element (Container.Tree, Position.Node, New_Item);
2135 end Replace_Element;
2137 ---------------------
2138 -- Reverse_Iterate --
2139 ---------------------
2141 procedure Reverse_Iterate
2142 (Container : Set;
2143 Process : not null access procedure (Position : Cursor))
2145 procedure Process_Node (Node : Node_Access);
2146 pragma Inline (Process_Node);
2148 procedure Local_Reverse_Iterate is
2149 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
2151 ------------------
2152 -- Process_Node --
2153 ------------------
2155 procedure Process_Node (Node : Node_Access) is
2156 begin
2157 Process (Cursor'(Container'Unrestricted_Access, Node));
2158 end Process_Node;
2160 T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
2161 B : Natural renames T.Busy;
2163 -- Start of processing for Reverse_Iterate
2165 begin
2166 B := B + 1;
2168 begin
2169 Local_Reverse_Iterate (T);
2170 exception
2171 when others =>
2172 B := B - 1;
2173 raise;
2174 end;
2176 B := B - 1;
2177 end Reverse_Iterate;
2179 -----------
2180 -- Right --
2181 -----------
2183 function Right (Node : Node_Access) return Node_Access is
2184 begin
2185 return Node.Right;
2186 end Right;
2188 ---------------
2189 -- Set_Color --
2190 ---------------
2192 procedure Set_Color (Node : Node_Access; Color : Color_Type) is
2193 begin
2194 Node.Color := Color;
2195 end Set_Color;
2197 --------------
2198 -- Set_Left --
2199 --------------
2201 procedure Set_Left (Node : Node_Access; Left : Node_Access) is
2202 begin
2203 Node.Left := Left;
2204 end Set_Left;
2206 ----------------
2207 -- Set_Parent --
2208 ----------------
2210 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is
2211 begin
2212 Node.Parent := Parent;
2213 end Set_Parent;
2215 ---------------
2216 -- Set_Right --
2217 ---------------
2219 procedure Set_Right (Node : Node_Access; Right : Node_Access) is
2220 begin
2221 Node.Right := Right;
2222 end Set_Right;
2224 --------------------------
2225 -- Symmetric_Difference --
2226 --------------------------
2228 procedure Symmetric_Difference (Target : in out Set; Source : Set) is
2229 begin
2230 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree);
2231 end Symmetric_Difference;
2233 function Symmetric_Difference (Left, Right : Set) return Set is
2234 Tree : constant Tree_Type :=
2235 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree);
2236 begin
2237 return Set'(Controlled with Tree);
2238 end Symmetric_Difference;
2240 ------------
2241 -- To_Set --
2242 ------------
2244 function To_Set (New_Item : Element_Type) return Set is
2245 Tree : Tree_Type;
2246 Node : Node_Access;
2247 Inserted : Boolean;
2248 pragma Unreferenced (Node, Inserted);
2249 begin
2250 Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
2251 return Set'(Controlled with Tree);
2252 end To_Set;
2254 -----------
2255 -- Union --
2256 -----------
2258 procedure Union (Target : in out Set; Source : Set) is
2259 begin
2260 Set_Ops.Union (Target.Tree, Source.Tree);
2261 end Union;
2263 function Union (Left, Right : Set) return Set is
2264 Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree);
2265 begin
2266 return Set'(Controlled with Tree);
2267 end Union;
2269 -----------
2270 -- Write --
2271 -----------
2273 procedure Write
2274 (Stream : not null access Root_Stream_Type'Class;
2275 Container : Set)
2277 procedure Write_Node
2278 (Stream : not null access Root_Stream_Type'Class;
2279 Node : Node_Access);
2280 pragma Inline (Write_Node);
2282 procedure Write is
2283 new Tree_Operations.Generic_Write (Write_Node);
2285 ----------------
2286 -- Write_Node --
2287 ----------------
2289 procedure Write_Node
2290 (Stream : not null access Root_Stream_Type'Class;
2291 Node : Node_Access)
2293 begin
2294 Element_Type'Output (Stream, Node.Element.all);
2295 end Write_Node;
2297 -- Start of processing for Write
2299 begin
2300 Write (Stream, Container.Tree);
2301 end Write;
2303 procedure Write
2304 (Stream : not null access Root_Stream_Type'Class;
2305 Item : Cursor)
2307 begin
2308 raise Program_Error with "attempt to stream set cursor";
2309 end Write;
2311 procedure Write
2312 (Stream : not null access Root_Stream_Type'Class;
2313 Item : Constant_Reference_Type)
2315 begin
2316 raise Program_Error with "attempt to stream reference";
2317 end Write;
2319 end Ada.Containers.Indefinite_Ordered_Sets;