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