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