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 _ M A P S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-2018, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- This unit was originally developed by Matthew J Heaney. -- 28------------------------------------------------------------------------------ 29 30with Ada.Containers.Helpers; use Ada.Containers.Helpers; 31 32with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; 33pragma Elaborate_All 34 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); 35 36with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; 37pragma Elaborate_All 38 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); 39 40with System; use type System.Address; 41 42package body Ada.Containers.Bounded_Ordered_Maps is 43 44 pragma Warnings (Off, "variable ""Busy*"" is not referenced"); 45 pragma Warnings (Off, "variable ""Lock*"" is not referenced"); 46 -- See comment in Ada.Containers.Helpers 47 48 ----------------------------- 49 -- Node Access Subprograms -- 50 ----------------------------- 51 52 -- These subprograms provide a functional interface to access fields 53 -- of a node, and a procedural interface for modifying these values. 54 55 function Color (Node : Node_Type) return Color_Type; 56 pragma Inline (Color); 57 58 function Left (Node : Node_Type) return Count_Type; 59 pragma Inline (Left); 60 61 function Parent (Node : Node_Type) return Count_Type; 62 pragma Inline (Parent); 63 64 function Right (Node : Node_Type) return Count_Type; 65 pragma Inline (Right); 66 67 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); 68 pragma Inline (Set_Parent); 69 70 procedure Set_Left (Node : in out Node_Type; Left : Count_Type); 71 pragma Inline (Set_Left); 72 73 procedure Set_Right (Node : in out Node_Type; Right : Count_Type); 74 pragma Inline (Set_Right); 75 76 procedure Set_Color (Node : in out Node_Type; Color : Color_Type); 77 pragma Inline (Set_Color); 78 79 ----------------------- 80 -- Local Subprograms -- 81 ----------------------- 82 83 function Is_Greater_Key_Node 84 (Left : Key_Type; 85 Right : Node_Type) return Boolean; 86 pragma Inline (Is_Greater_Key_Node); 87 88 function Is_Less_Key_Node 89 (Left : Key_Type; 90 Right : Node_Type) return Boolean; 91 pragma Inline (Is_Less_Key_Node); 92 93 -------------------------- 94 -- Local Instantiations -- 95 -------------------------- 96 97 package Tree_Operations is 98 new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types); 99 100 use Tree_Operations; 101 102 package Key_Ops is 103 new Red_Black_Trees.Generic_Bounded_Keys 104 (Tree_Operations => Tree_Operations, 105 Key_Type => Key_Type, 106 Is_Less_Key_Node => Is_Less_Key_Node, 107 Is_Greater_Key_Node => Is_Greater_Key_Node); 108 109 --------- 110 -- "<" -- 111 --------- 112 113 function "<" (Left, Right : Cursor) return Boolean is 114 begin 115 if Checks and then Left.Node = 0 then 116 raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; 117 end if; 118 119 if Checks and then Right.Node = 0 then 120 raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; 121 end if; 122 123 pragma Assert (Vet (Left.Container.all, Left.Node), 124 "Left cursor of ""<"" is bad"); 125 126 pragma Assert (Vet (Right.Container.all, Right.Node), 127 "Right cursor of ""<"" is bad"); 128 129 declare 130 LN : Node_Type renames Left.Container.Nodes (Left.Node); 131 RN : Node_Type renames Right.Container.Nodes (Right.Node); 132 133 begin 134 return LN.Key < RN.Key; 135 end; 136 end "<"; 137 138 function "<" (Left : Cursor; Right : Key_Type) return Boolean is 139 begin 140 if Checks and then Left.Node = 0 then 141 raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; 142 end if; 143 144 pragma Assert (Vet (Left.Container.all, Left.Node), 145 "Left cursor of ""<"" is bad"); 146 147 declare 148 LN : Node_Type renames Left.Container.Nodes (Left.Node); 149 150 begin 151 return LN.Key < Right; 152 end; 153 end "<"; 154 155 function "<" (Left : Key_Type; Right : Cursor) return Boolean is 156 begin 157 if Checks and then Right.Node = 0 then 158 raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; 159 end if; 160 161 pragma Assert (Vet (Right.Container.all, Right.Node), 162 "Right cursor of ""<"" is bad"); 163 164 declare 165 RN : Node_Type renames Right.Container.Nodes (Right.Node); 166 167 begin 168 return Left < RN.Key; 169 end; 170 end "<"; 171 172 --------- 173 -- "=" -- 174 --------- 175 176 function "=" (Left, Right : Map) return Boolean is 177 function Is_Equal_Node_Node (L, R : Node_Type) return Boolean; 178 pragma Inline (Is_Equal_Node_Node); 179 180 function Is_Equal is 181 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); 182 183 ------------------------ 184 -- Is_Equal_Node_Node -- 185 ------------------------ 186 187 function Is_Equal_Node_Node 188 (L, R : Node_Type) return Boolean is 189 begin 190 if L.Key < R.Key then 191 return False; 192 193 elsif R.Key < L.Key then 194 return False; 195 196 else 197 return L.Element = R.Element; 198 end if; 199 end Is_Equal_Node_Node; 200 201 -- Start of processing for "=" 202 203 begin 204 return Is_Equal (Left, Right); 205 end "="; 206 207 --------- 208 -- ">" -- 209 --------- 210 211 function ">" (Left, Right : Cursor) return Boolean is 212 begin 213 if Checks and then Left.Node = 0 then 214 raise Constraint_Error with "Left cursor of "">"" equals No_Element"; 215 end if; 216 217 if Checks and then Right.Node = 0 then 218 raise Constraint_Error with "Right cursor of "">"" equals No_Element"; 219 end if; 220 221 pragma Assert (Vet (Left.Container.all, Left.Node), 222 "Left cursor of "">"" is bad"); 223 224 pragma Assert (Vet (Right.Container.all, Right.Node), 225 "Right cursor of "">"" is bad"); 226 227 declare 228 LN : Node_Type renames Left.Container.Nodes (Left.Node); 229 RN : Node_Type renames Right.Container.Nodes (Right.Node); 230 231 begin 232 return RN.Key < LN.Key; 233 end; 234 end ">"; 235 236 function ">" (Left : Cursor; Right : Key_Type) return Boolean is 237 begin 238 if Checks and then Left.Node = 0 then 239 raise Constraint_Error with "Left cursor of "">"" equals No_Element"; 240 end if; 241 242 pragma Assert (Vet (Left.Container.all, Left.Node), 243 "Left cursor of "">"" is bad"); 244 245 declare 246 LN : Node_Type renames Left.Container.Nodes (Left.Node); 247 begin 248 return Right < LN.Key; 249 end; 250 end ">"; 251 252 function ">" (Left : Key_Type; Right : Cursor) return Boolean is 253 begin 254 if Checks and then Right.Node = 0 then 255 raise Constraint_Error with "Right cursor of "">"" equals No_Element"; 256 end if; 257 258 pragma Assert (Vet (Right.Container.all, Right.Node), 259 "Right cursor of "">"" is bad"); 260 261 declare 262 RN : Node_Type renames Right.Container.Nodes (Right.Node); 263 264 begin 265 return RN.Key < Left; 266 end; 267 end ">"; 268 269 ------------ 270 -- Assign -- 271 ------------ 272 273 procedure Assign (Target : in out Map; Source : Map) is 274 procedure Append_Element (Source_Node : Count_Type); 275 276 procedure Append_Elements is 277 new Tree_Operations.Generic_Iteration (Append_Element); 278 279 -------------------- 280 -- Append_Element -- 281 -------------------- 282 283 procedure Append_Element (Source_Node : Count_Type) is 284 SN : Node_Type renames Source.Nodes (Source_Node); 285 286 procedure Set_Element (Node : in out Node_Type); 287 pragma Inline (Set_Element); 288 289 function New_Node return Count_Type; 290 pragma Inline (New_Node); 291 292 procedure Insert_Post is 293 new Key_Ops.Generic_Insert_Post (New_Node); 294 295 procedure Unconditional_Insert_Sans_Hint is 296 new Key_Ops.Generic_Unconditional_Insert (Insert_Post); 297 298 procedure Unconditional_Insert_Avec_Hint is 299 new Key_Ops.Generic_Unconditional_Insert_With_Hint 300 (Insert_Post, 301 Unconditional_Insert_Sans_Hint); 302 303 procedure Allocate is 304 new Tree_Operations.Generic_Allocate (Set_Element); 305 306 -------------- 307 -- New_Node -- 308 -------------- 309 310 function New_Node return Count_Type is 311 Result : Count_Type; 312 313 begin 314 Allocate (Target, Result); 315 return Result; 316 end New_Node; 317 318 ----------------- 319 -- Set_Element -- 320 ----------------- 321 322 procedure Set_Element (Node : in out Node_Type) is 323 begin 324 Node.Key := SN.Key; 325 Node.Element := SN.Element; 326 end Set_Element; 327 328 Target_Node : Count_Type; 329 330 -- Start of processing for Append_Element 331 332 begin 333 Unconditional_Insert_Avec_Hint 334 (Tree => Target, 335 Hint => 0, 336 Key => SN.Key, 337 Node => Target_Node); 338 end Append_Element; 339 340 -- Start of processing for Assign 341 342 begin 343 if Target'Address = Source'Address then 344 return; 345 end if; 346 347 if Checks and then Target.Capacity < Source.Length then 348 raise Capacity_Error 349 with "Target capacity is less than Source length"; 350 end if; 351 352 Tree_Operations.Clear_Tree (Target); 353 Append_Elements (Source); 354 end Assign; 355 356 ------------- 357 -- Ceiling -- 358 ------------- 359 360 function Ceiling (Container : Map; Key : Key_Type) return Cursor is 361 Node : constant Count_Type := Key_Ops.Ceiling (Container, Key); 362 363 begin 364 if Node = 0 then 365 return No_Element; 366 end if; 367 368 return Cursor'(Container'Unrestricted_Access, Node); 369 end Ceiling; 370 371 ----------- 372 -- Clear -- 373 ----------- 374 375 procedure Clear (Container : in out Map) is 376 begin 377 Tree_Operations.Clear_Tree (Container); 378 end Clear; 379 380 ----------- 381 -- Color -- 382 ----------- 383 384 function Color (Node : Node_Type) return Color_Type is 385 begin 386 return Node.Color; 387 end Color; 388 389 ------------------------ 390 -- Constant_Reference -- 391 ------------------------ 392 393 function Constant_Reference 394 (Container : aliased Map; 395 Position : Cursor) return Constant_Reference_Type 396 is 397 begin 398 if Checks and then Position.Container = null then 399 raise Constraint_Error with 400 "Position cursor has no element"; 401 end if; 402 403 if Checks and then Position.Container /= Container'Unrestricted_Access 404 then 405 raise Program_Error with 406 "Position cursor designates wrong map"; 407 end if; 408 409 pragma Assert (Vet (Container, Position.Node), 410 "Position cursor in Constant_Reference is bad"); 411 412 declare 413 N : Node_Type renames Container.Nodes (Position.Node); 414 TC : constant Tamper_Counts_Access := 415 Container.TC'Unrestricted_Access; 416 begin 417 return R : constant Constant_Reference_Type := 418 (Element => N.Element'Access, 419 Control => (Controlled with TC)) 420 do 421 Lock (TC.all); 422 end return; 423 end; 424 end Constant_Reference; 425 426 function Constant_Reference 427 (Container : aliased Map; 428 Key : Key_Type) return Constant_Reference_Type 429 is 430 Node : constant Count_Type := Key_Ops.Find (Container, Key); 431 432 begin 433 if Checks and then Node = 0 then 434 raise Constraint_Error with "key not in map"; 435 end if; 436 437 declare 438 N : Node_Type renames Container.Nodes (Node); 439 TC : constant Tamper_Counts_Access := 440 Container.TC'Unrestricted_Access; 441 begin 442 return R : constant Constant_Reference_Type := 443 (Element => N.Element'Access, 444 Control => (Controlled with TC)) 445 do 446 Lock (TC.all); 447 end return; 448 end; 449 end Constant_Reference; 450 451 -------------- 452 -- Contains -- 453 -------------- 454 455 function Contains (Container : Map; Key : Key_Type) return Boolean is 456 begin 457 return Find (Container, Key) /= No_Element; 458 end Contains; 459 460 ---------- 461 -- Copy -- 462 ---------- 463 464 function Copy (Source : Map; Capacity : Count_Type := 0) return Map is 465 C : Count_Type; 466 467 begin 468 if Capacity = 0 then 469 C := Source.Length; 470 471 elsif Capacity >= Source.Length then 472 C := Capacity; 473 474 elsif Checks then 475 raise Capacity_Error with "Capacity value too small"; 476 end if; 477 478 return Target : Map (Capacity => C) do 479 Assign (Target => Target, Source => Source); 480 end return; 481 end Copy; 482 483 ------------ 484 -- Delete -- 485 ------------ 486 487 procedure Delete (Container : in out Map; Position : in out Cursor) is 488 begin 489 if Checks and then Position.Node = 0 then 490 raise Constraint_Error with 491 "Position cursor of Delete equals No_Element"; 492 end if; 493 494 if Checks and then Position.Container /= Container'Unrestricted_Access 495 then 496 raise Program_Error with 497 "Position cursor of Delete designates wrong map"; 498 end if; 499 500 pragma Assert (Vet (Container, Position.Node), 501 "Position cursor of Delete is bad"); 502 503 Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); 504 Tree_Operations.Free (Container, Position.Node); 505 506 Position := No_Element; 507 end Delete; 508 509 procedure Delete (Container : in out Map; Key : Key_Type) is 510 X : constant Count_Type := Key_Ops.Find (Container, Key); 511 512 begin 513 if Checks and then X = 0 then 514 raise Constraint_Error with "key not in map"; 515 end if; 516 517 Tree_Operations.Delete_Node_Sans_Free (Container, X); 518 Tree_Operations.Free (Container, X); 519 end Delete; 520 521 ------------------ 522 -- Delete_First -- 523 ------------------ 524 525 procedure Delete_First (Container : in out Map) is 526 X : constant Count_Type := Container.First; 527 528 begin 529 if X /= 0 then 530 Tree_Operations.Delete_Node_Sans_Free (Container, X); 531 Tree_Operations.Free (Container, X); 532 end if; 533 end Delete_First; 534 535 ----------------- 536 -- Delete_Last -- 537 ----------------- 538 539 procedure Delete_Last (Container : in out Map) is 540 X : constant Count_Type := Container.Last; 541 542 begin 543 if X /= 0 then 544 Tree_Operations.Delete_Node_Sans_Free (Container, X); 545 Tree_Operations.Free (Container, X); 546 end if; 547 end Delete_Last; 548 549 ------------- 550 -- Element -- 551 ------------- 552 553 function Element (Position : Cursor) return Element_Type is 554 begin 555 if Checks and then Position.Node = 0 then 556 raise Constraint_Error with 557 "Position cursor of function Element equals No_Element"; 558 end if; 559 560 pragma Assert (Vet (Position.Container.all, Position.Node), 561 "Position cursor of function Element is bad"); 562 563 return Position.Container.Nodes (Position.Node).Element; 564 end Element; 565 566 function Element (Container : Map; Key : Key_Type) return Element_Type is 567 Node : constant Count_Type := Key_Ops.Find (Container, Key); 568 begin 569 if Checks and then Node = 0 then 570 raise Constraint_Error with "key not in map"; 571 end if; 572 573 return Container.Nodes (Node).Element; 574 end Element; 575 576 --------------------- 577 -- Equivalent_Keys -- 578 --------------------- 579 580 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is 581 begin 582 if Left < Right 583 or else Right < Left 584 then 585 return False; 586 else 587 return True; 588 end if; 589 end Equivalent_Keys; 590 591 ------------- 592 -- Exclude -- 593 ------------- 594 595 procedure Exclude (Container : in out Map; Key : Key_Type) is 596 X : constant Count_Type := Key_Ops.Find (Container, Key); 597 598 begin 599 if X /= 0 then 600 Tree_Operations.Delete_Node_Sans_Free (Container, X); 601 Tree_Operations.Free (Container, X); 602 end if; 603 end Exclude; 604 605 -------------- 606 -- Finalize -- 607 -------------- 608 609 procedure Finalize (Object : in out Iterator) is 610 begin 611 if Object.Container /= null then 612 Unbusy (Object.Container.TC); 613 end if; 614 end Finalize; 615 616 ---------- 617 -- Find -- 618 ---------- 619 620 function Find (Container : Map; Key : Key_Type) return Cursor is 621 Node : constant Count_Type := Key_Ops.Find (Container, Key); 622 begin 623 if Node = 0 then 624 return No_Element; 625 else 626 return Cursor'(Container'Unrestricted_Access, Node); 627 end if; 628 end Find; 629 630 ----------- 631 -- First -- 632 ----------- 633 634 function First (Container : Map) return Cursor is 635 begin 636 if Container.First = 0 then 637 return No_Element; 638 else 639 return Cursor'(Container'Unrestricted_Access, Container.First); 640 end if; 641 end First; 642 643 function First (Object : Iterator) return Cursor is 644 begin 645 -- The value of the iterator object's Node component influences the 646 -- behavior of the First (and Last) selector function. 647 648 -- When the Node component is 0, this means the iterator object was 649 -- constructed without a start expression, in which case the (forward) 650 -- iteration starts from the (logical) beginning of the entire sequence 651 -- of items (corresponding to Container.First, for a forward iterator). 652 653 -- Otherwise, this is iteration over a partial sequence of items. When 654 -- the Node component is positive, the iterator object was constructed 655 -- with a start expression, that specifies the position from which the 656 -- (forward) partial iteration begins. 657 658 if Object.Node = 0 then 659 return Bounded_Ordered_Maps.First (Object.Container.all); 660 else 661 return Cursor'(Object.Container, Object.Node); 662 end if; 663 end First; 664 665 ------------------- 666 -- First_Element -- 667 ------------------- 668 669 function First_Element (Container : Map) return Element_Type is 670 begin 671 if Checks and then Container.First = 0 then 672 raise Constraint_Error with "map is empty"; 673 end if; 674 675 return Container.Nodes (Container.First).Element; 676 end First_Element; 677 678 --------------- 679 -- First_Key -- 680 --------------- 681 682 function First_Key (Container : Map) return Key_Type is 683 begin 684 if Checks and then Container.First = 0 then 685 raise Constraint_Error with "map is empty"; 686 end if; 687 688 return Container.Nodes (Container.First).Key; 689 end First_Key; 690 691 ----------- 692 -- Floor -- 693 ----------- 694 695 function Floor (Container : Map; Key : Key_Type) return Cursor is 696 Node : constant Count_Type := Key_Ops.Floor (Container, Key); 697 begin 698 if Node = 0 then 699 return No_Element; 700 else 701 return Cursor'(Container'Unrestricted_Access, Node); 702 end if; 703 end Floor; 704 705 ------------------------ 706 -- Get_Element_Access -- 707 ------------------------ 708 709 function Get_Element_Access 710 (Position : Cursor) return not null Element_Access is 711 begin 712 return Position.Container.Nodes (Position.Node).Element'Access; 713 end Get_Element_Access; 714 715 ----------------- 716 -- Has_Element -- 717 ----------------- 718 719 function Has_Element (Position : Cursor) return Boolean is 720 begin 721 return Position /= No_Element; 722 end Has_Element; 723 724 ------------- 725 -- Include -- 726 ------------- 727 728 procedure Include 729 (Container : in out Map; 730 Key : Key_Type; 731 New_Item : Element_Type) 732 is 733 Position : Cursor; 734 Inserted : Boolean; 735 736 begin 737 Insert (Container, Key, New_Item, Position, Inserted); 738 739 if not Inserted then 740 TE_Check (Container.TC); 741 742 declare 743 N : Node_Type renames Container.Nodes (Position.Node); 744 begin 745 N.Key := Key; 746 N.Element := New_Item; 747 end; 748 end if; 749 end Include; 750 751 ------------ 752 -- Insert -- 753 ------------ 754 755 procedure Insert 756 (Container : in out Map; 757 Key : Key_Type; 758 New_Item : Element_Type; 759 Position : out Cursor; 760 Inserted : out Boolean) 761 is 762 procedure Assign (Node : in out Node_Type); 763 pragma Inline (Assign); 764 765 function New_Node return Count_Type; 766 pragma Inline (New_Node); 767 768 procedure Insert_Post is 769 new Key_Ops.Generic_Insert_Post (New_Node); 770 771 procedure Insert_Sans_Hint is 772 new Key_Ops.Generic_Conditional_Insert (Insert_Post); 773 774 procedure Allocate is 775 new Tree_Operations.Generic_Allocate (Assign); 776 777 ------------ 778 -- Assign -- 779 ------------ 780 781 procedure Assign (Node : in out Node_Type) is 782 begin 783 Node.Key := Key; 784 Node.Element := New_Item; 785 end Assign; 786 787 -------------- 788 -- New_Node -- 789 -------------- 790 791 function New_Node return Count_Type is 792 Result : Count_Type; 793 begin 794 Allocate (Container, Result); 795 return Result; 796 end New_Node; 797 798 -- Start of processing for Insert 799 800 begin 801 Insert_Sans_Hint 802 (Container, 803 Key, 804 Position.Node, 805 Inserted); 806 807 Position.Container := Container'Unrestricted_Access; 808 end Insert; 809 810 procedure Insert 811 (Container : in out Map; 812 Key : Key_Type; 813 New_Item : Element_Type) 814 is 815 Position : Cursor; 816 pragma Unreferenced (Position); 817 818 Inserted : Boolean; 819 820 begin 821 Insert (Container, Key, New_Item, Position, Inserted); 822 823 if Checks and then not Inserted then 824 raise Constraint_Error with "key already in map"; 825 end if; 826 end Insert; 827 828 procedure Insert 829 (Container : in out Map; 830 Key : Key_Type; 831 Position : out Cursor; 832 Inserted : out Boolean) 833 is 834 procedure Assign (Node : in out Node_Type); 835 pragma Inline (Assign); 836 837 function New_Node return Count_Type; 838 pragma Inline (New_Node); 839 840 procedure Insert_Post is 841 new Key_Ops.Generic_Insert_Post (New_Node); 842 843 procedure Insert_Sans_Hint is 844 new Key_Ops.Generic_Conditional_Insert (Insert_Post); 845 846 procedure Allocate is 847 new Tree_Operations.Generic_Allocate (Assign); 848 849 ------------ 850 -- Assign -- 851 ------------ 852 853 procedure Assign (Node : in out Node_Type) is 854 pragma Warnings (Off); 855 Default_Initialized_Item : Element_Type; 856 pragma Unmodified (Default_Initialized_Item); 857 -- Default-initialized element (ok to reference, see below) 858 859 begin 860 Node.Key := Key; 861 862 -- There is no explicit element provided, but in an instance the element 863 -- type may be a scalar with a Default_Value aspect, or a composite type 864 -- with such a scalar component or with defaulted components, so insert 865 -- possibly initialized elements at the given position. 866 867 Node.Element := Default_Initialized_Item; 868 pragma Warnings (On); 869 end Assign; 870 871 -------------- 872 -- New_Node -- 873 -------------- 874 875 function New_Node return Count_Type is 876 Result : Count_Type; 877 begin 878 Allocate (Container, Result); 879 return Result; 880 end New_Node; 881 882 -- Start of processing for Insert 883 884 begin 885 Insert_Sans_Hint 886 (Container, 887 Key, 888 Position.Node, 889 Inserted); 890 891 Position.Container := Container'Unrestricted_Access; 892 end Insert; 893 894 -------------- 895 -- Is_Empty -- 896 -------------- 897 898 function Is_Empty (Container : Map) return Boolean is 899 begin 900 return Container.Length = 0; 901 end Is_Empty; 902 903 ------------------------- 904 -- Is_Greater_Key_Node -- 905 ------------------------- 906 907 function Is_Greater_Key_Node 908 (Left : Key_Type; 909 Right : Node_Type) return Boolean 910 is 911 begin 912 -- Left > Right same as Right < Left 913 914 return Right.Key < Left; 915 end Is_Greater_Key_Node; 916 917 ---------------------- 918 -- Is_Less_Key_Node -- 919 ---------------------- 920 921 function Is_Less_Key_Node 922 (Left : Key_Type; 923 Right : Node_Type) return Boolean 924 is 925 begin 926 return Left < Right.Key; 927 end Is_Less_Key_Node; 928 929 ------------- 930 -- Iterate -- 931 ------------- 932 933 procedure Iterate 934 (Container : Map; 935 Process : not null access procedure (Position : Cursor)) 936 is 937 procedure Process_Node (Node : Count_Type); 938 pragma Inline (Process_Node); 939 940 procedure Local_Iterate is 941 new Tree_Operations.Generic_Iteration (Process_Node); 942 943 ------------------ 944 -- Process_Node -- 945 ------------------ 946 947 procedure Process_Node (Node : Count_Type) is 948 begin 949 Process (Cursor'(Container'Unrestricted_Access, Node)); 950 end Process_Node; 951 952 Busy : With_Busy (Container.TC'Unrestricted_Access); 953 954 -- Start of processing for Iterate 955 956 begin 957 Local_Iterate (Container); 958 end Iterate; 959 960 function Iterate 961 (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class 962 is 963 begin 964 -- The value of the Node component influences the behavior of the First 965 -- and Last selector functions of the iterator object. When the Node 966 -- component is 0 (as is the case here), this means the iterator object 967 -- was constructed without a start expression. This is a complete 968 -- iterator, meaning that the iteration starts from the (logical) 969 -- beginning of the sequence of items. 970 971 -- Note: For a forward iterator, Container.First is the beginning, and 972 -- for a reverse iterator, Container.Last is the beginning. 973 974 return It : constant Iterator := 975 (Limited_Controlled with 976 Container => Container'Unrestricted_Access, 977 Node => 0) 978 do 979 Busy (Container.TC'Unrestricted_Access.all); 980 end return; 981 end Iterate; 982 983 function Iterate 984 (Container : Map; 985 Start : Cursor) 986 return Map_Iterator_Interfaces.Reversible_Iterator'Class 987 is 988 begin 989 -- Iterator was defined to behave the same as for a complete iterator, 990 -- and iterate over the entire sequence of items. However, those 991 -- semantics were unintuitive and arguably error-prone (it is too easy 992 -- to accidentally create an endless loop), and so they were changed, 993 -- per the ARG meeting in Denver on 2011/11. However, there was no 994 -- consensus about what positive meaning this corner case should have, 995 -- and so it was decided to simply raise an exception. This does imply, 996 -- however, that it is not possible to use a partial iterator to specify 997 -- an empty sequence of items. 998 999 if Checks and then Start = No_Element then 1000 raise Constraint_Error with 1001 "Start position for iterator equals No_Element"; 1002 end if; 1003 1004 if Checks and then Start.Container /= Container'Unrestricted_Access then 1005 raise Program_Error with 1006 "Start cursor of Iterate designates wrong map"; 1007 end if; 1008 1009 pragma Assert (Vet (Container, Start.Node), 1010 "Start cursor of Iterate is bad"); 1011 1012 -- The value of the Node component influences the behavior of the First 1013 -- and Last selector functions of the iterator object. When the Node 1014 -- component is positive (as is the case here), it means that this 1015 -- is a partial iteration, over a subset of the complete sequence of 1016 -- items. The iterator object was constructed with a start expression, 1017 -- indicating the position from which the iteration begins. (Note that 1018 -- the start position has the same value irrespective of whether this 1019 -- is a forward or reverse iteration.) 1020 1021 return It : constant Iterator := 1022 (Limited_Controlled with 1023 Container => Container'Unrestricted_Access, 1024 Node => Start.Node) 1025 do 1026 Busy (Container.TC'Unrestricted_Access.all); 1027 end return; 1028 end Iterate; 1029 1030 --------- 1031 -- Key -- 1032 --------- 1033 1034 function Key (Position : Cursor) return Key_Type is 1035 begin 1036 if Checks and then Position.Node = 0 then 1037 raise Constraint_Error with 1038 "Position cursor of function Key equals No_Element"; 1039 end if; 1040 1041 pragma Assert (Vet (Position.Container.all, Position.Node), 1042 "Position cursor of function Key is bad"); 1043 1044 return Position.Container.Nodes (Position.Node).Key; 1045 end Key; 1046 1047 ---------- 1048 -- Last -- 1049 ---------- 1050 1051 function Last (Container : Map) return Cursor is 1052 begin 1053 if Container.Last = 0 then 1054 return No_Element; 1055 else 1056 return Cursor'(Container'Unrestricted_Access, Container.Last); 1057 end if; 1058 end Last; 1059 1060 function Last (Object : Iterator) return Cursor is 1061 begin 1062 -- The value of the iterator object's Node component influences the 1063 -- behavior of the Last (and First) selector function. 1064 1065 -- When the Node component is 0, this means the iterator object was 1066 -- constructed without a start expression, in which case the (reverse) 1067 -- iteration starts from the (logical) beginning of the entire sequence 1068 -- (corresponding to Container.Last, for a reverse iterator). 1069 1070 -- Otherwise, this is iteration over a partial sequence of items. When 1071 -- the Node component is positive, the iterator object was constructed 1072 -- with a start expression, that specifies the position from which the 1073 -- (reverse) partial iteration begins. 1074 1075 if Object.Node = 0 then 1076 return Bounded_Ordered_Maps.Last (Object.Container.all); 1077 else 1078 return Cursor'(Object.Container, Object.Node); 1079 end if; 1080 end Last; 1081 1082 ------------------ 1083 -- Last_Element -- 1084 ------------------ 1085 1086 function Last_Element (Container : Map) return Element_Type is 1087 begin 1088 if Checks and then Container.Last = 0 then 1089 raise Constraint_Error with "map is empty"; 1090 end if; 1091 1092 return Container.Nodes (Container.Last).Element; 1093 end Last_Element; 1094 1095 -------------- 1096 -- Last_Key -- 1097 -------------- 1098 1099 function Last_Key (Container : Map) return Key_Type is 1100 begin 1101 if Checks and then Container.Last = 0 then 1102 raise Constraint_Error with "map is empty"; 1103 end if; 1104 1105 return Container.Nodes (Container.Last).Key; 1106 end Last_Key; 1107 1108 ---------- 1109 -- Left -- 1110 ---------- 1111 1112 function Left (Node : Node_Type) return Count_Type is 1113 begin 1114 return Node.Left; 1115 end Left; 1116 1117 ------------ 1118 -- Length -- 1119 ------------ 1120 1121 function Length (Container : Map) return Count_Type is 1122 begin 1123 return Container.Length; 1124 end Length; 1125 1126 ---------- 1127 -- Move -- 1128 ---------- 1129 1130 procedure Move (Target : in out Map; Source : in out Map) is 1131 begin 1132 if Target'Address = Source'Address then 1133 return; 1134 end if; 1135 1136 TC_Check (Source.TC); 1137 1138 Target.Assign (Source); 1139 Source.Clear; 1140 end Move; 1141 1142 ---------- 1143 -- Next -- 1144 ---------- 1145 1146 procedure Next (Position : in out Cursor) is 1147 begin 1148 Position := Next (Position); 1149 end Next; 1150 1151 function Next (Position : Cursor) return Cursor is 1152 begin 1153 if Position = No_Element then 1154 return No_Element; 1155 end if; 1156 1157 pragma Assert (Vet (Position.Container.all, Position.Node), 1158 "Position cursor of Next is bad"); 1159 1160 declare 1161 M : Map renames Position.Container.all; 1162 1163 Node : constant Count_Type := 1164 Tree_Operations.Next (M, Position.Node); 1165 1166 begin 1167 if Node = 0 then 1168 return No_Element; 1169 end if; 1170 1171 return Cursor'(Position.Container, Node); 1172 end; 1173 end Next; 1174 1175 function Next 1176 (Object : Iterator; 1177 Position : Cursor) return Cursor 1178 is 1179 begin 1180 if Position.Container = null then 1181 return No_Element; 1182 end if; 1183 1184 if Checks and then Position.Container /= Object.Container then 1185 raise Program_Error with 1186 "Position cursor of Next designates wrong map"; 1187 end if; 1188 1189 return Next (Position); 1190 end Next; 1191 1192 ------------ 1193 -- Parent -- 1194 ------------ 1195 1196 function Parent (Node : Node_Type) return Count_Type is 1197 begin 1198 return Node.Parent; 1199 end Parent; 1200 1201 -------------- 1202 -- Previous -- 1203 -------------- 1204 1205 procedure Previous (Position : in out Cursor) is 1206 begin 1207 Position := Previous (Position); 1208 end Previous; 1209 1210 function Previous (Position : Cursor) return Cursor is 1211 begin 1212 if Position = No_Element then 1213 return No_Element; 1214 end if; 1215 1216 pragma Assert (Vet (Position.Container.all, Position.Node), 1217 "Position cursor of Previous is bad"); 1218 1219 declare 1220 M : Map renames Position.Container.all; 1221 1222 Node : constant Count_Type := 1223 Tree_Operations.Previous (M, Position.Node); 1224 1225 begin 1226 if Node = 0 then 1227 return No_Element; 1228 end if; 1229 1230 return Cursor'(Position.Container, Node); 1231 end; 1232 end Previous; 1233 1234 function Previous 1235 (Object : Iterator; 1236 Position : Cursor) return Cursor 1237 is 1238 begin 1239 if Position.Container = null then 1240 return No_Element; 1241 end if; 1242 1243 if Checks and then Position.Container /= Object.Container then 1244 raise Program_Error with 1245 "Position cursor of Previous designates wrong map"; 1246 end if; 1247 1248 return Previous (Position); 1249 end Previous; 1250 1251 ---------------------- 1252 -- Pseudo_Reference -- 1253 ---------------------- 1254 1255 function Pseudo_Reference 1256 (Container : aliased Map'Class) return Reference_Control_Type 1257 is 1258 TC : constant Tamper_Counts_Access := 1259 Container.TC'Unrestricted_Access; 1260 begin 1261 return R : constant Reference_Control_Type := (Controlled with TC) do 1262 Lock (TC.all); 1263 end return; 1264 end Pseudo_Reference; 1265 1266 ------------------- 1267 -- Query_Element -- 1268 ------------------- 1269 1270 procedure Query_Element 1271 (Position : Cursor; 1272 Process : not null access procedure (Key : Key_Type; 1273 Element : Element_Type)) 1274 is 1275 begin 1276 if Checks and then Position.Node = 0 then 1277 raise Constraint_Error with 1278 "Position cursor of Query_Element equals No_Element"; 1279 end if; 1280 1281 pragma Assert (Vet (Position.Container.all, Position.Node), 1282 "Position cursor of Query_Element is bad"); 1283 1284 declare 1285 M : Map renames Position.Container.all; 1286 N : Node_Type renames M.Nodes (Position.Node); 1287 Lock : With_Lock (M.TC'Unrestricted_Access); 1288 begin 1289 Process (N.Key, N.Element); 1290 end; 1291 end Query_Element; 1292 1293 ---------- 1294 -- Read -- 1295 ---------- 1296 1297 procedure Read 1298 (Stream : not null access Root_Stream_Type'Class; 1299 Container : out Map) 1300 is 1301 procedure Read_Element (Node : in out Node_Type); 1302 pragma Inline (Read_Element); 1303 1304 procedure Allocate is 1305 new Tree_Operations.Generic_Allocate (Read_Element); 1306 1307 procedure Read_Elements is 1308 new Tree_Operations.Generic_Read (Allocate); 1309 1310 ------------------ 1311 -- Read_Element -- 1312 ------------------ 1313 1314 procedure Read_Element (Node : in out Node_Type) is 1315 begin 1316 Key_Type'Read (Stream, Node.Key); 1317 Element_Type'Read (Stream, Node.Element); 1318 end Read_Element; 1319 1320 -- Start of processing for Read 1321 1322 begin 1323 Read_Elements (Stream, Container); 1324 end Read; 1325 1326 procedure Read 1327 (Stream : not null access Root_Stream_Type'Class; 1328 Item : out Cursor) 1329 is 1330 begin 1331 raise Program_Error with "attempt to stream map cursor"; 1332 end Read; 1333 1334 procedure Read 1335 (Stream : not null access Root_Stream_Type'Class; 1336 Item : out Reference_Type) 1337 is 1338 begin 1339 raise Program_Error with "attempt to stream reference"; 1340 end Read; 1341 1342 procedure Read 1343 (Stream : not null access Root_Stream_Type'Class; 1344 Item : out Constant_Reference_Type) 1345 is 1346 begin 1347 raise Program_Error with "attempt to stream reference"; 1348 end Read; 1349 1350 --------------- 1351 -- Reference -- 1352 --------------- 1353 1354 function Reference 1355 (Container : aliased in out Map; 1356 Position : Cursor) return Reference_Type 1357 is 1358 begin 1359 if Checks and then Position.Container = null then 1360 raise Constraint_Error with 1361 "Position cursor has no element"; 1362 end if; 1363 1364 if Checks and then Position.Container /= Container'Unrestricted_Access 1365 then 1366 raise Program_Error with 1367 "Position cursor designates wrong map"; 1368 end if; 1369 1370 pragma Assert (Vet (Container, Position.Node), 1371 "Position cursor in function Reference is bad"); 1372 1373 declare 1374 N : Node_Type renames Container.Nodes (Position.Node); 1375 TC : constant Tamper_Counts_Access := 1376 Container.TC'Unrestricted_Access; 1377 begin 1378 return R : constant Reference_Type := 1379 (Element => N.Element'Access, 1380 Control => (Controlled with TC)) 1381 do 1382 Lock (TC.all); 1383 end return; 1384 end; 1385 end Reference; 1386 1387 function Reference 1388 (Container : aliased in out Map; 1389 Key : Key_Type) return Reference_Type 1390 is 1391 Node : constant Count_Type := Key_Ops.Find (Container, Key); 1392 1393 begin 1394 if Checks and then Node = 0 then 1395 raise Constraint_Error with "key not in map"; 1396 end if; 1397 1398 declare 1399 N : Node_Type renames Container.Nodes (Node); 1400 TC : constant Tamper_Counts_Access := 1401 Container.TC'Unrestricted_Access; 1402 begin 1403 return R : constant Reference_Type := 1404 (Element => N.Element'Access, 1405 Control => (Controlled with TC)) 1406 do 1407 Lock (TC.all); 1408 end return; 1409 end; 1410 end Reference; 1411 1412 ------------- 1413 -- Replace -- 1414 ------------- 1415 1416 procedure Replace 1417 (Container : in out Map; 1418 Key : Key_Type; 1419 New_Item : Element_Type) 1420 is 1421 Node : constant Count_Type := Key_Ops.Find (Container, Key); 1422 1423 begin 1424 if Checks and then Node = 0 then 1425 raise Constraint_Error with "key not in map"; 1426 end if; 1427 1428 TE_Check (Container.TC); 1429 1430 declare 1431 N : Node_Type renames Container.Nodes (Node); 1432 1433 begin 1434 N.Key := Key; 1435 N.Element := New_Item; 1436 end; 1437 end Replace; 1438 1439 --------------------- 1440 -- Replace_Element -- 1441 --------------------- 1442 1443 procedure Replace_Element 1444 (Container : in out Map; 1445 Position : Cursor; 1446 New_Item : Element_Type) 1447 is 1448 begin 1449 if Checks and then Position.Node = 0 then 1450 raise Constraint_Error with 1451 "Position cursor of Replace_Element equals No_Element"; 1452 end if; 1453 1454 if Checks and then Position.Container /= Container'Unrestricted_Access 1455 then 1456 raise Program_Error with 1457 "Position cursor of Replace_Element designates wrong map"; 1458 end if; 1459 1460 TE_Check (Container.TC); 1461 1462 pragma Assert (Vet (Container, Position.Node), 1463 "Position cursor of Replace_Element is bad"); 1464 1465 Container.Nodes (Position.Node).Element := New_Item; 1466 end Replace_Element; 1467 1468 --------------------- 1469 -- Reverse_Iterate -- 1470 --------------------- 1471 1472 procedure Reverse_Iterate 1473 (Container : Map; 1474 Process : not null access procedure (Position : Cursor)) 1475 is 1476 procedure Process_Node (Node : Count_Type); 1477 pragma Inline (Process_Node); 1478 1479 procedure Local_Reverse_Iterate is 1480 new Tree_Operations.Generic_Reverse_Iteration (Process_Node); 1481 1482 ------------------ 1483 -- Process_Node -- 1484 ------------------ 1485 1486 procedure Process_Node (Node : Count_Type) is 1487 begin 1488 Process (Cursor'(Container'Unrestricted_Access, Node)); 1489 end Process_Node; 1490 1491 Busy : With_Busy (Container.TC'Unrestricted_Access); 1492 1493 -- Start of processing for Reverse_Iterate 1494 1495 begin 1496 Local_Reverse_Iterate (Container); 1497 end Reverse_Iterate; 1498 1499 ----------- 1500 -- Right -- 1501 ----------- 1502 1503 function Right (Node : Node_Type) return Count_Type is 1504 begin 1505 return Node.Right; 1506 end Right; 1507 1508 --------------- 1509 -- Set_Color -- 1510 --------------- 1511 1512 procedure Set_Color 1513 (Node : in out Node_Type; 1514 Color : Color_Type) 1515 is 1516 begin 1517 Node.Color := Color; 1518 end Set_Color; 1519 1520 -------------- 1521 -- Set_Left -- 1522 -------------- 1523 1524 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is 1525 begin 1526 Node.Left := Left; 1527 end Set_Left; 1528 1529 ---------------- 1530 -- Set_Parent -- 1531 ---------------- 1532 1533 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is 1534 begin 1535 Node.Parent := Parent; 1536 end Set_Parent; 1537 1538 --------------- 1539 -- Set_Right -- 1540 --------------- 1541 1542 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is 1543 begin 1544 Node.Right := Right; 1545 end Set_Right; 1546 1547 -------------------- 1548 -- Update_Element -- 1549 -------------------- 1550 1551 procedure Update_Element 1552 (Container : in out Map; 1553 Position : Cursor; 1554 Process : not null access procedure (Key : Key_Type; 1555 Element : in out Element_Type)) 1556 is 1557 begin 1558 if Checks and then Position.Node = 0 then 1559 raise Constraint_Error with 1560 "Position cursor of Update_Element equals No_Element"; 1561 end if; 1562 1563 if Checks and then Position.Container /= Container'Unrestricted_Access 1564 then 1565 raise Program_Error with 1566 "Position cursor of Update_Element designates wrong map"; 1567 end if; 1568 1569 pragma Assert (Vet (Container, Position.Node), 1570 "Position cursor of Update_Element is bad"); 1571 1572 declare 1573 N : Node_Type renames Container.Nodes (Position.Node); 1574 Lock : With_Lock (Container.TC'Unrestricted_Access); 1575 begin 1576 Process (N.Key, N.Element); 1577 end; 1578 end Update_Element; 1579 1580 ----------- 1581 -- Write -- 1582 ----------- 1583 1584 procedure Write 1585 (Stream : not null access Root_Stream_Type'Class; 1586 Container : Map) 1587 is 1588 procedure Write_Node 1589 (Stream : not null access Root_Stream_Type'Class; 1590 Node : Node_Type); 1591 pragma Inline (Write_Node); 1592 1593 procedure Write_Nodes is 1594 new Tree_Operations.Generic_Write (Write_Node); 1595 1596 ---------------- 1597 -- Write_Node -- 1598 ---------------- 1599 1600 procedure Write_Node 1601 (Stream : not null access Root_Stream_Type'Class; 1602 Node : Node_Type) 1603 is 1604 begin 1605 Key_Type'Write (Stream, Node.Key); 1606 Element_Type'Write (Stream, Node.Element); 1607 end Write_Node; 1608 1609 -- Start of processing for Write 1610 1611 begin 1612 Write_Nodes (Stream, Container); 1613 end Write; 1614 1615 procedure Write 1616 (Stream : not null access Root_Stream_Type'Class; 1617 Item : Cursor) 1618 is 1619 begin 1620 raise Program_Error with "attempt to stream map cursor"; 1621 end Write; 1622 1623 procedure Write 1624 (Stream : not null access Root_Stream_Type'Class; 1625 Item : Reference_Type) 1626 is 1627 begin 1628 raise Program_Error with "attempt to stream reference"; 1629 end Write; 1630 1631 procedure Write 1632 (Stream : not null access Root_Stream_Type'Class; 1633 Item : Constant_Reference_Type) 1634 is 1635 begin 1636 raise Program_Error with "attempt to stream reference"; 1637 end Write; 1638 1639end Ada.Containers.Bounded_Ordered_Maps; 1640