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