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