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