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