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