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-2020, 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'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 Node : constant Count_Type := Key_Keys.Find (Container, Key); 743 744 begin 745 if Checks and then Node = 0 then 746 raise Constraint_Error with "key not in set"; 747 end if; 748 749 declare 750 N : Node_Type renames Container.Nodes (Node); 751 TC : constant Tamper_Counts_Access := 752 Container.TC'Unrestricted_Access; 753 begin 754 return R : constant Constant_Reference_Type := 755 (Element => N.Element'Access, 756 Control => (Controlled with TC)) 757 do 758 Busy (TC.all); 759 end return; 760 end; 761 end Constant_Reference; 762 763 -------------- 764 -- Contains -- 765 -------------- 766 767 function Contains (Container : Set; Key : Key_Type) return Boolean is 768 begin 769 return Find (Container, Key) /= No_Element; 770 end Contains; 771 772 ------------ 773 -- Delete -- 774 ------------ 775 776 procedure Delete (Container : in out Set; Key : Key_Type) is 777 X : constant Count_Type := Key_Keys.Find (Container, Key); 778 779 begin 780 if Checks and then X = 0 then 781 raise Constraint_Error with "attempt to delete key not in set"; 782 end if; 783 784 Tree_Operations.Delete_Node_Sans_Free (Container, X); 785 Tree_Operations.Free (Container, X); 786 end Delete; 787 788 ------------- 789 -- Element -- 790 ------------- 791 792 function Element (Container : Set; Key : Key_Type) return Element_Type is 793 Node : constant Count_Type := Key_Keys.Find (Container, Key); 794 795 begin 796 if Checks and then Node = 0 then 797 raise Constraint_Error with "key not in set"; 798 end if; 799 800 return Container.Nodes (Node).Element; 801 end Element; 802 803 --------------------- 804 -- Equivalent_Keys -- 805 --------------------- 806 807 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is 808 begin 809 return (if Left < Right or else Right < Left then False else True); 810 end Equivalent_Keys; 811 812 ------------- 813 -- Exclude -- 814 ------------- 815 816 procedure Exclude (Container : in out Set; Key : Key_Type) is 817 X : constant Count_Type := Key_Keys.Find (Container, Key); 818 begin 819 if X /= 0 then 820 Tree_Operations.Delete_Node_Sans_Free (Container, X); 821 Tree_Operations.Free (Container, X); 822 end if; 823 end Exclude; 824 825 -------------- 826 -- Finalize -- 827 -------------- 828 829 procedure Finalize (Control : in out Reference_Control_Type) is 830 begin 831 if Control.Container /= null then 832 Impl.Reference_Control_Type (Control).Finalize; 833 834 if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) 835 then 836 Delete (Control.Container.all, Key (Control.Pos)); 837 raise Program_Error; 838 end if; 839 840 Control.Container := null; 841 end if; 842 end Finalize; 843 844 ---------- 845 -- Find -- 846 ---------- 847 848 function Find (Container : Set; Key : Key_Type) return Cursor is 849 Node : constant Count_Type := Key_Keys.Find (Container, Key); 850 begin 851 return (if Node = 0 then No_Element 852 else Cursor'(Container'Unrestricted_Access, Node)); 853 end Find; 854 855 ----------- 856 -- Floor -- 857 ----------- 858 859 function Floor (Container : Set; Key : Key_Type) return Cursor is 860 Node : constant Count_Type := Key_Keys.Floor (Container, Key); 861 begin 862 return (if Node = 0 then No_Element 863 else Cursor'(Container'Unrestricted_Access, Node)); 864 end Floor; 865 866 ------------------------- 867 -- Is_Greater_Key_Node -- 868 ------------------------- 869 870 function Is_Greater_Key_Node 871 (Left : Key_Type; 872 Right : Node_Type) return Boolean 873 is 874 begin 875 return Key (Right.Element) < Left; 876 end Is_Greater_Key_Node; 877 878 ---------------------- 879 -- Is_Less_Key_Node -- 880 ---------------------- 881 882 function Is_Less_Key_Node 883 (Left : Key_Type; 884 Right : Node_Type) return Boolean 885 is 886 begin 887 return Left < Key (Right.Element); 888 end Is_Less_Key_Node; 889 890 --------- 891 -- Key -- 892 --------- 893 894 function Key (Position : Cursor) return Key_Type is 895 begin 896 if Checks and then Position.Node = 0 then 897 raise Constraint_Error with 898 "Position cursor equals No_Element"; 899 end if; 900 901 pragma Assert (Vet (Position.Container.all, Position.Node), 902 "bad cursor in Key"); 903 904 return Key (Position.Container.Nodes (Position.Node).Element); 905 end Key; 906 907 ---------- 908 -- Read -- 909 ---------- 910 911 procedure Read 912 (Stream : not null access Root_Stream_Type'Class; 913 Item : out Reference_Type) 914 is 915 begin 916 raise Program_Error with "attempt to stream reference"; 917 end Read; 918 919 ------------------------------ 920 -- Reference_Preserving_Key -- 921 ------------------------------ 922 923 function Reference_Preserving_Key 924 (Container : aliased in out Set; 925 Position : Cursor) return Reference_Type 926 is 927 begin 928 if Checks and then Position.Container = null then 929 raise Constraint_Error with "Position cursor has no element"; 930 end if; 931 932 if Checks and then Position.Container /= Container'Unrestricted_Access 933 then 934 raise Program_Error with 935 "Position cursor designates wrong container"; 936 end if; 937 938 pragma Assert 939 (Vet (Container, Position.Node), 940 "bad cursor in function Reference_Preserving_Key"); 941 942 declare 943 N : Node_Type renames Container.Nodes (Position.Node); 944 begin 945 return R : constant Reference_Type := 946 (Element => N.Element'Access, 947 Control => 948 (Controlled with 949 Container.TC'Unrestricted_Access, 950 Container => Container'Unchecked_Access, 951 Pos => Position, 952 Old_Key => new Key_Type'(Key (Position)))) 953 do 954 Busy (Container.TC); 955 end return; 956 end; 957 end Reference_Preserving_Key; 958 959 function Reference_Preserving_Key 960 (Container : aliased in out Set; 961 Key : Key_Type) return Reference_Type 962 is 963 Node : constant Count_Type := Key_Keys.Find (Container, Key); 964 965 begin 966 if Checks and then Node = 0 then 967 raise Constraint_Error with "key not in set"; 968 end if; 969 970 declare 971 N : Node_Type renames Container.Nodes (Node); 972 begin 973 return R : constant Reference_Type := 974 (Element => N.Element'Access, 975 Control => 976 (Controlled with 977 Container.TC'Unrestricted_Access, 978 Container => Container'Unchecked_Access, 979 Pos => Find (Container, Key), 980 Old_Key => new Key_Type'(Key))) 981 do 982 Busy (Container.TC); 983 end return; 984 end; 985 end Reference_Preserving_Key; 986 987 ------------- 988 -- Replace -- 989 ------------- 990 991 procedure Replace 992 (Container : in out Set; 993 Key : Key_Type; 994 New_Item : Element_Type) 995 is 996 Node : constant Count_Type := Key_Keys.Find (Container, Key); 997 998 begin 999 if Checks and then Node = 0 then 1000 raise Constraint_Error with 1001 "attempt to replace key not in set"; 1002 end if; 1003 1004 Replace_Element (Container, Node, New_Item); 1005 end Replace; 1006 1007 ----------------------------------- 1008 -- Update_Element_Preserving_Key -- 1009 ----------------------------------- 1010 1011 procedure Update_Element_Preserving_Key 1012 (Container : in out Set; 1013 Position : Cursor; 1014 Process : not null access procedure (Element : in out Element_Type)) 1015 is 1016 begin 1017 if Checks and then Position.Node = 0 then 1018 raise Constraint_Error with 1019 "Position cursor equals No_Element"; 1020 end if; 1021 1022 if Checks and then Position.Container /= Container'Unrestricted_Access 1023 then 1024 raise Program_Error with 1025 "Position cursor designates wrong set"; 1026 end if; 1027 1028 pragma Assert (Vet (Container, Position.Node), 1029 "bad cursor in Update_Element_Preserving_Key"); 1030 1031 -- Per AI05-0022, the container implementation is required to detect 1032 -- element tampering by a generic actual subprogram. 1033 1034 declare 1035 N : Node_Type renames Container.Nodes (Position.Node); 1036 E : Element_Type renames N.Element; 1037 K : constant Key_Type := Key (E); 1038 Lock : With_Lock (Container.TC'Unrestricted_Access); 1039 begin 1040 Process (E); 1041 if Equivalent_Keys (K, Key (E)) then 1042 return; 1043 end if; 1044 end; 1045 1046 Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); 1047 Tree_Operations.Free (Container, Position.Node); 1048 1049 raise Program_Error with "key was modified"; 1050 end Update_Element_Preserving_Key; 1051 1052 ----------- 1053 -- Write -- 1054 ----------- 1055 1056 procedure Write 1057 (Stream : not null access Root_Stream_Type'Class; 1058 Item : Reference_Type) 1059 is 1060 begin 1061 raise Program_Error with "attempt to stream reference"; 1062 end Write; 1063 end Generic_Keys; 1064 1065 ------------------------ 1066 -- Get_Element_Access -- 1067 ------------------------ 1068 1069 function Get_Element_Access 1070 (Position : Cursor) return not null Element_Access is 1071 begin 1072 return Position.Container.Nodes (Position.Node).Element'Access; 1073 end Get_Element_Access; 1074 1075 ----------------- 1076 -- Has_Element -- 1077 ----------------- 1078 1079 function Has_Element (Position : Cursor) return Boolean is 1080 begin 1081 return Position /= No_Element; 1082 end Has_Element; 1083 1084 ------------- 1085 -- Include -- 1086 ------------- 1087 1088 procedure Include (Container : in out Set; New_Item : Element_Type) is 1089 Position : Cursor; 1090 Inserted : Boolean; 1091 1092 begin 1093 Insert (Container, New_Item, Position, Inserted); 1094 1095 if not Inserted then 1096 TE_Check (Container.TC); 1097 1098 Container.Nodes (Position.Node).Element := New_Item; 1099 end if; 1100 end Include; 1101 1102 ------------ 1103 -- Insert -- 1104 ------------ 1105 1106 procedure Insert 1107 (Container : in out Set; 1108 New_Item : Element_Type; 1109 Position : out Cursor; 1110 Inserted : out Boolean) 1111 is 1112 begin 1113 Insert_Sans_Hint 1114 (Container, 1115 New_Item, 1116 Position.Node, 1117 Inserted); 1118 1119 Position.Container := Container'Unrestricted_Access; 1120 end Insert; 1121 1122 procedure Insert 1123 (Container : in out Set; 1124 New_Item : Element_Type) 1125 is 1126 Position : Cursor; 1127 pragma Unreferenced (Position); 1128 1129 Inserted : Boolean; 1130 1131 begin 1132 Insert (Container, New_Item, Position, Inserted); 1133 1134 if Checks and then not Inserted then 1135 raise Constraint_Error with 1136 "attempt to insert element already in set"; 1137 end if; 1138 end Insert; 1139 1140 ---------------------- 1141 -- Insert_Sans_Hint -- 1142 ---------------------- 1143 1144 procedure Insert_Sans_Hint 1145 (Container : in out Set; 1146 New_Item : Element_Type; 1147 Node : out Count_Type; 1148 Inserted : out Boolean) 1149 is 1150 procedure Set_Element (Node : in out Node_Type); 1151 pragma Inline (Set_Element); 1152 1153 function New_Node return Count_Type; 1154 pragma Inline (New_Node); 1155 1156 procedure Insert_Post is 1157 new Element_Keys.Generic_Insert_Post (New_Node); 1158 1159 procedure Conditional_Insert_Sans_Hint is 1160 new Element_Keys.Generic_Conditional_Insert (Insert_Post); 1161 1162 procedure Allocate is 1163 new Tree_Operations.Generic_Allocate (Set_Element); 1164 1165 -------------- 1166 -- New_Node -- 1167 -------------- 1168 1169 function New_Node return Count_Type is 1170 Result : Count_Type; 1171 begin 1172 Allocate (Container, Result); 1173 return Result; 1174 end New_Node; 1175 1176 ----------------- 1177 -- Set_Element -- 1178 ----------------- 1179 1180 procedure Set_Element (Node : in out Node_Type) is 1181 begin 1182 Node.Element := New_Item; 1183 end Set_Element; 1184 1185 -- Start of processing for Insert_Sans_Hint 1186 1187 begin 1188 TC_Check (Container.TC); 1189 1190 Conditional_Insert_Sans_Hint 1191 (Container, 1192 New_Item, 1193 Node, 1194 Inserted); 1195 end Insert_Sans_Hint; 1196 1197 ---------------------- 1198 -- Insert_With_Hint -- 1199 ---------------------- 1200 1201 procedure Insert_With_Hint 1202 (Dst_Set : in out Set; 1203 Dst_Hint : Count_Type; 1204 Src_Node : Node_Type; 1205 Dst_Node : out Count_Type) 1206 is 1207 Success : Boolean; 1208 pragma Unreferenced (Success); 1209 1210 procedure Set_Element (Node : in out Node_Type); 1211 pragma Inline (Set_Element); 1212 1213 function New_Node return Count_Type; 1214 pragma Inline (New_Node); 1215 1216 procedure Insert_Post is 1217 new Element_Keys.Generic_Insert_Post (New_Node); 1218 1219 procedure Insert_Sans_Hint is 1220 new Element_Keys.Generic_Conditional_Insert (Insert_Post); 1221 1222 procedure Local_Insert_With_Hint is 1223 new Element_Keys.Generic_Conditional_Insert_With_Hint 1224 (Insert_Post, 1225 Insert_Sans_Hint); 1226 1227 procedure Allocate is 1228 new Tree_Operations.Generic_Allocate (Set_Element); 1229 1230 -------------- 1231 -- New_Node -- 1232 -------------- 1233 1234 function New_Node return Count_Type is 1235 Result : Count_Type; 1236 begin 1237 Allocate (Dst_Set, Result); 1238 return Result; 1239 end New_Node; 1240 1241 ----------------- 1242 -- Set_Element -- 1243 ----------------- 1244 1245 procedure Set_Element (Node : in out Node_Type) is 1246 begin 1247 Node.Element := Src_Node.Element; 1248 end Set_Element; 1249 1250 -- Start of processing for Insert_With_Hint 1251 1252 begin 1253 Local_Insert_With_Hint 1254 (Dst_Set, 1255 Dst_Hint, 1256 Src_Node.Element, 1257 Dst_Node, 1258 Success); 1259 end Insert_With_Hint; 1260 1261 ------------------ 1262 -- Intersection -- 1263 ------------------ 1264 1265 procedure Intersection (Target : in out Set; Source : Set) 1266 renames Set_Ops.Set_Intersection; 1267 1268 function Intersection (Left, Right : Set) return Set 1269 renames Set_Ops.Set_Intersection; 1270 1271 -------------- 1272 -- Is_Empty -- 1273 -------------- 1274 1275 function Is_Empty (Container : Set) return Boolean is 1276 begin 1277 return Container.Length = 0; 1278 end Is_Empty; 1279 1280 ----------------------------- 1281 -- Is_Greater_Element_Node -- 1282 ----------------------------- 1283 1284 function Is_Greater_Element_Node 1285 (Left : Element_Type; 1286 Right : Node_Type) return Boolean 1287 is 1288 begin 1289 -- Compute e > node same as node < e 1290 1291 return Right.Element < Left; 1292 end Is_Greater_Element_Node; 1293 1294 -------------------------- 1295 -- Is_Less_Element_Node -- 1296 -------------------------- 1297 1298 function Is_Less_Element_Node 1299 (Left : Element_Type; 1300 Right : Node_Type) return Boolean 1301 is 1302 begin 1303 return Left < Right.Element; 1304 end Is_Less_Element_Node; 1305 1306 ----------------------- 1307 -- Is_Less_Node_Node -- 1308 ----------------------- 1309 1310 function Is_Less_Node_Node (L, R : Node_Type) return Boolean is 1311 begin 1312 return L.Element < R.Element; 1313 end Is_Less_Node_Node; 1314 1315 --------------- 1316 -- Is_Subset -- 1317 --------------- 1318 1319 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean 1320 renames Set_Ops.Set_Subset; 1321 1322 ------------- 1323 -- Iterate -- 1324 ------------- 1325 1326 procedure Iterate 1327 (Container : Set; 1328 Process : not null access procedure (Position : Cursor)) 1329 is 1330 procedure Process_Node (Node : Count_Type); 1331 pragma Inline (Process_Node); 1332 1333 procedure Local_Iterate is 1334 new Tree_Operations.Generic_Iteration (Process_Node); 1335 1336 ------------------ 1337 -- Process_Node -- 1338 ------------------ 1339 1340 procedure Process_Node (Node : Count_Type) is 1341 begin 1342 Process (Cursor'(Container'Unrestricted_Access, Node)); 1343 end Process_Node; 1344 1345 S : Set renames Container'Unrestricted_Access.all; 1346 Busy : With_Busy (S.TC'Unrestricted_Access); 1347 1348 -- Start of processing for Iterate 1349 1350 begin 1351 Local_Iterate (S); 1352 end Iterate; 1353 1354 function Iterate (Container : Set) 1355 return Set_Iterator_Interfaces.Reversible_Iterator'class 1356 is 1357 begin 1358 -- The value of the Node component influences the behavior of the First 1359 -- and Last selector functions of the iterator object. When the Node 1360 -- component is 0 (as is the case here), this means the iterator object 1361 -- was constructed without a start expression. This is a complete 1362 -- iterator, meaning that the iteration starts from the (logical) 1363 -- beginning of the sequence of items. 1364 1365 -- Note: For a forward iterator, Container.First is the beginning, and 1366 -- for a reverse iterator, Container.Last is the beginning. 1367 1368 return It : constant Iterator := 1369 Iterator'(Limited_Controlled with 1370 Container => Container'Unrestricted_Access, 1371 Node => 0) 1372 do 1373 Busy (Container.TC'Unrestricted_Access.all); 1374 end return; 1375 end Iterate; 1376 1377 function Iterate (Container : Set; Start : Cursor) 1378 return Set_Iterator_Interfaces.Reversible_Iterator'class 1379 is 1380 begin 1381 -- It was formerly the case that when Start = No_Element, the partial 1382 -- iterator was defined to behave the same as for a complete iterator, 1383 -- and iterate over the entire sequence of items. However, those 1384 -- semantics were unintuitive and arguably error-prone (it is too easy 1385 -- to accidentally create an endless loop), and so they were changed, 1386 -- per the ARG meeting in Denver on 2011/11. However, there was no 1387 -- consensus about what positive meaning this corner case should have, 1388 -- and so it was decided to simply raise an exception. This does imply, 1389 -- however, that it is not possible to use a partial iterator to specify 1390 -- an empty sequence of items. 1391 1392 if Checks and then Start = No_Element then 1393 raise Constraint_Error with 1394 "Start position for iterator equals No_Element"; 1395 end if; 1396 1397 if Checks and then Start.Container /= Container'Unrestricted_Access then 1398 raise Program_Error with 1399 "Start cursor of Iterate designates wrong set"; 1400 end if; 1401 1402 pragma Assert (Vet (Container, Start.Node), 1403 "Start cursor of Iterate is bad"); 1404 1405 -- The value of the Node component influences the behavior of the First 1406 -- and Last selector functions of the iterator object. When the Node 1407 -- component is positive (as is the case here), it means that this 1408 -- is a partial iteration, over a subset of the complete sequence of 1409 -- items. The iterator object was constructed with a start expression, 1410 -- indicating the position from which the iteration begins. (Note that 1411 -- the start position has the same value irrespective of whether this 1412 -- is a forward or reverse iteration.) 1413 1414 return It : constant Iterator := 1415 Iterator'(Limited_Controlled with 1416 Container => Container'Unrestricted_Access, 1417 Node => Start.Node) 1418 do 1419 Busy (Container.TC'Unrestricted_Access.all); 1420 end return; 1421 end Iterate; 1422 1423 ---------- 1424 -- Last -- 1425 ---------- 1426 1427 function Last (Container : Set) return Cursor is 1428 begin 1429 return (if Container.Last = 0 then No_Element 1430 else Cursor'(Container'Unrestricted_Access, Container.Last)); 1431 end Last; 1432 1433 function Last (Object : Iterator) return Cursor is 1434 begin 1435 -- The value of the iterator object's Node component influences the 1436 -- behavior of the Last (and First) selector function. 1437 1438 -- When the Node component is 0, this means the iterator object was 1439 -- constructed without a start expression, in which case the (reverse) 1440 -- iteration starts from the (logical) beginning of the entire sequence 1441 -- (corresponding to Container.Last, for a reverse iterator). 1442 1443 -- Otherwise, this is iteration over a partial sequence of items. When 1444 -- the Node component is positive, the iterator object was constructed 1445 -- with a start expression, that specifies the position from which the 1446 -- (reverse) partial iteration begins. 1447 1448 if Object.Node = 0 then 1449 return Bounded_Ordered_Sets.Last (Object.Container.all); 1450 else 1451 return Cursor'(Object.Container, Object.Node); 1452 end if; 1453 end Last; 1454 1455 ------------------ 1456 -- Last_Element -- 1457 ------------------ 1458 1459 function Last_Element (Container : Set) return Element_Type is 1460 begin 1461 if Checks and then Container.Last = 0 then 1462 raise Constraint_Error with "set is empty"; 1463 end if; 1464 1465 return Container.Nodes (Container.Last).Element; 1466 end Last_Element; 1467 1468 ---------- 1469 -- Left -- 1470 ---------- 1471 1472 function Left (Node : Node_Type) return Count_Type is 1473 begin 1474 return Node.Left; 1475 end Left; 1476 1477 ------------ 1478 -- Length -- 1479 ------------ 1480 1481 function Length (Container : Set) return Count_Type is 1482 begin 1483 return Container.Length; 1484 end Length; 1485 1486 ---------- 1487 -- Move -- 1488 ---------- 1489 1490 procedure Move (Target : in out Set; Source : in out Set) is 1491 begin 1492 if Target'Address = Source'Address then 1493 return; 1494 end if; 1495 1496 TC_Check (Source.TC); 1497 1498 Target.Assign (Source); 1499 Source.Clear; 1500 end Move; 1501 1502 ---------- 1503 -- Next -- 1504 ---------- 1505 1506 function Next (Position : Cursor) return Cursor is 1507 begin 1508 if Position = No_Element then 1509 return No_Element; 1510 end if; 1511 1512 pragma Assert (Vet (Position.Container.all, Position.Node), 1513 "bad cursor in Next"); 1514 1515 declare 1516 Node : constant Count_Type := 1517 Tree_Operations.Next (Position.Container.all, Position.Node); 1518 1519 begin 1520 if Node = 0 then 1521 return No_Element; 1522 end if; 1523 1524 return Cursor'(Position.Container, Node); 1525 end; 1526 end Next; 1527 1528 procedure Next (Position : in out Cursor) is 1529 begin 1530 Position := Next (Position); 1531 end Next; 1532 1533 function Next (Object : Iterator; Position : Cursor) return Cursor is 1534 begin 1535 if Position.Container = null then 1536 return No_Element; 1537 end if; 1538 1539 if Checks and then Position.Container /= Object.Container then 1540 raise Program_Error with 1541 "Position cursor of Next designates wrong set"; 1542 end if; 1543 1544 return Next (Position); 1545 end Next; 1546 1547 ------------- 1548 -- Overlap -- 1549 ------------- 1550 1551 function Overlap (Left, Right : Set) return Boolean 1552 renames Set_Ops.Set_Overlap; 1553 1554 ------------ 1555 -- Parent -- 1556 ------------ 1557 1558 function Parent (Node : Node_Type) return Count_Type is 1559 begin 1560 return Node.Parent; 1561 end Parent; 1562 1563 -------------- 1564 -- Previous -- 1565 -------------- 1566 1567 function Previous (Position : Cursor) return Cursor is 1568 begin 1569 if Position = No_Element then 1570 return No_Element; 1571 end if; 1572 1573 pragma Assert (Vet (Position.Container.all, Position.Node), 1574 "bad cursor in Previous"); 1575 1576 declare 1577 Node : constant Count_Type := 1578 Tree_Operations.Previous (Position.Container.all, Position.Node); 1579 begin 1580 return (if Node = 0 then No_Element 1581 else Cursor'(Position.Container, Node)); 1582 end; 1583 end Previous; 1584 1585 procedure Previous (Position : in out Cursor) is 1586 begin 1587 Position := Previous (Position); 1588 end Previous; 1589 1590 function Previous (Object : Iterator; Position : Cursor) return Cursor is 1591 begin 1592 if Position.Container = null then 1593 return No_Element; 1594 end if; 1595 1596 if Checks and then Position.Container /= Object.Container then 1597 raise Program_Error with 1598 "Position cursor of Previous designates wrong set"; 1599 end if; 1600 1601 return Previous (Position); 1602 end Previous; 1603 1604 ---------------------- 1605 -- Pseudo_Reference -- 1606 ---------------------- 1607 1608 function Pseudo_Reference 1609 (Container : aliased Set'Class) return Reference_Control_Type 1610 is 1611 TC : constant Tamper_Counts_Access := 1612 Container.TC'Unrestricted_Access; 1613 begin 1614 return R : constant Reference_Control_Type := (Controlled with TC) do 1615 Busy (TC.all); 1616 end return; 1617 end Pseudo_Reference; 1618 1619 ------------------- 1620 -- Query_Element -- 1621 ------------------- 1622 1623 procedure Query_Element 1624 (Position : Cursor; 1625 Process : not null access procedure (Element : Element_Type)) 1626 is 1627 begin 1628 if Checks and then Position.Node = 0 then 1629 raise Constraint_Error with "Position cursor equals No_Element"; 1630 end if; 1631 1632 pragma Assert (Vet (Position.Container.all, Position.Node), 1633 "bad cursor in Query_Element"); 1634 1635 declare 1636 S : Set renames Position.Container.all; 1637 Lock : With_Lock (S.TC'Unrestricted_Access); 1638 begin 1639 Process (S.Nodes (Position.Node).Element); 1640 end; 1641 end Query_Element; 1642 1643 --------------- 1644 -- Put_Image -- 1645 --------------- 1646 1647 procedure Put_Image 1648 (S : in out Ada.Strings.Text_Output.Sink'Class; V : Set) 1649 is 1650 First_Time : Boolean := True; 1651 use System.Put_Images; 1652 begin 1653 Array_Before (S); 1654 1655 for X of V loop 1656 if First_Time then 1657 First_Time := False; 1658 else 1659 Simple_Array_Between (S); 1660 end if; 1661 1662 Element_Type'Put_Image (S, X); 1663 end loop; 1664 1665 Array_After (S); 1666 end Put_Image; 1667 1668 ---------- 1669 -- Read -- 1670 ---------- 1671 1672 procedure Read 1673 (Stream : not null access Root_Stream_Type'Class; 1674 Container : out Set) 1675 is 1676 procedure Read_Element (Node : in out Node_Type); 1677 pragma Inline (Read_Element); 1678 1679 procedure Allocate is 1680 new Tree_Operations.Generic_Allocate (Read_Element); 1681 1682 procedure Read_Elements is 1683 new Tree_Operations.Generic_Read (Allocate); 1684 1685 ------------------ 1686 -- Read_Element -- 1687 ------------------ 1688 1689 procedure Read_Element (Node : in out Node_Type) is 1690 begin 1691 Element_Type'Read (Stream, Node.Element); 1692 end Read_Element; 1693 1694 -- Start of processing for Read 1695 1696 begin 1697 Read_Elements (Stream, Container); 1698 end Read; 1699 1700 procedure Read 1701 (Stream : not null access Root_Stream_Type'Class; 1702 Item : out Cursor) 1703 is 1704 begin 1705 raise Program_Error with "attempt to stream set cursor"; 1706 end Read; 1707 1708 procedure Read 1709 (Stream : not null access Root_Stream_Type'Class; 1710 Item : out Constant_Reference_Type) 1711 is 1712 begin 1713 raise Program_Error with "attempt to stream reference"; 1714 end Read; 1715 1716 ------------- 1717 -- Replace -- 1718 ------------- 1719 1720 procedure Replace (Container : in out Set; New_Item : Element_Type) is 1721 Node : constant Count_Type := Element_Keys.Find (Container, New_Item); 1722 1723 begin 1724 TE_Check (Container.TC); 1725 1726 if Checks and then Node = 0 then 1727 raise Constraint_Error with 1728 "attempt to replace element not in set"; 1729 end if; 1730 1731 Container.Nodes (Node).Element := New_Item; 1732 end Replace; 1733 1734 --------------------- 1735 -- Replace_Element -- 1736 --------------------- 1737 1738 procedure Replace_Element 1739 (Container : in out Set; 1740 Index : Count_Type; 1741 Item : Element_Type) 1742 is 1743 pragma Assert (Index /= 0); 1744 1745 function New_Node return Count_Type; 1746 pragma Inline (New_Node); 1747 1748 procedure Local_Insert_Post is 1749 new Element_Keys.Generic_Insert_Post (New_Node); 1750 1751 procedure Local_Insert_Sans_Hint is 1752 new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); 1753 1754 procedure Local_Insert_With_Hint is 1755 new Element_Keys.Generic_Conditional_Insert_With_Hint 1756 (Local_Insert_Post, 1757 Local_Insert_Sans_Hint); 1758 1759 Nodes : Nodes_Type renames Container.Nodes; 1760 Node : Node_Type renames Nodes (Index); 1761 1762 -------------- 1763 -- New_Node -- 1764 -------------- 1765 1766 function New_Node return Count_Type is 1767 begin 1768 Node.Element := Item; 1769 Node.Color := Red_Black_Trees.Red; 1770 Node.Parent := 0; 1771 Node.Right := 0; 1772 Node.Left := 0; 1773 return Index; 1774 end New_Node; 1775 1776 Hint : Count_Type; 1777 Result : Count_Type; 1778 Inserted : Boolean; 1779 Compare : Boolean; 1780 1781 -- Start of processing for Replace_Element 1782 1783 begin 1784 -- Replace_Element assigns value Item to the element designated by Node, 1785 -- per certain semantic constraints, described as follows. 1786 1787 -- If Item is equivalent to the element, then element is replaced and 1788 -- there's nothing else to do. This is the easy case. 1789 1790 -- If Item is not equivalent, then the node will (possibly) have to move 1791 -- to some other place in the tree. This is slighly more complicated, 1792 -- because we must ensure that Item is not equivalent to some other 1793 -- element in the tree (in which case, the replacement is not allowed). 1794 1795 -- Determine whether Item is equivalent to element on the specified 1796 -- node. 1797 1798 declare 1799 Lock : With_Lock (Container.TC'Unrestricted_Access); 1800 begin 1801 Compare := (if Item < Node.Element then False 1802 elsif Node.Element < Item then False 1803 else True); 1804 end; 1805 1806 if Compare then 1807 1808 -- Item is equivalent to the node's element, so we will not have to 1809 -- move the node. 1810 1811 TE_Check (Container.TC); 1812 1813 Node.Element := Item; 1814 return; 1815 end if; 1816 1817 -- The replacement Item is not equivalent to the element on the 1818 -- specified node, which means that it will need to be re-inserted in a 1819 -- different position in the tree. We must now determine whether Item is 1820 -- equivalent to some other element in the tree (which would prohibit 1821 -- the assignment and hence the move). 1822 1823 -- Ceiling returns the smallest element equivalent or greater than the 1824 -- specified Item; if there is no such element, then it returns 0. 1825 1826 Hint := Element_Keys.Ceiling (Container, Item); 1827 1828 if Hint /= 0 then -- Item <= Nodes (Hint).Element 1829 declare 1830 Lock : With_Lock (Container.TC'Unrestricted_Access); 1831 begin 1832 Compare := Item < Nodes (Hint).Element; 1833 end; 1834 1835 -- Item is equivalent to Nodes (Hint).Element 1836 1837 if Checks and then not Compare then 1838 1839 -- Ceiling returns an element that is equivalent or greater than 1840 -- Item. If Item is "not less than" the element, then by 1841 -- elimination we know that Item is equivalent to the element. 1842 1843 -- But this means that it is not possible to assign the value of 1844 -- Item to the specified element (on Node), because a different 1845 -- element (on Hint) equivalent to Item already exsits. (Were we 1846 -- to change Node's element value, we would have to move Node, but 1847 -- we would be unable to move the Node, because its new position 1848 -- in the tree is already occupied by an equivalent element.) 1849 1850 raise Program_Error with "attempt to replace existing element"; 1851 end if; 1852 1853 -- Item is not equivalent to any other element in the tree 1854 -- (specifically, it is less than Nodes (Hint).Element), so it is 1855 -- safe to assign the value of Item to Node.Element. This means that 1856 -- the node will have to move to a different position in the tree 1857 -- (because its element will have a different value). 1858 1859 -- The nearest (greater) neighbor of Item is Hint. This will be the 1860 -- insertion position of Node (because its element will have Item as 1861 -- its new value). 1862 1863 -- If Node equals Hint, the relative position of Node does not 1864 -- change. This allows us to perform an optimization: we need not 1865 -- remove Node from the tree and then reinsert it with its new value, 1866 -- because it would only be placed in the exact same position. 1867 1868 if Hint = Index then 1869 TE_Check (Container.TC); 1870 1871 Node.Element := Item; 1872 return; 1873 end if; 1874 end if; 1875 1876 -- If we get here, it is because Item was greater than all elements in 1877 -- the tree (Hint = 0), or because Item was less than some element at a 1878 -- different place in the tree (Item < Nodes (Hint).Element and Hint /= 1879 -- Index). In either case, we remove Node from the tree and then insert 1880 -- Item into the tree, onto the same Node. 1881 1882 Tree_Operations.Delete_Node_Sans_Free (Container, Index); 1883 1884 Local_Insert_With_Hint 1885 (Tree => Container, 1886 Position => Hint, 1887 Key => Item, 1888 Node => Result, 1889 Inserted => Inserted); 1890 1891 pragma Assert (Inserted); 1892 pragma Assert (Result = Index); 1893 end Replace_Element; 1894 1895 procedure Replace_Element 1896 (Container : in out Set; 1897 Position : Cursor; 1898 New_Item : Element_Type) 1899 is 1900 begin 1901 if Checks and then Position.Node = 0 then 1902 raise Constraint_Error with 1903 "Position cursor equals No_Element"; 1904 end if; 1905 1906 if Checks and then Position.Container /= Container'Unrestricted_Access 1907 then 1908 raise Program_Error with 1909 "Position cursor designates wrong set"; 1910 end if; 1911 1912 pragma Assert (Vet (Container, Position.Node), 1913 "bad cursor in Replace_Element"); 1914 1915 Replace_Element (Container, Position.Node, New_Item); 1916 end Replace_Element; 1917 1918 --------------------- 1919 -- Reverse_Iterate -- 1920 --------------------- 1921 1922 procedure Reverse_Iterate 1923 (Container : Set; 1924 Process : not null access procedure (Position : Cursor)) 1925 is 1926 procedure Process_Node (Node : Count_Type); 1927 pragma Inline (Process_Node); 1928 1929 procedure Local_Reverse_Iterate is 1930 new Tree_Operations.Generic_Reverse_Iteration (Process_Node); 1931 1932 ------------------ 1933 -- Process_Node -- 1934 ------------------ 1935 1936 procedure Process_Node (Node : Count_Type) is 1937 begin 1938 Process (Cursor'(Container'Unrestricted_Access, Node)); 1939 end Process_Node; 1940 1941 S : Set renames Container'Unrestricted_Access.all; 1942 Busy : With_Busy (S.TC'Unrestricted_Access); 1943 1944 -- Start of processing for Reverse_Iterate 1945 1946 begin 1947 Local_Reverse_Iterate (S); 1948 end Reverse_Iterate; 1949 1950 ----------- 1951 -- Right -- 1952 ----------- 1953 1954 function Right (Node : Node_Type) return Count_Type is 1955 begin 1956 return Node.Right; 1957 end Right; 1958 1959 --------------- 1960 -- Set_Color -- 1961 --------------- 1962 1963 procedure Set_Color 1964 (Node : in out Node_Type; 1965 Color : Red_Black_Trees.Color_Type) 1966 is 1967 begin 1968 Node.Color := Color; 1969 end Set_Color; 1970 1971 -------------- 1972 -- Set_Left -- 1973 -------------- 1974 1975 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is 1976 begin 1977 Node.Left := Left; 1978 end Set_Left; 1979 1980 ---------------- 1981 -- Set_Parent -- 1982 ---------------- 1983 1984 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is 1985 begin 1986 Node.Parent := Parent; 1987 end Set_Parent; 1988 1989 --------------- 1990 -- Set_Right -- 1991 --------------- 1992 1993 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is 1994 begin 1995 Node.Right := Right; 1996 end Set_Right; 1997 1998 -------------------------- 1999 -- Symmetric_Difference -- 2000 -------------------------- 2001 2002 procedure Symmetric_Difference (Target : in out Set; Source : Set) 2003 renames Set_Ops.Set_Symmetric_Difference; 2004 2005 function Symmetric_Difference (Left, Right : Set) return Set 2006 renames Set_Ops.Set_Symmetric_Difference; 2007 2008 ------------ 2009 -- To_Set -- 2010 ------------ 2011 2012 function To_Set (New_Item : Element_Type) return Set is 2013 Node : Count_Type; 2014 Inserted : Boolean; 2015 begin 2016 return S : Set (1) do 2017 Insert_Sans_Hint (S, New_Item, Node, Inserted); 2018 pragma Assert (Inserted); 2019 end return; 2020 end To_Set; 2021 2022 ----------- 2023 -- Union -- 2024 ----------- 2025 2026 procedure Union (Target : in out Set; Source : Set) 2027 renames Set_Ops.Set_Union; 2028 2029 function Union (Left, Right : Set) return Set 2030 renames Set_Ops.Set_Union; 2031 2032 ----------- 2033 -- Write -- 2034 ----------- 2035 2036 procedure Write 2037 (Stream : not null access Root_Stream_Type'Class; 2038 Container : Set) 2039 is 2040 procedure Write_Element 2041 (Stream : not null access Root_Stream_Type'Class; 2042 Node : Node_Type); 2043 pragma Inline (Write_Element); 2044 2045 procedure Write_Elements is 2046 new Tree_Operations.Generic_Write (Write_Element); 2047 2048 ------------------- 2049 -- Write_Element -- 2050 ------------------- 2051 2052 procedure Write_Element 2053 (Stream : not null access Root_Stream_Type'Class; 2054 Node : Node_Type) 2055 is 2056 begin 2057 Element_Type'Write (Stream, Node.Element); 2058 end Write_Element; 2059 2060 -- Start of processing for Write 2061 2062 begin 2063 Write_Elements (Stream, Container); 2064 end Write; 2065 2066 procedure Write 2067 (Stream : not null access Root_Stream_Type'Class; 2068 Item : Cursor) 2069 is 2070 begin 2071 raise Program_Error with "attempt to stream set cursor"; 2072 end Write; 2073 2074 procedure Write 2075 (Stream : not null access Root_Stream_Type'Class; 2076 Item : Constant_Reference_Type) 2077 is 2078 begin 2079 raise Program_Error with "attempt to stream reference"; 2080 end Write; 2081 2082end Ada.Containers.Bounded_Ordered_Sets; 2083