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