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-2015, 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 New_Item : Element_Type; 855 pragma Unmodified (New_Item); 856 -- Default-initialized element (ok to reference, see below) 857 858 begin 859 Node.Key := Key; 860 861 -- There is no explicit element provided, but in an instance the element 862 -- type may be a scalar with a Default_Value aspect, or a composite type 863 -- with such a scalar component or with defaulted components, so insert 864 -- possibly initialized elements at the given position. 865 866 Node.Element := New_Item; 867 end Assign; 868 869 -------------- 870 -- New_Node -- 871 -------------- 872 873 function New_Node return Count_Type is 874 Result : Count_Type; 875 begin 876 Allocate (Container, Result); 877 return Result; 878 end New_Node; 879 880 -- Start of processing for Insert 881 882 begin 883 Insert_Sans_Hint 884 (Container, 885 Key, 886 Position.Node, 887 Inserted); 888 889 Position.Container := Container'Unrestricted_Access; 890 end Insert; 891 892 -------------- 893 -- Is_Empty -- 894 -------------- 895 896 function Is_Empty (Container : Map) return Boolean is 897 begin 898 return Container.Length = 0; 899 end Is_Empty; 900 901 ------------------------- 902 -- Is_Greater_Key_Node -- 903 ------------------------- 904 905 function Is_Greater_Key_Node 906 (Left : Key_Type; 907 Right : Node_Type) return Boolean 908 is 909 begin 910 -- Left > Right same as Right < Left 911 912 return Right.Key < Left; 913 end Is_Greater_Key_Node; 914 915 ---------------------- 916 -- Is_Less_Key_Node -- 917 ---------------------- 918 919 function Is_Less_Key_Node 920 (Left : Key_Type; 921 Right : Node_Type) return Boolean 922 is 923 begin 924 return Left < Right.Key; 925 end Is_Less_Key_Node; 926 927 ------------- 928 -- Iterate -- 929 ------------- 930 931 procedure Iterate 932 (Container : Map; 933 Process : not null access procedure (Position : Cursor)) 934 is 935 procedure Process_Node (Node : Count_Type); 936 pragma Inline (Process_Node); 937 938 procedure Local_Iterate is 939 new Tree_Operations.Generic_Iteration (Process_Node); 940 941 ------------------ 942 -- Process_Node -- 943 ------------------ 944 945 procedure Process_Node (Node : Count_Type) is 946 begin 947 Process (Cursor'(Container'Unrestricted_Access, Node)); 948 end Process_Node; 949 950 Busy : With_Busy (Container.TC'Unrestricted_Access); 951 952 -- Start of processing for Iterate 953 954 begin 955 Local_Iterate (Container); 956 end Iterate; 957 958 function Iterate 959 (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class 960 is 961 begin 962 -- The value of the Node component influences the behavior of the First 963 -- and Last selector functions of the iterator object. When the Node 964 -- component is 0 (as is the case here), this means the iterator object 965 -- was constructed without a start expression. This is a complete 966 -- iterator, meaning that the iteration starts from the (logical) 967 -- beginning of the sequence of items. 968 969 -- Note: For a forward iterator, Container.First is the beginning, and 970 -- for a reverse iterator, Container.Last is the beginning. 971 972 return It : constant Iterator := 973 (Limited_Controlled with 974 Container => Container'Unrestricted_Access, 975 Node => 0) 976 do 977 Busy (Container.TC'Unrestricted_Access.all); 978 end return; 979 end Iterate; 980 981 function Iterate 982 (Container : Map; 983 Start : Cursor) 984 return Map_Iterator_Interfaces.Reversible_Iterator'Class 985 is 986 begin 987 -- Iterator was defined to behave the same as for a complete iterator, 988 -- and iterate over the entire sequence of items. However, those 989 -- semantics were unintuitive and arguably error-prone (it is too easy 990 -- to accidentally create an endless loop), and so they were changed, 991 -- per the ARG meeting in Denver on 2011/11. However, there was no 992 -- consensus about what positive meaning this corner case should have, 993 -- and so it was decided to simply raise an exception. This does imply, 994 -- however, that it is not possible to use a partial iterator to specify 995 -- an empty sequence of items. 996 997 if Checks and then Start = No_Element then 998 raise Constraint_Error with 999 "Start position for iterator equals No_Element"; 1000 end if; 1001 1002 if Checks and then Start.Container /= Container'Unrestricted_Access then 1003 raise Program_Error with 1004 "Start cursor of Iterate designates wrong map"; 1005 end if; 1006 1007 pragma Assert (Vet (Container, Start.Node), 1008 "Start cursor of Iterate is bad"); 1009 1010 -- The value of the Node component influences the behavior of the First 1011 -- and Last selector functions of the iterator object. When the Node 1012 -- component is positive (as is the case here), it means that this 1013 -- is a partial iteration, over a subset of the complete sequence of 1014 -- items. The iterator object was constructed with a start expression, 1015 -- indicating the position from which the iteration begins. (Note that 1016 -- the start position has the same value irrespective of whether this 1017 -- is a forward or reverse iteration.) 1018 1019 return It : constant Iterator := 1020 (Limited_Controlled with 1021 Container => Container'Unrestricted_Access, 1022 Node => Start.Node) 1023 do 1024 Busy (Container.TC'Unrestricted_Access.all); 1025 end return; 1026 end Iterate; 1027 1028 --------- 1029 -- Key -- 1030 --------- 1031 1032 function Key (Position : Cursor) return Key_Type is 1033 begin 1034 if Checks and then Position.Node = 0 then 1035 raise Constraint_Error with 1036 "Position cursor of function Key equals No_Element"; 1037 end if; 1038 1039 pragma Assert (Vet (Position.Container.all, Position.Node), 1040 "Position cursor of function Key is bad"); 1041 1042 return Position.Container.Nodes (Position.Node).Key; 1043 end Key; 1044 1045 ---------- 1046 -- Last -- 1047 ---------- 1048 1049 function Last (Container : Map) return Cursor is 1050 begin 1051 if Container.Last = 0 then 1052 return No_Element; 1053 else 1054 return Cursor'(Container'Unrestricted_Access, Container.Last); 1055 end if; 1056 end Last; 1057 1058 function Last (Object : Iterator) return Cursor is 1059 begin 1060 -- The value of the iterator object's Node component influences the 1061 -- behavior of the Last (and First) selector function. 1062 1063 -- When the Node component is 0, this means the iterator object was 1064 -- constructed without a start expression, in which case the (reverse) 1065 -- iteration starts from the (logical) beginning of the entire sequence 1066 -- (corresponding to Container.Last, for a reverse iterator). 1067 1068 -- Otherwise, this is iteration over a partial sequence of items. When 1069 -- the Node component is positive, the iterator object was constructed 1070 -- with a start expression, that specifies the position from which the 1071 -- (reverse) partial iteration begins. 1072 1073 if Object.Node = 0 then 1074 return Bounded_Ordered_Maps.Last (Object.Container.all); 1075 else 1076 return Cursor'(Object.Container, Object.Node); 1077 end if; 1078 end Last; 1079 1080 ------------------ 1081 -- Last_Element -- 1082 ------------------ 1083 1084 function Last_Element (Container : Map) return Element_Type is 1085 begin 1086 if Checks and then Container.Last = 0 then 1087 raise Constraint_Error with "map is empty"; 1088 end if; 1089 1090 return Container.Nodes (Container.Last).Element; 1091 end Last_Element; 1092 1093 -------------- 1094 -- Last_Key -- 1095 -------------- 1096 1097 function Last_Key (Container : Map) return Key_Type is 1098 begin 1099 if Checks and then Container.Last = 0 then 1100 raise Constraint_Error with "map is empty"; 1101 end if; 1102 1103 return Container.Nodes (Container.Last).Key; 1104 end Last_Key; 1105 1106 ---------- 1107 -- Left -- 1108 ---------- 1109 1110 function Left (Node : Node_Type) return Count_Type is 1111 begin 1112 return Node.Left; 1113 end Left; 1114 1115 ------------ 1116 -- Length -- 1117 ------------ 1118 1119 function Length (Container : Map) return Count_Type is 1120 begin 1121 return Container.Length; 1122 end Length; 1123 1124 ---------- 1125 -- Move -- 1126 ---------- 1127 1128 procedure Move (Target : in out Map; Source : in out Map) is 1129 begin 1130 if Target'Address = Source'Address then 1131 return; 1132 end if; 1133 1134 TC_Check (Source.TC); 1135 1136 Target.Assign (Source); 1137 Source.Clear; 1138 end Move; 1139 1140 ---------- 1141 -- Next -- 1142 ---------- 1143 1144 procedure Next (Position : in out Cursor) is 1145 begin 1146 Position := Next (Position); 1147 end Next; 1148 1149 function Next (Position : Cursor) return Cursor is 1150 begin 1151 if Position = No_Element then 1152 return No_Element; 1153 end if; 1154 1155 pragma Assert (Vet (Position.Container.all, Position.Node), 1156 "Position cursor of Next is bad"); 1157 1158 declare 1159 M : Map renames Position.Container.all; 1160 1161 Node : constant Count_Type := 1162 Tree_Operations.Next (M, Position.Node); 1163 1164 begin 1165 if Node = 0 then 1166 return No_Element; 1167 end if; 1168 1169 return Cursor'(Position.Container, Node); 1170 end; 1171 end Next; 1172 1173 function Next 1174 (Object : Iterator; 1175 Position : Cursor) return Cursor 1176 is 1177 begin 1178 if Position.Container = null then 1179 return No_Element; 1180 end if; 1181 1182 if Checks and then Position.Container /= Object.Container then 1183 raise Program_Error with 1184 "Position cursor of Next designates wrong map"; 1185 end if; 1186 1187 return Next (Position); 1188 end Next; 1189 1190 ------------ 1191 -- Parent -- 1192 ------------ 1193 1194 function Parent (Node : Node_Type) return Count_Type is 1195 begin 1196 return Node.Parent; 1197 end Parent; 1198 1199 -------------- 1200 -- Previous -- 1201 -------------- 1202 1203 procedure Previous (Position : in out Cursor) is 1204 begin 1205 Position := Previous (Position); 1206 end Previous; 1207 1208 function Previous (Position : Cursor) return Cursor is 1209 begin 1210 if Position = No_Element then 1211 return No_Element; 1212 end if; 1213 1214 pragma Assert (Vet (Position.Container.all, Position.Node), 1215 "Position cursor of Previous is bad"); 1216 1217 declare 1218 M : Map renames Position.Container.all; 1219 1220 Node : constant Count_Type := 1221 Tree_Operations.Previous (M, Position.Node); 1222 1223 begin 1224 if Node = 0 then 1225 return No_Element; 1226 end if; 1227 1228 return Cursor'(Position.Container, Node); 1229 end; 1230 end Previous; 1231 1232 function Previous 1233 (Object : Iterator; 1234 Position : Cursor) return Cursor 1235 is 1236 begin 1237 if Position.Container = null then 1238 return No_Element; 1239 end if; 1240 1241 if Checks and then Position.Container /= Object.Container then 1242 raise Program_Error with 1243 "Position cursor of Previous designates wrong map"; 1244 end if; 1245 1246 return Previous (Position); 1247 end Previous; 1248 1249 ---------------------- 1250 -- Pseudo_Reference -- 1251 ---------------------- 1252 1253 function Pseudo_Reference 1254 (Container : aliased Map'Class) return Reference_Control_Type 1255 is 1256 TC : constant Tamper_Counts_Access := 1257 Container.TC'Unrestricted_Access; 1258 begin 1259 return R : constant Reference_Control_Type := (Controlled with TC) do 1260 Lock (TC.all); 1261 end return; 1262 end Pseudo_Reference; 1263 1264 ------------------- 1265 -- Query_Element -- 1266 ------------------- 1267 1268 procedure Query_Element 1269 (Position : Cursor; 1270 Process : not null access procedure (Key : Key_Type; 1271 Element : Element_Type)) 1272 is 1273 begin 1274 if Checks and then Position.Node = 0 then 1275 raise Constraint_Error with 1276 "Position cursor of Query_Element equals No_Element"; 1277 end if; 1278 1279 pragma Assert (Vet (Position.Container.all, Position.Node), 1280 "Position cursor of Query_Element is bad"); 1281 1282 declare 1283 M : Map renames Position.Container.all; 1284 N : Node_Type renames M.Nodes (Position.Node); 1285 Lock : With_Lock (M.TC'Unrestricted_Access); 1286 begin 1287 Process (N.Key, N.Element); 1288 end; 1289 end Query_Element; 1290 1291 ---------- 1292 -- Read -- 1293 ---------- 1294 1295 procedure Read 1296 (Stream : not null access Root_Stream_Type'Class; 1297 Container : out Map) 1298 is 1299 procedure Read_Element (Node : in out Node_Type); 1300 pragma Inline (Read_Element); 1301 1302 procedure Allocate is 1303 new Tree_Operations.Generic_Allocate (Read_Element); 1304 1305 procedure Read_Elements is 1306 new Tree_Operations.Generic_Read (Allocate); 1307 1308 ------------------ 1309 -- Read_Element -- 1310 ------------------ 1311 1312 procedure Read_Element (Node : in out Node_Type) is 1313 begin 1314 Key_Type'Read (Stream, Node.Key); 1315 Element_Type'Read (Stream, Node.Element); 1316 end Read_Element; 1317 1318 -- Start of processing for Read 1319 1320 begin 1321 Read_Elements (Stream, Container); 1322 end Read; 1323 1324 procedure Read 1325 (Stream : not null access Root_Stream_Type'Class; 1326 Item : out Cursor) 1327 is 1328 begin 1329 raise Program_Error with "attempt to stream map cursor"; 1330 end Read; 1331 1332 procedure Read 1333 (Stream : not null access Root_Stream_Type'Class; 1334 Item : out Reference_Type) 1335 is 1336 begin 1337 raise Program_Error with "attempt to stream reference"; 1338 end Read; 1339 1340 procedure Read 1341 (Stream : not null access Root_Stream_Type'Class; 1342 Item : out Constant_Reference_Type) 1343 is 1344 begin 1345 raise Program_Error with "attempt to stream reference"; 1346 end Read; 1347 1348 --------------- 1349 -- Reference -- 1350 --------------- 1351 1352 function Reference 1353 (Container : aliased in out Map; 1354 Position : Cursor) return Reference_Type 1355 is 1356 begin 1357 if Checks and then Position.Container = null then 1358 raise Constraint_Error with 1359 "Position cursor has no element"; 1360 end if; 1361 1362 if Checks and then Position.Container /= Container'Unrestricted_Access 1363 then 1364 raise Program_Error with 1365 "Position cursor designates wrong map"; 1366 end if; 1367 1368 pragma Assert (Vet (Container, Position.Node), 1369 "Position cursor in function Reference is bad"); 1370 1371 declare 1372 N : Node_Type renames Container.Nodes (Position.Node); 1373 TC : constant Tamper_Counts_Access := 1374 Container.TC'Unrestricted_Access; 1375 begin 1376 return R : constant Reference_Type := 1377 (Element => N.Element'Access, 1378 Control => (Controlled with TC)) 1379 do 1380 Lock (TC.all); 1381 end return; 1382 end; 1383 end Reference; 1384 1385 function Reference 1386 (Container : aliased in out Map; 1387 Key : Key_Type) return Reference_Type 1388 is 1389 Node : constant Count_Type := Key_Ops.Find (Container, Key); 1390 1391 begin 1392 if Checks and then Node = 0 then 1393 raise Constraint_Error with "key not in map"; 1394 end if; 1395 1396 declare 1397 N : Node_Type renames Container.Nodes (Node); 1398 TC : constant Tamper_Counts_Access := 1399 Container.TC'Unrestricted_Access; 1400 begin 1401 return R : constant Reference_Type := 1402 (Element => N.Element'Access, 1403 Control => (Controlled with TC)) 1404 do 1405 Lock (TC.all); 1406 end return; 1407 end; 1408 end Reference; 1409 1410 ------------- 1411 -- Replace -- 1412 ------------- 1413 1414 procedure Replace 1415 (Container : in out Map; 1416 Key : Key_Type; 1417 New_Item : Element_Type) 1418 is 1419 Node : constant Count_Type := Key_Ops.Find (Container, Key); 1420 1421 begin 1422 if Checks and then Node = 0 then 1423 raise Constraint_Error with "key not in map"; 1424 end if; 1425 1426 TE_Check (Container.TC); 1427 1428 declare 1429 N : Node_Type renames Container.Nodes (Node); 1430 1431 begin 1432 N.Key := Key; 1433 N.Element := New_Item; 1434 end; 1435 end Replace; 1436 1437 --------------------- 1438 -- Replace_Element -- 1439 --------------------- 1440 1441 procedure Replace_Element 1442 (Container : in out Map; 1443 Position : Cursor; 1444 New_Item : Element_Type) 1445 is 1446 begin 1447 if Checks and then Position.Node = 0 then 1448 raise Constraint_Error with 1449 "Position cursor of Replace_Element equals No_Element"; 1450 end if; 1451 1452 if Checks and then Position.Container /= Container'Unrestricted_Access 1453 then 1454 raise Program_Error with 1455 "Position cursor of Replace_Element designates wrong map"; 1456 end if; 1457 1458 TE_Check (Container.TC); 1459 1460 pragma Assert (Vet (Container, Position.Node), 1461 "Position cursor of Replace_Element is bad"); 1462 1463 Container.Nodes (Position.Node).Element := New_Item; 1464 end Replace_Element; 1465 1466 --------------------- 1467 -- Reverse_Iterate -- 1468 --------------------- 1469 1470 procedure Reverse_Iterate 1471 (Container : Map; 1472 Process : not null access procedure (Position : Cursor)) 1473 is 1474 procedure Process_Node (Node : Count_Type); 1475 pragma Inline (Process_Node); 1476 1477 procedure Local_Reverse_Iterate is 1478 new Tree_Operations.Generic_Reverse_Iteration (Process_Node); 1479 1480 ------------------ 1481 -- Process_Node -- 1482 ------------------ 1483 1484 procedure Process_Node (Node : Count_Type) is 1485 begin 1486 Process (Cursor'(Container'Unrestricted_Access, Node)); 1487 end Process_Node; 1488 1489 Busy : With_Busy (Container.TC'Unrestricted_Access); 1490 1491 -- Start of processing for Reverse_Iterate 1492 1493 begin 1494 Local_Reverse_Iterate (Container); 1495 end Reverse_Iterate; 1496 1497 ----------- 1498 -- Right -- 1499 ----------- 1500 1501 function Right (Node : Node_Type) return Count_Type is 1502 begin 1503 return Node.Right; 1504 end Right; 1505 1506 --------------- 1507 -- Set_Color -- 1508 --------------- 1509 1510 procedure Set_Color 1511 (Node : in out Node_Type; 1512 Color : Color_Type) 1513 is 1514 begin 1515 Node.Color := Color; 1516 end Set_Color; 1517 1518 -------------- 1519 -- Set_Left -- 1520 -------------- 1521 1522 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is 1523 begin 1524 Node.Left := Left; 1525 end Set_Left; 1526 1527 ---------------- 1528 -- Set_Parent -- 1529 ---------------- 1530 1531 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is 1532 begin 1533 Node.Parent := Parent; 1534 end Set_Parent; 1535 1536 --------------- 1537 -- Set_Right -- 1538 --------------- 1539 1540 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is 1541 begin 1542 Node.Right := Right; 1543 end Set_Right; 1544 1545 -------------------- 1546 -- Update_Element -- 1547 -------------------- 1548 1549 procedure Update_Element 1550 (Container : in out Map; 1551 Position : Cursor; 1552 Process : not null access procedure (Key : Key_Type; 1553 Element : in out Element_Type)) 1554 is 1555 begin 1556 if Checks and then Position.Node = 0 then 1557 raise Constraint_Error with 1558 "Position cursor of Update_Element equals No_Element"; 1559 end if; 1560 1561 if Checks and then Position.Container /= Container'Unrestricted_Access 1562 then 1563 raise Program_Error with 1564 "Position cursor of Update_Element designates wrong map"; 1565 end if; 1566 1567 pragma Assert (Vet (Container, Position.Node), 1568 "Position cursor of Update_Element is bad"); 1569 1570 declare 1571 N : Node_Type renames Container.Nodes (Position.Node); 1572 Lock : With_Lock (Container.TC'Unrestricted_Access); 1573 begin 1574 Process (N.Key, N.Element); 1575 end; 1576 end Update_Element; 1577 1578 ----------- 1579 -- Write -- 1580 ----------- 1581 1582 procedure Write 1583 (Stream : not null access Root_Stream_Type'Class; 1584 Container : Map) 1585 is 1586 procedure Write_Node 1587 (Stream : not null access Root_Stream_Type'Class; 1588 Node : Node_Type); 1589 pragma Inline (Write_Node); 1590 1591 procedure Write_Nodes is 1592 new Tree_Operations.Generic_Write (Write_Node); 1593 1594 ---------------- 1595 -- Write_Node -- 1596 ---------------- 1597 1598 procedure Write_Node 1599 (Stream : not null access Root_Stream_Type'Class; 1600 Node : Node_Type) 1601 is 1602 begin 1603 Key_Type'Write (Stream, Node.Key); 1604 Element_Type'Write (Stream, Node.Element); 1605 end Write_Node; 1606 1607 -- Start of processing for Write 1608 1609 begin 1610 Write_Nodes (Stream, Container); 1611 end Write; 1612 1613 procedure Write 1614 (Stream : not null access Root_Stream_Type'Class; 1615 Item : Cursor) 1616 is 1617 begin 1618 raise Program_Error with "attempt to stream map cursor"; 1619 end Write; 1620 1621 procedure Write 1622 (Stream : not null access Root_Stream_Type'Class; 1623 Item : Reference_Type) 1624 is 1625 begin 1626 raise Program_Error with "attempt to stream reference"; 1627 end Write; 1628 1629 procedure Write 1630 (Stream : not null access Root_Stream_Type'Class; 1631 Item : Constant_Reference_Type) 1632 is 1633 begin 1634 raise Program_Error with "attempt to stream reference"; 1635 end Write; 1636 1637end Ada.Containers.Bounded_Ordered_Maps; 1638