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-2019, 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 if Checks 484 and then (Left (Position.Node) = Position.Node 485 or else 486 Right (Position.Node) = Position.Node) 487 then 488 raise Program_Error with "dangling cursor"; 489 end if; 490 491 pragma Assert (Vet (Position.Container.Tree, Position.Node), 492 "bad cursor in Element"); 493 494 return Position.Node.Element; 495 end Element; 496 497 ------------------------- 498 -- Equivalent_Elements -- 499 ------------------------- 500 501 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is 502 begin 503 return (if Left < Right or else Right < Left then False else True); 504 end Equivalent_Elements; 505 506 --------------------- 507 -- Equivalent_Sets -- 508 --------------------- 509 510 function Equivalent_Sets (Left, Right : Set) return Boolean is 511 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; 512 pragma Inline (Is_Equivalent_Node_Node); 513 514 function Is_Equivalent is 515 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); 516 517 ----------------------------- 518 -- Is_Equivalent_Node_Node -- 519 ----------------------------- 520 521 function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is 522 begin 523 return (if L.Element < R.Element then False 524 elsif R.Element < L.Element then False 525 else True); 526 end Is_Equivalent_Node_Node; 527 528 -- Start of processing for Equivalent_Sets 529 530 begin 531 return Is_Equivalent (Left.Tree, Right.Tree); 532 end Equivalent_Sets; 533 534 ------------- 535 -- Exclude -- 536 ------------- 537 538 procedure Exclude (Container : in out Set; Item : Element_Type) is 539 X : Node_Access := Element_Keys.Find (Container.Tree, Item); 540 541 begin 542 if X /= null then 543 Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); 544 Free (X); 545 end if; 546 end Exclude; 547 548 -------------- 549 -- Finalize -- 550 -------------- 551 552 procedure Finalize (Object : in out Iterator) is 553 begin 554 if Object.Container /= null then 555 Unbusy (Object.Container.Tree.TC); 556 end if; 557 end Finalize; 558 559 ---------- 560 -- Find -- 561 ---------- 562 563 function Find (Container : Set; Item : Element_Type) return Cursor is 564 Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item); 565 begin 566 return (if Node = null then No_Element 567 else Cursor'(Container'Unrestricted_Access, Node)); 568 end Find; 569 570 ----------- 571 -- First -- 572 ----------- 573 574 function First (Container : Set) return Cursor is 575 begin 576 return 577 (if Container.Tree.First = null then No_Element 578 else Cursor'(Container'Unrestricted_Access, Container.Tree.First)); 579 end First; 580 581 function First (Object : Iterator) return Cursor is 582 begin 583 -- The value of the iterator object's Node component influences the 584 -- behavior of the First (and Last) selector function. 585 586 -- When the Node component is null, this means the iterator object was 587 -- constructed without a start expression, in which case the (forward) 588 -- iteration starts from the (logical) beginning of the entire sequence 589 -- of items (corresponding to Container.First, for a forward iterator). 590 591 -- Otherwise, this is iteration over a partial sequence of items. When 592 -- the Node component is non-null, the iterator object was constructed 593 -- with a start expression, that specifies the position from which the 594 -- (forward) partial iteration begins. 595 596 if Object.Node = null then 597 return Object.Container.First; 598 else 599 return Cursor'(Object.Container, Object.Node); 600 end if; 601 end First; 602 603 ------------------- 604 -- First_Element -- 605 ------------------- 606 607 function First_Element (Container : Set) return Element_Type is 608 begin 609 if Checks and then Container.Tree.First = null then 610 raise Constraint_Error with "set is empty"; 611 end if; 612 613 return Container.Tree.First.Element; 614 end First_Element; 615 616 ----------- 617 -- Floor -- 618 ----------- 619 620 function Floor (Container : Set; Item : Element_Type) return Cursor is 621 Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item); 622 begin 623 return (if Node = null then No_Element 624 else Cursor'(Container'Unrestricted_Access, Node)); 625 end Floor; 626 627 ---------- 628 -- Free -- 629 ---------- 630 631 procedure Free (X : in out Node_Access) is 632 procedure Deallocate is 633 new Ada.Unchecked_Deallocation (Node_Type, Node_Access); 634 begin 635 if X /= null then 636 X.Parent := X; 637 X.Left := X; 638 X.Right := X; 639 Deallocate (X); 640 end if; 641 end Free; 642 643 ------------------ 644 -- Generic_Keys -- 645 ------------------ 646 647 package body Generic_Keys is 648 649 ----------------------- 650 -- Local Subprograms -- 651 ----------------------- 652 653 function Is_Greater_Key_Node 654 (Left : Key_Type; 655 Right : Node_Access) return Boolean; 656 pragma Inline (Is_Greater_Key_Node); 657 658 function Is_Less_Key_Node 659 (Left : Key_Type; 660 Right : Node_Access) return Boolean; 661 pragma Inline (Is_Less_Key_Node); 662 663 -------------------------- 664 -- Local Instantiations -- 665 -------------------------- 666 667 package Key_Keys is 668 new Red_Black_Trees.Generic_Keys 669 (Tree_Operations => Tree_Operations, 670 Key_Type => Key_Type, 671 Is_Less_Key_Node => Is_Less_Key_Node, 672 Is_Greater_Key_Node => Is_Greater_Key_Node); 673 674 ------------- 675 -- Ceiling -- 676 ------------- 677 678 function Ceiling (Container : Set; Key : Key_Type) return Cursor is 679 Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key); 680 begin 681 return (if Node = null then No_Element 682 else Cursor'(Container'Unrestricted_Access, Node)); 683 end Ceiling; 684 685 ------------------------ 686 -- Constant_Reference -- 687 ------------------------ 688 689 function Constant_Reference 690 (Container : aliased Set; 691 Key : Key_Type) return Constant_Reference_Type 692 is 693 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); 694 695 begin 696 if Checks and then Node = null then 697 raise Constraint_Error with "key not in set"; 698 end if; 699 700 declare 701 Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree; 702 TC : constant Tamper_Counts_Access := 703 Tree.TC'Unrestricted_Access; 704 begin 705 return R : constant Constant_Reference_Type := 706 (Element => Node.Element'Access, 707 Control => (Controlled with TC)) 708 do 709 Lock (TC.all); 710 end return; 711 end; 712 end Constant_Reference; 713 714 -------------- 715 -- Contains -- 716 -------------- 717 718 function Contains (Container : Set; Key : Key_Type) return Boolean is 719 begin 720 return Find (Container, Key) /= No_Element; 721 end Contains; 722 723 ------------ 724 -- Delete -- 725 ------------ 726 727 procedure Delete (Container : in out Set; Key : Key_Type) is 728 X : Node_Access := Key_Keys.Find (Container.Tree, Key); 729 730 begin 731 if Checks and then X = null then 732 raise Constraint_Error with "attempt to delete key not in set"; 733 end if; 734 735 Delete_Node_Sans_Free (Container.Tree, X); 736 Free (X); 737 end Delete; 738 739 ------------- 740 -- Element -- 741 ------------- 742 743 function Element (Container : Set; Key : Key_Type) return Element_Type is 744 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); 745 746 begin 747 if Checks and then Node = null then 748 raise Constraint_Error with "key not in set"; 749 end if; 750 751 return Node.Element; 752 end Element; 753 754 --------------------- 755 -- Equivalent_Keys -- 756 --------------------- 757 758 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is 759 begin 760 return (if Left < Right or else Right < Left then False else True); 761 end Equivalent_Keys; 762 763 ------------- 764 -- Exclude -- 765 ------------- 766 767 procedure Exclude (Container : in out Set; Key : Key_Type) is 768 X : Node_Access := Key_Keys.Find (Container.Tree, Key); 769 begin 770 if X /= null then 771 Delete_Node_Sans_Free (Container.Tree, X); 772 Free (X); 773 end if; 774 end Exclude; 775 776 -------------- 777 -- Finalize -- 778 -------------- 779 780 procedure Finalize (Control : in out Reference_Control_Type) is 781 begin 782 if Control.Container /= null then 783 Impl.Reference_Control_Type (Control).Finalize; 784 785 if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) 786 then 787 Delete (Control.Container.all, Key (Control.Pos)); 788 raise Program_Error; 789 end if; 790 791 Control.Container := null; 792 Control.Old_Key := null; 793 end if; 794 end Finalize; 795 796 ---------- 797 -- Find -- 798 ---------- 799 800 function Find (Container : Set; Key : Key_Type) return Cursor is 801 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); 802 begin 803 return (if Node = null then No_Element 804 else Cursor'(Container'Unrestricted_Access, Node)); 805 end Find; 806 807 ----------- 808 -- Floor -- 809 ----------- 810 811 function Floor (Container : Set; Key : Key_Type) return Cursor is 812 Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); 813 begin 814 return (if Node = null then No_Element 815 else Cursor'(Container'Unrestricted_Access, Node)); 816 end Floor; 817 818 ------------------------- 819 -- Is_Greater_Key_Node -- 820 ------------------------- 821 822 function Is_Greater_Key_Node 823 (Left : Key_Type; 824 Right : Node_Access) return Boolean 825 is 826 begin 827 return Key (Right.Element) < Left; 828 end Is_Greater_Key_Node; 829 830 ---------------------- 831 -- Is_Less_Key_Node -- 832 ---------------------- 833 834 function Is_Less_Key_Node 835 (Left : Key_Type; 836 Right : Node_Access) return Boolean 837 is 838 begin 839 return Left < Key (Right.Element); 840 end Is_Less_Key_Node; 841 842 --------- 843 -- Key -- 844 --------- 845 846 function Key (Position : Cursor) return Key_Type is 847 begin 848 if Checks and then Position.Node = null then 849 raise Constraint_Error with 850 "Position cursor equals No_Element"; 851 end if; 852 853 pragma Assert (Vet (Position.Container.Tree, Position.Node), 854 "bad cursor in Key"); 855 856 return Key (Position.Node.Element); 857 end Key; 858 859 ---------- 860 -- Read -- 861 ---------- 862 863 procedure Read 864 (Stream : not null access Root_Stream_Type'Class; 865 Item : out Reference_Type) 866 is 867 begin 868 raise Program_Error with "attempt to stream reference"; 869 end Read; 870 871 ------------------------------ 872 -- Reference_Preserving_Key -- 873 ------------------------------ 874 875 function Reference_Preserving_Key 876 (Container : aliased in out Set; 877 Position : Cursor) return Reference_Type 878 is 879 begin 880 if Checks and then Position.Container = null then 881 raise Constraint_Error with "Position cursor has no element"; 882 end if; 883 884 if Checks and then Position.Container /= Container'Unrestricted_Access 885 then 886 raise Program_Error with 887 "Position cursor designates wrong container"; 888 end if; 889 890 pragma Assert 891 (Vet (Container.Tree, Position.Node), 892 "bad cursor in function Reference_Preserving_Key"); 893 894 declare 895 Tree : Tree_Type renames Container.Tree; 896 begin 897 return R : constant Reference_Type := 898 (Element => Position.Node.Element'Access, 899 Control => 900 (Controlled with 901 Tree.TC'Unrestricted_Access, 902 Container => Container'Access, 903 Pos => Position, 904 Old_Key => new Key_Type'(Key (Position)))) 905 do 906 Lock (Tree.TC); 907 end return; 908 end; 909 end Reference_Preserving_Key; 910 911 function Reference_Preserving_Key 912 (Container : aliased in out Set; 913 Key : Key_Type) return Reference_Type 914 is 915 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); 916 917 begin 918 if Checks and then Node = null then 919 raise Constraint_Error with "Key not in set"; 920 end if; 921 922 declare 923 Tree : Tree_Type renames Container.Tree; 924 begin 925 return R : constant Reference_Type := 926 (Element => Node.Element'Access, 927 Control => 928 (Controlled with 929 Tree.TC'Unrestricted_Access, 930 Container => Container'Access, 931 Pos => Find (Container, Key), 932 Old_Key => new Key_Type'(Key))) 933 do 934 Lock (Tree.TC); 935 end return; 936 end; 937 end Reference_Preserving_Key; 938 939 ------------- 940 -- Replace -- 941 ------------- 942 943 procedure Replace 944 (Container : in out Set; 945 Key : Key_Type; 946 New_Item : Element_Type) 947 is 948 Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); 949 950 begin 951 if Checks and then Node = null then 952 raise Constraint_Error with 953 "attempt to replace key not in set"; 954 end if; 955 956 Replace_Element (Container.Tree, Node, New_Item); 957 end Replace; 958 959 ----------------------------------- 960 -- Update_Element_Preserving_Key -- 961 ----------------------------------- 962 963 procedure Update_Element_Preserving_Key 964 (Container : in out Set; 965 Position : Cursor; 966 Process : not null access procedure (Element : in out Element_Type)) 967 is 968 Tree : Tree_Type renames Container.Tree; 969 970 begin 971 if Checks and then Position.Node = null then 972 raise Constraint_Error with 973 "Position cursor equals No_Element"; 974 end if; 975 976 if Checks and then Position.Container /= Container'Unrestricted_Access 977 then 978 raise Program_Error with 979 "Position cursor designates wrong set"; 980 end if; 981 982 pragma Assert (Vet (Container.Tree, Position.Node), 983 "bad cursor in Update_Element_Preserving_Key"); 984 985 declare 986 E : Element_Type renames Position.Node.Element; 987 K : constant Key_Type := Key (E); 988 Lock : With_Lock (Tree.TC'Unrestricted_Access); 989 begin 990 Process (E); 991 if Equivalent_Keys (K, Key (E)) then 992 return; 993 end if; 994 end; 995 996 declare 997 X : Node_Access := Position.Node; 998 begin 999 Tree_Operations.Delete_Node_Sans_Free (Tree, X); 1000 Free (X); 1001 end; 1002 1003 raise Program_Error with "key was modified"; 1004 end Update_Element_Preserving_Key; 1005 1006 ----------- 1007 -- Write -- 1008 ----------- 1009 1010 procedure Write 1011 (Stream : not null access Root_Stream_Type'Class; 1012 Item : Reference_Type) 1013 is 1014 begin 1015 raise Program_Error with "attempt to stream reference"; 1016 end Write; 1017 1018 end Generic_Keys; 1019 1020 ------------------------ 1021 -- Get_Element_Access -- 1022 ------------------------ 1023 1024 function Get_Element_Access 1025 (Position : Cursor) return not null Element_Access is 1026 begin 1027 return Position.Node.Element'Access; 1028 end Get_Element_Access; 1029 1030 ----------------- 1031 -- Has_Element -- 1032 ----------------- 1033 1034 function Has_Element (Position : Cursor) return Boolean is 1035 begin 1036 return Position /= No_Element; 1037 end Has_Element; 1038 1039 ------------- 1040 -- Include -- 1041 ------------- 1042 1043 procedure Include (Container : in out Set; New_Item : Element_Type) is 1044 Position : Cursor; 1045 Inserted : Boolean; 1046 1047 begin 1048 Insert (Container, New_Item, Position, Inserted); 1049 1050 if not Inserted then 1051 TE_Check (Container.Tree.TC); 1052 1053 Position.Node.Element := New_Item; 1054 end if; 1055 end Include; 1056 1057 ------------ 1058 -- Insert -- 1059 ------------ 1060 1061 procedure Insert 1062 (Container : in out Set; 1063 New_Item : Element_Type; 1064 Position : out Cursor; 1065 Inserted : out Boolean) 1066 is 1067 begin 1068 Insert_Sans_Hint 1069 (Container.Tree, 1070 New_Item, 1071 Position.Node, 1072 Inserted); 1073 1074 Position.Container := Container'Unrestricted_Access; 1075 end Insert; 1076 1077 procedure Insert 1078 (Container : in out Set; 1079 New_Item : Element_Type) 1080 is 1081 Position : Cursor; 1082 pragma Unreferenced (Position); 1083 1084 Inserted : Boolean; 1085 1086 begin 1087 Insert (Container, New_Item, Position, Inserted); 1088 1089 if Checks and then not Inserted then 1090 raise Constraint_Error with 1091 "attempt to insert element already in set"; 1092 end if; 1093 end Insert; 1094 1095 ---------------------- 1096 -- Insert_Sans_Hint -- 1097 ---------------------- 1098 1099 procedure Insert_Sans_Hint 1100 (Tree : in out Tree_Type; 1101 New_Item : Element_Type; 1102 Node : out Node_Access; 1103 Inserted : out Boolean) 1104 is 1105 function New_Node return Node_Access; 1106 pragma Inline (New_Node); 1107 1108 procedure Insert_Post is 1109 new Element_Keys.Generic_Insert_Post (New_Node); 1110 1111 procedure Conditional_Insert_Sans_Hint is 1112 new Element_Keys.Generic_Conditional_Insert (Insert_Post); 1113 1114 -------------- 1115 -- New_Node -- 1116 -------------- 1117 1118 function New_Node return Node_Access is 1119 begin 1120 return new Node_Type'(Parent => null, 1121 Left => null, 1122 Right => null, 1123 Color => Red_Black_Trees.Red, 1124 Element => New_Item); 1125 end New_Node; 1126 1127 -- Start of processing for Insert_Sans_Hint 1128 1129 begin 1130 Conditional_Insert_Sans_Hint 1131 (Tree, 1132 New_Item, 1133 Node, 1134 Inserted); 1135 end Insert_Sans_Hint; 1136 1137 ---------------------- 1138 -- Insert_With_Hint -- 1139 ---------------------- 1140 1141 procedure Insert_With_Hint 1142 (Dst_Tree : in out Tree_Type; 1143 Dst_Hint : Node_Access; 1144 Src_Node : Node_Access; 1145 Dst_Node : out Node_Access) 1146 is 1147 Success : Boolean; 1148 pragma Unreferenced (Success); 1149 1150 function New_Node return Node_Access; 1151 pragma Inline (New_Node); 1152 1153 procedure Insert_Post is 1154 new Element_Keys.Generic_Insert_Post (New_Node); 1155 1156 procedure Insert_Sans_Hint is 1157 new Element_Keys.Generic_Conditional_Insert (Insert_Post); 1158 1159 procedure Local_Insert_With_Hint is 1160 new Element_Keys.Generic_Conditional_Insert_With_Hint 1161 (Insert_Post, 1162 Insert_Sans_Hint); 1163 1164 -------------- 1165 -- New_Node -- 1166 -------------- 1167 1168 function New_Node return Node_Access is 1169 Node : constant Node_Access := 1170 new Node_Type'(Parent => null, 1171 Left => null, 1172 Right => null, 1173 Color => Red, 1174 Element => Src_Node.Element); 1175 begin 1176 return Node; 1177 end New_Node; 1178 1179 -- Start of processing for Insert_With_Hint 1180 1181 begin 1182 Local_Insert_With_Hint 1183 (Dst_Tree, 1184 Dst_Hint, 1185 Src_Node.Element, 1186 Dst_Node, 1187 Success); 1188 end Insert_With_Hint; 1189 1190 ------------------ 1191 -- Intersection -- 1192 ------------------ 1193 1194 procedure Intersection (Target : in out Set; Source : Set) is 1195 begin 1196 Set_Ops.Intersection (Target.Tree, Source.Tree); 1197 end Intersection; 1198 1199 function Intersection (Left, Right : Set) return Set is 1200 Tree : constant Tree_Type := 1201 Set_Ops.Intersection (Left.Tree, Right.Tree); 1202 begin 1203 return Set'(Controlled with Tree); 1204 end Intersection; 1205 1206 -------------- 1207 -- Is_Empty -- 1208 -------------- 1209 1210 function Is_Empty (Container : Set) return Boolean is 1211 begin 1212 return Container.Tree.Length = 0; 1213 end Is_Empty; 1214 1215 ------------------------ 1216 -- Is_Equal_Node_Node -- 1217 ------------------------ 1218 1219 function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is 1220 begin 1221 return L.Element = R.Element; 1222 end Is_Equal_Node_Node; 1223 1224 ----------------------------- 1225 -- Is_Greater_Element_Node -- 1226 ----------------------------- 1227 1228 function Is_Greater_Element_Node 1229 (Left : Element_Type; 1230 Right : Node_Access) return Boolean 1231 is 1232 begin 1233 -- Compute e > node same as node < e 1234 1235 return Right.Element < Left; 1236 end Is_Greater_Element_Node; 1237 1238 -------------------------- 1239 -- Is_Less_Element_Node -- 1240 -------------------------- 1241 1242 function Is_Less_Element_Node 1243 (Left : Element_Type; 1244 Right : Node_Access) return Boolean 1245 is 1246 begin 1247 return Left < Right.Element; 1248 end Is_Less_Element_Node; 1249 1250 ----------------------- 1251 -- Is_Less_Node_Node -- 1252 ----------------------- 1253 1254 function Is_Less_Node_Node (L, R : Node_Access) return Boolean is 1255 begin 1256 return L.Element < R.Element; 1257 end Is_Less_Node_Node; 1258 1259 --------------- 1260 -- Is_Subset -- 1261 --------------- 1262 1263 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is 1264 begin 1265 return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); 1266 end Is_Subset; 1267 1268 ------------- 1269 -- Iterate -- 1270 ------------- 1271 1272 procedure Iterate 1273 (Container : Set; 1274 Process : not null access procedure (Position : Cursor)) 1275 is 1276 procedure Process_Node (Node : Node_Access); 1277 pragma Inline (Process_Node); 1278 1279 procedure Local_Iterate is 1280 new Tree_Operations.Generic_Iteration (Process_Node); 1281 1282 ------------------ 1283 -- Process_Node -- 1284 ------------------ 1285 1286 procedure Process_Node (Node : Node_Access) is 1287 begin 1288 Process (Cursor'(Container'Unrestricted_Access, Node)); 1289 end Process_Node; 1290 1291 T : Tree_Type renames Container'Unrestricted_Access.all.Tree; 1292 Busy : With_Busy (T.TC'Unrestricted_Access); 1293 1294 -- Start of processing for Iterate 1295 1296 begin 1297 Local_Iterate (T); 1298 end Iterate; 1299 1300 function Iterate (Container : Set) 1301 return Set_Iterator_Interfaces.Reversible_Iterator'Class 1302 is 1303 begin 1304 -- The value of the Node component influences the behavior of the First 1305 -- and Last selector functions of the iterator object. When the Node 1306 -- component is null (as is the case here), this means the iterator 1307 -- object was constructed without a start expression. This is a complete 1308 -- iterator, meaning that the iteration starts from the (logical) 1309 -- beginning of the sequence of items. 1310 1311 -- Note: For a forward iterator, Container.First is the beginning, and 1312 -- for a reverse iterator, Container.Last is the beginning. 1313 1314 Busy (Container.Tree.TC'Unrestricted_Access.all); 1315 1316 return It : constant Iterator := 1317 Iterator'(Limited_Controlled with 1318 Container => Container'Unrestricted_Access, 1319 Node => null); 1320 end Iterate; 1321 1322 function Iterate (Container : Set; Start : Cursor) 1323 return Set_Iterator_Interfaces.Reversible_Iterator'Class 1324 is 1325 begin 1326 -- It was formerly the case that when Start = No_Element, the partial 1327 -- iterator was defined to behave the same as for a complete iterator, 1328 -- and iterate over the entire sequence of items. However, those 1329 -- semantics were unintuitive and arguably error-prone (it is too easy 1330 -- to accidentally create an endless loop), and so they were changed, 1331 -- per the ARG meeting in Denver on 2011/11. However, there was no 1332 -- consensus about what positive meaning this corner case should have, 1333 -- and so it was decided to simply raise an exception. This does imply, 1334 -- however, that it is not possible to use a partial iterator to specify 1335 -- an empty sequence of items. 1336 1337 if Checks and then Start = No_Element then 1338 raise Constraint_Error with 1339 "Start position for iterator equals No_Element"; 1340 end if; 1341 1342 if Checks and then Start.Container /= Container'Unrestricted_Access then 1343 raise Program_Error with 1344 "Start cursor of Iterate designates wrong set"; 1345 end if; 1346 1347 pragma Assert (Vet (Container.Tree, Start.Node), 1348 "Start cursor of Iterate is bad"); 1349 1350 -- The value of the Node component influences the behavior of the First 1351 -- and Last selector functions of the iterator object. When the Node 1352 -- component is non-null (as is the case here), it means that this is a 1353 -- partial iteration, over a subset of the complete sequence of 1354 -- items. The iterator object was constructed with a start expression, 1355 -- indicating the position from which the iteration begins. Note that 1356 -- the start position has the same value irrespective of whether this is 1357 -- a forward or reverse iteration. 1358 1359 Busy (Container.Tree.TC'Unrestricted_Access.all); 1360 1361 return It : constant Iterator := 1362 Iterator'(Limited_Controlled with 1363 Container => Container'Unrestricted_Access, 1364 Node => Start.Node); 1365 end Iterate; 1366 1367 ---------- 1368 -- Last -- 1369 ---------- 1370 1371 function Last (Container : Set) return Cursor is 1372 begin 1373 return 1374 (if Container.Tree.Last = null then No_Element 1375 else Cursor'(Container'Unrestricted_Access, Container.Tree.Last)); 1376 end Last; 1377 1378 function Last (Object : Iterator) return Cursor is 1379 begin 1380 -- The value of the iterator object's Node component influences the 1381 -- behavior of the Last (and First) selector function. 1382 1383 -- When the Node component is null, this means the iterator object was 1384 -- constructed without a start expression, in which case the (reverse) 1385 -- iteration starts from the (logical) beginning of the entire sequence 1386 -- (corresponding to Container.Last, for a reverse iterator). 1387 1388 -- Otherwise, this is iteration over a partial sequence of items. When 1389 -- the Node component is non-null, the iterator object was constructed 1390 -- with a start expression, that specifies the position from which the 1391 -- (reverse) partial iteration begins. 1392 1393 if Object.Node = null then 1394 return Object.Container.Last; 1395 else 1396 return Cursor'(Object.Container, Object.Node); 1397 end if; 1398 end Last; 1399 1400 ------------------ 1401 -- Last_Element -- 1402 ------------------ 1403 1404 function Last_Element (Container : Set) return Element_Type is 1405 begin 1406 if Checks and then Container.Tree.Last = null then 1407 raise Constraint_Error with "set is empty"; 1408 end if; 1409 1410 return Container.Tree.Last.Element; 1411 end Last_Element; 1412 1413 ---------- 1414 -- Left -- 1415 ---------- 1416 1417 function Left (Node : Node_Access) return Node_Access is 1418 begin 1419 return Node.Left; 1420 end Left; 1421 1422 ------------ 1423 -- Length -- 1424 ------------ 1425 1426 function Length (Container : Set) return Count_Type is 1427 begin 1428 return Container.Tree.Length; 1429 end Length; 1430 1431 ---------- 1432 -- Move -- 1433 ---------- 1434 1435 procedure Move is new Tree_Operations.Generic_Move (Clear); 1436 1437 procedure Move (Target : in out Set; Source : in out Set) is 1438 begin 1439 Move (Target => Target.Tree, Source => Source.Tree); 1440 end Move; 1441 1442 ---------- 1443 -- Next -- 1444 ---------- 1445 1446 function Next (Position : Cursor) return Cursor is 1447 begin 1448 if Position = No_Element then 1449 return No_Element; 1450 end if; 1451 1452 pragma Assert (Vet (Position.Container.Tree, Position.Node), 1453 "bad cursor in Next"); 1454 1455 declare 1456 Node : constant Node_Access := 1457 Tree_Operations.Next (Position.Node); 1458 begin 1459 return (if Node = null then No_Element 1460 else Cursor'(Position.Container, Node)); 1461 end; 1462 end Next; 1463 1464 procedure Next (Position : in out Cursor) is 1465 begin 1466 Position := Next (Position); 1467 end Next; 1468 1469 function Next (Object : Iterator; Position : Cursor) return Cursor is 1470 begin 1471 if Position.Container = null then 1472 return No_Element; 1473 end if; 1474 1475 if Checks and then Position.Container /= Object.Container then 1476 raise Program_Error with 1477 "Position cursor of Next designates wrong set"; 1478 end if; 1479 1480 return Next (Position); 1481 end Next; 1482 1483 ------------- 1484 -- Overlap -- 1485 ------------- 1486 1487 function Overlap (Left, Right : Set) return Boolean is 1488 begin 1489 return Set_Ops.Overlap (Left.Tree, Right.Tree); 1490 end Overlap; 1491 1492 ------------ 1493 -- Parent -- 1494 ------------ 1495 1496 function Parent (Node : Node_Access) return Node_Access is 1497 begin 1498 return Node.Parent; 1499 end Parent; 1500 1501 -------------- 1502 -- Previous -- 1503 -------------- 1504 1505 function Previous (Position : Cursor) return Cursor is 1506 begin 1507 if Position = No_Element then 1508 return No_Element; 1509 end if; 1510 1511 pragma Assert (Vet (Position.Container.Tree, Position.Node), 1512 "bad cursor in Previous"); 1513 1514 declare 1515 Node : constant Node_Access := 1516 Tree_Operations.Previous (Position.Node); 1517 begin 1518 return (if Node = null then No_Element 1519 else Cursor'(Position.Container, Node)); 1520 end; 1521 end Previous; 1522 1523 procedure Previous (Position : in out Cursor) is 1524 begin 1525 Position := Previous (Position); 1526 end Previous; 1527 1528 function Previous (Object : Iterator; Position : Cursor) return Cursor is 1529 begin 1530 if Position.Container = null then 1531 return No_Element; 1532 end if; 1533 1534 if Checks and then Position.Container /= Object.Container then 1535 raise Program_Error with 1536 "Position cursor of Previous designates wrong set"; 1537 end if; 1538 1539 return Previous (Position); 1540 end Previous; 1541 1542 ---------------------- 1543 -- Pseudo_Reference -- 1544 ---------------------- 1545 1546 function Pseudo_Reference 1547 (Container : aliased Set'Class) return Reference_Control_Type 1548 is 1549 TC : constant Tamper_Counts_Access := 1550 Container.Tree.TC'Unrestricted_Access; 1551 begin 1552 return R : constant Reference_Control_Type := (Controlled with TC) do 1553 Lock (TC.all); 1554 end return; 1555 end Pseudo_Reference; 1556 1557 ------------------- 1558 -- Query_Element -- 1559 ------------------- 1560 1561 procedure Query_Element 1562 (Position : Cursor; 1563 Process : not null access procedure (Element : Element_Type)) 1564 is 1565 begin 1566 if Checks and then Position.Node = null then 1567 raise Constraint_Error with "Position cursor equals No_Element"; 1568 end if; 1569 1570 pragma Assert (Vet (Position.Container.Tree, Position.Node), 1571 "bad cursor in Query_Element"); 1572 1573 declare 1574 T : Tree_Type renames Position.Container.Tree; 1575 Lock : With_Lock (T.TC'Unrestricted_Access); 1576 begin 1577 Process (Position.Node.Element); 1578 end; 1579 end Query_Element; 1580 1581 ---------- 1582 -- Read -- 1583 ---------- 1584 1585 procedure Read 1586 (Stream : not null access Root_Stream_Type'Class; 1587 Container : out Set) 1588 is 1589 function Read_Node 1590 (Stream : not null access Root_Stream_Type'Class) return Node_Access; 1591 pragma Inline (Read_Node); 1592 1593 procedure Read is 1594 new Tree_Operations.Generic_Read (Clear, Read_Node); 1595 1596 --------------- 1597 -- Read_Node -- 1598 --------------- 1599 1600 function Read_Node 1601 (Stream : not null access Root_Stream_Type'Class) return Node_Access 1602 is 1603 Node : Node_Access := new Node_Type; 1604 begin 1605 Element_Type'Read (Stream, Node.Element); 1606 return Node; 1607 exception 1608 when others => 1609 Free (Node); 1610 raise; 1611 end Read_Node; 1612 1613 -- Start of processing for Read 1614 1615 begin 1616 Read (Stream, Container.Tree); 1617 end Read; 1618 1619 procedure Read 1620 (Stream : not null access Root_Stream_Type'Class; 1621 Item : out Cursor) 1622 is 1623 begin 1624 raise Program_Error with "attempt to stream set cursor"; 1625 end Read; 1626 1627 procedure Read 1628 (Stream : not null access Root_Stream_Type'Class; 1629 Item : out Constant_Reference_Type) 1630 is 1631 begin 1632 raise Program_Error with "attempt to stream reference"; 1633 end Read; 1634 1635 ------------- 1636 -- Replace -- 1637 ------------- 1638 1639 procedure Replace (Container : in out Set; New_Item : Element_Type) is 1640 Node : constant Node_Access := 1641 Element_Keys.Find (Container.Tree, New_Item); 1642 1643 begin 1644 if Checks and then Node = null then 1645 raise Constraint_Error with 1646 "attempt to replace element not in set"; 1647 end if; 1648 1649 TE_Check (Container.Tree.TC); 1650 1651 Node.Element := New_Item; 1652 end Replace; 1653 1654 --------------------- 1655 -- Replace_Element -- 1656 --------------------- 1657 1658 procedure Replace_Element 1659 (Tree : in out Tree_Type; 1660 Node : Node_Access; 1661 Item : Element_Type) 1662 is 1663 pragma Assert (Node /= null); 1664 1665 function New_Node return Node_Access; 1666 pragma Inline (New_Node); 1667 1668 procedure Local_Insert_Post is 1669 new Element_Keys.Generic_Insert_Post (New_Node); 1670 1671 procedure Local_Insert_Sans_Hint is 1672 new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); 1673 1674 procedure Local_Insert_With_Hint is 1675 new Element_Keys.Generic_Conditional_Insert_With_Hint 1676 (Local_Insert_Post, 1677 Local_Insert_Sans_Hint); 1678 1679 -------------- 1680 -- New_Node -- 1681 -------------- 1682 1683 function New_Node return Node_Access is 1684 begin 1685 Node.Element := Item; 1686 Node.Color := Red; 1687 Node.Parent := null; 1688 Node.Right := null; 1689 Node.Left := null; 1690 return Node; 1691 end New_Node; 1692 1693 Hint : Node_Access; 1694 Result : Node_Access; 1695 Inserted : Boolean; 1696 Compare : Boolean; 1697 1698 -- Start of processing for Replace_Element 1699 1700 begin 1701 -- Replace_Element assigns value Item to the element designated by Node, 1702 -- per certain semantic constraints. 1703 1704 -- If Item is equivalent to the element, then element is replaced and 1705 -- there's nothing else to do. This is the easy case. 1706 1707 -- If Item is not equivalent, then the node will (possibly) have to move 1708 -- to some other place in the tree. This is slighly more complicated, 1709 -- because we must ensure that Item is not equivalent to some other 1710 -- element in the tree (in which case, the replacement is not allowed). 1711 1712 -- Determine whether Item is equivalent to element on the specified 1713 -- node. 1714 1715 declare 1716 Lock : With_Lock (Tree.TC'Unrestricted_Access); 1717 begin 1718 Compare := (if Item < Node.Element then False 1719 elsif Node.Element < Item then False 1720 else True); 1721 end; 1722 1723 if Compare then 1724 -- Item is equivalent to the node's element, so we will not have to 1725 -- move the node. 1726 1727 TE_Check (Tree.TC); 1728 1729 Node.Element := Item; 1730 return; 1731 end if; 1732 1733 -- The replacement Item is not equivalent to the element on the 1734 -- specified node, which means that it will need to be re-inserted in a 1735 -- different position in the tree. We must now determine whether Item is 1736 -- equivalent to some other element in the tree (which would prohibit 1737 -- the assignment and hence the move). 1738 1739 -- Ceiling returns the smallest element equivalent or greater than the 1740 -- specified Item; if there is no such element, then it returns null. 1741 1742 Hint := Element_Keys.Ceiling (Tree, Item); 1743 1744 if Hint /= null then 1745 declare 1746 Lock : With_Lock (Tree.TC'Unrestricted_Access); 1747 begin 1748 Compare := Item < Hint.Element; 1749 end; 1750 1751 -- Item >= Hint.Element 1752 1753 if Checks and then not Compare then 1754 1755 -- Ceiling returns an element that is equivalent or greater 1756 -- than Item. If Item is "not less than" the element, then 1757 -- by elimination we know that Item is equivalent to the element. 1758 1759 -- But this means that it is not possible to assign the value of 1760 -- Item to the specified element (on Node), because a different 1761 -- element (on Hint) equivalent to Item already exsits. (Were we 1762 -- to change Node's element value, we would have to move Node, but 1763 -- we would be unable to move the Node, because its new position 1764 -- in the tree is already occupied by an equivalent element.) 1765 1766 raise Program_Error with "attempt to replace existing element"; 1767 end if; 1768 1769 -- Item is not equivalent to any other element in the tree, so it is 1770 -- safe to assign the value of Item to Node.Element. This means that 1771 -- the node will have to move to a different position in the tree 1772 -- (because its element will have a different value). 1773 1774 -- The nearest (greater) neighbor of Item is Hint. This will be the 1775 -- insertion position of Node (because its element will have Item as 1776 -- its new value). 1777 1778 -- If Node equals Hint, the relative position of Node does not 1779 -- change. This allows us to perform an optimization: we need not 1780 -- remove Node from the tree and then reinsert it with its new value, 1781 -- because it would only be placed in the exact same position. 1782 1783 if Hint = Node then 1784 TE_Check (Tree.TC); 1785 1786 Node.Element := Item; 1787 return; 1788 end if; 1789 end if; 1790 1791 -- If we get here, it is because Item was greater than all elements in 1792 -- the tree (Hint = null), or because Item was less than some element at 1793 -- a different place in the tree (Item < Hint.Element). In either case, 1794 -- we remove Node from the tree (without actually deallocating it), and 1795 -- then insert Item into the tree, onto the same Node (so no new node is 1796 -- actually allocated). 1797 1798 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit 1799 1800 Local_Insert_With_Hint -- use unconditional insert here instead??? 1801 (Tree => Tree, 1802 Position => Hint, 1803 Key => Item, 1804 Node => Result, 1805 Inserted => Inserted); 1806 1807 pragma Assert (Inserted); 1808 pragma Assert (Result = Node); 1809 end Replace_Element; 1810 1811 procedure Replace_Element 1812 (Container : in out Set; 1813 Position : Cursor; 1814 New_Item : Element_Type) 1815 is 1816 begin 1817 if Checks and then Position.Node = null then 1818 raise Constraint_Error with 1819 "Position cursor equals No_Element"; 1820 end if; 1821 1822 if Checks and then Position.Container /= Container'Unrestricted_Access 1823 then 1824 raise Program_Error with 1825 "Position cursor designates wrong set"; 1826 end if; 1827 1828 pragma Assert (Vet (Container.Tree, Position.Node), 1829 "bad cursor in Replace_Element"); 1830 1831 Replace_Element (Container.Tree, Position.Node, New_Item); 1832 end Replace_Element; 1833 1834 --------------------- 1835 -- Reverse_Iterate -- 1836 --------------------- 1837 1838 procedure Reverse_Iterate 1839 (Container : Set; 1840 Process : not null access procedure (Position : Cursor)) 1841 is 1842 procedure Process_Node (Node : Node_Access); 1843 pragma Inline (Process_Node); 1844 1845 procedure Local_Reverse_Iterate is 1846 new Tree_Operations.Generic_Reverse_Iteration (Process_Node); 1847 1848 ------------------ 1849 -- Process_Node -- 1850 ------------------ 1851 1852 procedure Process_Node (Node : Node_Access) is 1853 begin 1854 Process (Cursor'(Container'Unrestricted_Access, Node)); 1855 end Process_Node; 1856 1857 T : Tree_Type renames Container.Tree'Unrestricted_Access.all; 1858 Busy : With_Busy (T.TC'Unrestricted_Access); 1859 1860 -- Start of processing for Reverse_Iterate 1861 1862 begin 1863 Local_Reverse_Iterate (T); 1864 end Reverse_Iterate; 1865 1866 ----------- 1867 -- Right -- 1868 ----------- 1869 1870 function Right (Node : Node_Access) return Node_Access is 1871 begin 1872 return Node.Right; 1873 end Right; 1874 1875 --------------- 1876 -- Set_Color -- 1877 --------------- 1878 1879 procedure Set_Color (Node : Node_Access; Color : Color_Type) is 1880 begin 1881 Node.Color := Color; 1882 end Set_Color; 1883 1884 -------------- 1885 -- Set_Left -- 1886 -------------- 1887 1888 procedure Set_Left (Node : Node_Access; Left : Node_Access) is 1889 begin 1890 Node.Left := Left; 1891 end Set_Left; 1892 1893 ---------------- 1894 -- Set_Parent -- 1895 ---------------- 1896 1897 procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is 1898 begin 1899 Node.Parent := Parent; 1900 end Set_Parent; 1901 1902 --------------- 1903 -- Set_Right -- 1904 --------------- 1905 1906 procedure Set_Right (Node : Node_Access; Right : Node_Access) is 1907 begin 1908 Node.Right := Right; 1909 end Set_Right; 1910 1911 -------------------------- 1912 -- Symmetric_Difference -- 1913 -------------------------- 1914 1915 procedure Symmetric_Difference (Target : in out Set; Source : Set) is 1916 begin 1917 Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); 1918 end Symmetric_Difference; 1919 1920 function Symmetric_Difference (Left, Right : Set) return Set is 1921 Tree : constant Tree_Type := 1922 Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); 1923 begin 1924 return Set'(Controlled with Tree); 1925 end Symmetric_Difference; 1926 1927 ------------ 1928 -- To_Set -- 1929 ------------ 1930 1931 function To_Set (New_Item : Element_Type) return Set is 1932 Tree : Tree_Type; 1933 Node : Node_Access; 1934 Inserted : Boolean; 1935 pragma Unreferenced (Node, Inserted); 1936 begin 1937 Insert_Sans_Hint (Tree, New_Item, Node, Inserted); 1938 return Set'(Controlled with Tree); 1939 end To_Set; 1940 1941 ----------- 1942 -- Union -- 1943 ----------- 1944 1945 procedure Union (Target : in out Set; Source : Set) is 1946 begin 1947 Set_Ops.Union (Target.Tree, Source.Tree); 1948 end Union; 1949 1950 function Union (Left, Right : Set) return Set is 1951 Tree : constant Tree_Type := 1952 Set_Ops.Union (Left.Tree, Right.Tree); 1953 begin 1954 return Set'(Controlled with Tree); 1955 end Union; 1956 1957 ----------- 1958 -- Write -- 1959 ----------- 1960 1961 procedure Write 1962 (Stream : not null access Root_Stream_Type'Class; 1963 Container : Set) 1964 is 1965 procedure Write_Node 1966 (Stream : not null access Root_Stream_Type'Class; 1967 Node : Node_Access); 1968 pragma Inline (Write_Node); 1969 1970 procedure Write is 1971 new Tree_Operations.Generic_Write (Write_Node); 1972 1973 ---------------- 1974 -- Write_Node -- 1975 ---------------- 1976 1977 procedure Write_Node 1978 (Stream : not null access Root_Stream_Type'Class; 1979 Node : Node_Access) 1980 is 1981 begin 1982 Element_Type'Write (Stream, Node.Element); 1983 end Write_Node; 1984 1985 -- Start of processing for Write 1986 1987 begin 1988 Write (Stream, Container.Tree); 1989 end Write; 1990 1991 procedure Write 1992 (Stream : not null access Root_Stream_Type'Class; 1993 Item : Cursor) 1994 is 1995 begin 1996 raise Program_Error with "attempt to stream set cursor"; 1997 end Write; 1998 1999 procedure Write 2000 (Stream : not null access Root_Stream_Type'Class; 2001 Item : Constant_Reference_Type) 2002 is 2003 begin 2004 raise Program_Error with "attempt to stream reference"; 2005 end Write; 2006 2007end Ada.Containers.Ordered_Sets; 2008