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