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