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