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