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