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