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