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