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