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