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