1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2010-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 28with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; 29pragma Elaborate_All 30 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); 31 32with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; 33pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); 34 35with System; use type System.Address; 36 37package body Ada.Containers.Formal_Ordered_Maps with 38 SPARK_Mode => Off 39is 40 41 ----------------------------- 42 -- Node Access Subprograms -- 43 ----------------------------- 44 45 -- These subprograms provide a functional interface to access fields 46 -- of a node, and a procedural interface for modifying these values. 47 48 function Color 49 (Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type; 50 pragma Inline (Color); 51 52 function Left_Son (Node : Node_Type) return Count_Type; 53 pragma Inline (Left_Son); 54 55 function Parent (Node : Node_Type) return Count_Type; 56 pragma Inline (Parent); 57 58 function Right_Son (Node : Node_Type) return Count_Type; 59 pragma Inline (Right_Son); 60 61 procedure Set_Color 62 (Node : in out Node_Type; 63 Color : Ada.Containers.Red_Black_Trees.Color_Type); 64 pragma Inline (Set_Color); 65 66 procedure Set_Left (Node : in out Node_Type; Left : Count_Type); 67 pragma Inline (Set_Left); 68 69 procedure Set_Right (Node : in out Node_Type; Right : Count_Type); 70 pragma Inline (Set_Right); 71 72 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); 73 pragma Inline (Set_Parent); 74 75 ----------------------- 76 -- Local Subprograms -- 77 ----------------------- 78 79 -- All need comments ??? 80 81 generic 82 with procedure Set_Element (Node : in out Node_Type); 83 procedure Generic_Allocate 84 (Tree : in out Tree_Types.Tree_Type'Class; 85 Node : out Count_Type); 86 87 procedure Free (Tree : in out Map; X : Count_Type); 88 89 function Is_Greater_Key_Node 90 (Left : Key_Type; 91 Right : Node_Type) return Boolean; 92 pragma Inline (Is_Greater_Key_Node); 93 94 function Is_Less_Key_Node 95 (Left : Key_Type; 96 Right : Node_Type) return Boolean; 97 pragma Inline (Is_Less_Key_Node); 98 99 -------------------------- 100 -- Local Instantiations -- 101 -------------------------- 102 103 package Tree_Operations is 104 new Red_Black_Trees.Generic_Bounded_Operations 105 (Tree_Types => Tree_Types, 106 Left => Left_Son, 107 Right => Right_Son); 108 109 use Tree_Operations; 110 111 package Key_Ops is 112 new Red_Black_Trees.Generic_Bounded_Keys 113 (Tree_Operations => Tree_Operations, 114 Key_Type => Key_Type, 115 Is_Less_Key_Node => Is_Less_Key_Node, 116 Is_Greater_Key_Node => Is_Greater_Key_Node); 117 118 --------- 119 -- "=" -- 120 --------- 121 122 function "=" (Left, Right : Map) return Boolean is 123 Lst : Count_Type; 124 Node : Count_Type; 125 ENode : Count_Type; 126 127 begin 128 if Length (Left) /= Length (Right) then 129 return False; 130 end if; 131 132 if Is_Empty (Left) then 133 return True; 134 end if; 135 136 Lst := Next (Left, Last (Left).Node); 137 138 Node := First (Left).Node; 139 while Node /= Lst loop 140 ENode := Find (Right, Left.Nodes (Node).Key).Node; 141 142 if ENode = 0 or else 143 Left.Nodes (Node).Element /= Right.Nodes (ENode).Element 144 then 145 return False; 146 end if; 147 148 Node := Next (Left, Node); 149 end loop; 150 151 return True; 152 end "="; 153 154 ------------ 155 -- Assign -- 156 ------------ 157 158 procedure Assign (Target : in out Map; Source : Map) is 159 procedure Append_Element (Source_Node : Count_Type); 160 161 procedure Append_Elements is 162 new Tree_Operations.Generic_Iteration (Append_Element); 163 164 -------------------- 165 -- Append_Element -- 166 -------------------- 167 168 procedure Append_Element (Source_Node : Count_Type) is 169 SN : Node_Type renames Source.Nodes (Source_Node); 170 171 procedure Set_Element (Node : in out Node_Type); 172 pragma Inline (Set_Element); 173 174 function New_Node return Count_Type; 175 pragma Inline (New_Node); 176 177 procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node); 178 179 procedure Unconditional_Insert_Sans_Hint is 180 new Key_Ops.Generic_Unconditional_Insert (Insert_Post); 181 182 procedure Unconditional_Insert_Avec_Hint is 183 new Key_Ops.Generic_Unconditional_Insert_With_Hint 184 (Insert_Post, 185 Unconditional_Insert_Sans_Hint); 186 187 procedure Allocate is new Generic_Allocate (Set_Element); 188 189 -------------- 190 -- New_Node -- 191 -------------- 192 193 function New_Node return Count_Type is 194 Result : Count_Type; 195 begin 196 Allocate (Target, Result); 197 return Result; 198 end New_Node; 199 200 ----------------- 201 -- Set_Element -- 202 ----------------- 203 204 procedure Set_Element (Node : in out Node_Type) is 205 begin 206 Node.Key := SN.Key; 207 Node.Element := SN.Element; 208 end Set_Element; 209 210 Target_Node : Count_Type; 211 212 -- Start of processing for Append_Element 213 214 begin 215 Unconditional_Insert_Avec_Hint 216 (Tree => Target, 217 Hint => 0, 218 Key => SN.Key, 219 Node => Target_Node); 220 end Append_Element; 221 222 -- Start of processing for Assign 223 224 begin 225 if Target'Address = Source'Address then 226 return; 227 end if; 228 229 if Target.Capacity < Length (Source) then 230 raise Storage_Error with "not enough capacity"; -- SE or CE? ??? 231 end if; 232 233 Tree_Operations.Clear_Tree (Target); 234 Append_Elements (Source); 235 end Assign; 236 237 ------------- 238 -- Ceiling -- 239 ------------- 240 241 function Ceiling (Container : Map; Key : Key_Type) return Cursor is 242 Node : constant Count_Type := Key_Ops.Ceiling (Container, Key); 243 244 begin 245 if Node = 0 then 246 return No_Element; 247 end if; 248 249 return (Node => Node); 250 end Ceiling; 251 252 ----------- 253 -- Clear -- 254 ----------- 255 256 procedure Clear (Container : in out Map) is 257 begin 258 Tree_Operations.Clear_Tree (Container); 259 end Clear; 260 261 ----------- 262 -- Color -- 263 ----------- 264 265 function Color (Node : Node_Type) return Color_Type is 266 begin 267 return Node.Color; 268 end Color; 269 270 -------------- 271 -- Contains -- 272 -------------- 273 274 function Contains (Container : Map; Key : Key_Type) return Boolean is 275 begin 276 return Find (Container, Key) /= No_Element; 277 end Contains; 278 279 ---------- 280 -- Copy -- 281 ---------- 282 283 function Copy (Source : Map; Capacity : Count_Type := 0) return Map is 284 Node : Count_Type := 1; 285 N : Count_Type; 286 287 begin 288 if 0 < Capacity and then Capacity < Source.Capacity then 289 raise Capacity_Error; 290 end if; 291 292 return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do 293 if Length (Source) > 0 then 294 Target.Length := Source.Length; 295 Target.Root := Source.Root; 296 Target.First := Source.First; 297 Target.Last := Source.Last; 298 Target.Free := Source.Free; 299 300 while Node <= Source.Capacity loop 301 Target.Nodes (Node).Element := 302 Source.Nodes (Node).Element; 303 Target.Nodes (Node).Key := 304 Source.Nodes (Node).Key; 305 Target.Nodes (Node).Parent := 306 Source.Nodes (Node).Parent; 307 Target.Nodes (Node).Left := 308 Source.Nodes (Node).Left; 309 Target.Nodes (Node).Right := 310 Source.Nodes (Node).Right; 311 Target.Nodes (Node).Color := 312 Source.Nodes (Node).Color; 313 Target.Nodes (Node).Has_Element := 314 Source.Nodes (Node).Has_Element; 315 Node := Node + 1; 316 end loop; 317 318 while Node <= Target.Capacity loop 319 N := Node; 320 Formal_Ordered_Maps.Free (Tree => Target, X => N); 321 Node := Node + 1; 322 end loop; 323 end if; 324 end return; 325 end Copy; 326 327 --------------------- 328 -- Current_To_Last -- 329 --------------------- 330 331 function Current_To_Last (Container : Map; Current : Cursor) return Map is 332 Curs : Cursor := First (Container); 333 C : Map (Container.Capacity) := Copy (Container, Container.Capacity); 334 Node : Count_Type; 335 336 begin 337 if Curs = No_Element then 338 Clear (C); 339 return C; 340 341 elsif Current /= No_Element and not Has_Element (Container, Current) then 342 raise Constraint_Error; 343 344 else 345 while Curs.Node /= Current.Node loop 346 Node := Curs.Node; 347 Delete (C, Curs); 348 Curs := Next (Container, (Node => Node)); 349 end loop; 350 351 return C; 352 end if; 353 end Current_To_Last; 354 355 ------------ 356 -- Delete -- 357 ------------ 358 359 procedure Delete (Container : in out Map; Position : in out Cursor) is 360 begin 361 if not Has_Element (Container, Position) then 362 raise Constraint_Error with 363 "Position cursor of Delete has no element"; 364 end if; 365 366 pragma Assert (Vet (Container, Position.Node), 367 "Position cursor of Delete is bad"); 368 369 Tree_Operations.Delete_Node_Sans_Free (Container, 370 Position.Node); 371 Formal_Ordered_Maps.Free (Container, Position.Node); 372 end Delete; 373 374 procedure Delete (Container : in out Map; Key : Key_Type) is 375 X : constant Node_Access := Key_Ops.Find (Container, Key); 376 377 begin 378 if X = 0 then 379 raise Constraint_Error with "key not in map"; 380 end if; 381 382 Tree_Operations.Delete_Node_Sans_Free (Container, X); 383 Formal_Ordered_Maps.Free (Container, X); 384 end Delete; 385 386 ------------------ 387 -- Delete_First -- 388 ------------------ 389 390 procedure Delete_First (Container : in out Map) is 391 X : constant Node_Access := First (Container).Node; 392 begin 393 if X /= 0 then 394 Tree_Operations.Delete_Node_Sans_Free (Container, X); 395 Formal_Ordered_Maps.Free (Container, X); 396 end if; 397 end Delete_First; 398 399 ----------------- 400 -- Delete_Last -- 401 ----------------- 402 403 procedure Delete_Last (Container : in out Map) is 404 X : constant Node_Access := Last (Container).Node; 405 begin 406 if X /= 0 then 407 Tree_Operations.Delete_Node_Sans_Free (Container, X); 408 Formal_Ordered_Maps.Free (Container, X); 409 end if; 410 end Delete_Last; 411 412 ------------- 413 -- Element -- 414 ------------- 415 416 function Element (Container : Map; Position : Cursor) return Element_Type is 417 begin 418 if not Has_Element (Container, Position) then 419 raise Constraint_Error with 420 "Position cursor of function Element has no element"; 421 end if; 422 423 pragma Assert (Vet (Container, Position.Node), 424 "Position cursor of function Element is bad"); 425 426 return Container.Nodes (Position.Node).Element; 427 428 end Element; 429 430 function Element (Container : Map; Key : Key_Type) return Element_Type is 431 Node : constant Node_Access := Find (Container, Key).Node; 432 433 begin 434 if Node = 0 then 435 raise Constraint_Error with "key not in map"; 436 end if; 437 438 return Container.Nodes (Node).Element; 439 end Element; 440 441 --------------------- 442 -- Equivalent_Keys -- 443 --------------------- 444 445 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is 446 begin 447 if Left < Right 448 or else Right < Left 449 then 450 return False; 451 else 452 return True; 453 end if; 454 end Equivalent_Keys; 455 456 ------------- 457 -- Exclude -- 458 ------------- 459 460 procedure Exclude (Container : in out Map; Key : Key_Type) is 461 X : constant Node_Access := Key_Ops.Find (Container, Key); 462 begin 463 if X /= 0 then 464 Tree_Operations.Delete_Node_Sans_Free (Container, X); 465 Formal_Ordered_Maps.Free (Container, X); 466 end if; 467 end Exclude; 468 469 ---------- 470 -- Find -- 471 ---------- 472 473 function Find (Container : Map; Key : Key_Type) return Cursor is 474 Node : constant Count_Type := Key_Ops.Find (Container, Key); 475 476 begin 477 if Node = 0 then 478 return No_Element; 479 end if; 480 481 return (Node => Node); 482 end Find; 483 484 ----------- 485 -- First -- 486 ----------- 487 488 function First (Container : Map) return Cursor is 489 begin 490 if Length (Container) = 0 then 491 return No_Element; 492 end if; 493 494 return (Node => Container.First); 495 end First; 496 497 ------------------- 498 -- First_Element -- 499 ------------------- 500 501 function First_Element (Container : Map) return Element_Type is 502 begin 503 if Is_Empty (Container) then 504 raise Constraint_Error with "map is empty"; 505 end if; 506 507 return Container.Nodes (First (Container).Node).Element; 508 end First_Element; 509 510 --------------- 511 -- First_Key -- 512 --------------- 513 514 function First_Key (Container : Map) return Key_Type is 515 begin 516 if Is_Empty (Container) then 517 raise Constraint_Error with "map is empty"; 518 end if; 519 520 return Container.Nodes (First (Container).Node).Key; 521 end First_Key; 522 523 ----------------------- 524 -- First_To_Previous -- 525 ----------------------- 526 527 function First_To_Previous 528 (Container : Map; 529 Current : Cursor) return Map 530 is 531 Curs : Cursor := Current; 532 C : Map (Container.Capacity) := Copy (Container, Container.Capacity); 533 Node : Count_Type; 534 535 begin 536 if Curs = No_Element then 537 return C; 538 539 elsif not Has_Element (Container, Curs) then 540 raise Constraint_Error; 541 542 else 543 while Curs.Node /= 0 loop 544 Node := Curs.Node; 545 Delete (C, Curs); 546 Curs := Next (Container, (Node => Node)); 547 end loop; 548 549 return C; 550 end if; 551 end First_To_Previous; 552 553 ----------- 554 -- Floor -- 555 ----------- 556 557 function Floor (Container : Map; Key : Key_Type) return Cursor is 558 Node : constant Count_Type := Key_Ops.Floor (Container, Key); 559 560 begin 561 if Node = 0 then 562 return No_Element; 563 end if; 564 565 return (Node => Node); 566 end Floor; 567 568 ---------- 569 -- Free -- 570 ---------- 571 572 procedure Free 573 (Tree : in out Map; 574 X : Count_Type) 575 is 576 begin 577 Tree.Nodes (X).Has_Element := False; 578 Tree_Operations.Free (Tree, X); 579 end Free; 580 581 ---------------------- 582 -- Generic_Allocate -- 583 ---------------------- 584 585 procedure Generic_Allocate 586 (Tree : in out Tree_Types.Tree_Type'Class; 587 Node : out Count_Type) 588 is 589 procedure Allocate is 590 new Tree_Operations.Generic_Allocate (Set_Element); 591 begin 592 Allocate (Tree, Node); 593 Tree.Nodes (Node).Has_Element := True; 594 end Generic_Allocate; 595 596 ----------------- 597 -- Has_Element -- 598 ----------------- 599 600 function Has_Element (Container : Map; Position : Cursor) return Boolean is 601 begin 602 if Position.Node = 0 then 603 return False; 604 end if; 605 606 return Container.Nodes (Position.Node).Has_Element; 607 end Has_Element; 608 609 ------------- 610 -- Include -- 611 ------------- 612 613 procedure Include 614 (Container : in out Map; 615 Key : Key_Type; 616 New_Item : Element_Type) 617 is 618 Position : Cursor; 619 Inserted : Boolean; 620 621 begin 622 Insert (Container, Key, New_Item, Position, Inserted); 623 624 if not Inserted then 625 declare 626 N : Node_Type renames Container.Nodes (Position.Node); 627 begin 628 N.Key := Key; 629 N.Element := New_Item; 630 end; 631 end if; 632 end Include; 633 634 procedure Insert 635 (Container : in out Map; 636 Key : Key_Type; 637 New_Item : Element_Type; 638 Position : out Cursor; 639 Inserted : out Boolean) 640 is 641 function New_Node return Node_Access; 642 -- Comment ??? 643 644 procedure Insert_Post is 645 new Key_Ops.Generic_Insert_Post (New_Node); 646 647 procedure Insert_Sans_Hint is 648 new Key_Ops.Generic_Conditional_Insert (Insert_Post); 649 650 -------------- 651 -- New_Node -- 652 -------------- 653 654 function New_Node return Node_Access is 655 procedure Initialize (Node : in out Node_Type); 656 procedure Allocate_Node is new Generic_Allocate (Initialize); 657 658 procedure Initialize (Node : in out Node_Type) is 659 begin 660 Node.Key := Key; 661 Node.Element := New_Item; 662 end Initialize; 663 664 X : Node_Access; 665 666 begin 667 Allocate_Node (Container, X); 668 return X; 669 end New_Node; 670 671 -- Start of processing for Insert 672 673 begin 674 Insert_Sans_Hint 675 (Container, 676 Key, 677 Position.Node, 678 Inserted); 679 end Insert; 680 681 procedure Insert 682 (Container : in out Map; 683 Key : Key_Type; 684 New_Item : Element_Type) 685 is 686 Position : Cursor; 687 Inserted : Boolean; 688 689 begin 690 Insert (Container, Key, New_Item, Position, Inserted); 691 692 if not Inserted then 693 raise Constraint_Error with "key already in map"; 694 end if; 695 end Insert; 696 697 -------------- 698 -- Is_Empty -- 699 -------------- 700 701 function Is_Empty (Container : Map) return Boolean is 702 begin 703 return Length (Container) = 0; 704 end Is_Empty; 705 706 ------------------------- 707 -- Is_Greater_Key_Node -- 708 ------------------------- 709 710 function Is_Greater_Key_Node 711 (Left : Key_Type; 712 Right : Node_Type) return Boolean 713 is 714 begin 715 -- k > node same as node < k 716 717 return Right.Key < Left; 718 end Is_Greater_Key_Node; 719 720 ---------------------- 721 -- Is_Less_Key_Node -- 722 ---------------------- 723 724 function Is_Less_Key_Node 725 (Left : Key_Type; 726 Right : Node_Type) return Boolean 727 is 728 begin 729 return Left < Right.Key; 730 end Is_Less_Key_Node; 731 732 --------- 733 -- Key -- 734 --------- 735 736 function Key (Container : Map; Position : Cursor) return Key_Type is 737 begin 738 if not Has_Element (Container, Position) then 739 raise Constraint_Error with 740 "Position cursor of function Key has no element"; 741 end if; 742 743 pragma Assert (Vet (Container, Position.Node), 744 "Position cursor of function Key is bad"); 745 746 return Container.Nodes (Position.Node).Key; 747 end Key; 748 749 ---------- 750 -- Last -- 751 ---------- 752 753 function Last (Container : Map) return Cursor is 754 begin 755 if Length (Container) = 0 then 756 return No_Element; 757 end if; 758 759 return (Node => Container.Last); 760 end Last; 761 762 ------------------ 763 -- Last_Element -- 764 ------------------ 765 766 function Last_Element (Container : Map) return Element_Type is 767 begin 768 if Is_Empty (Container) then 769 raise Constraint_Error with "map is empty"; 770 end if; 771 772 return Container.Nodes (Last (Container).Node).Element; 773 end Last_Element; 774 775 -------------- 776 -- Last_Key -- 777 -------------- 778 779 function Last_Key (Container : Map) return Key_Type is 780 begin 781 if Is_Empty (Container) then 782 raise Constraint_Error with "map is empty"; 783 end if; 784 785 return Container.Nodes (Last (Container).Node).Key; 786 end Last_Key; 787 788 -------------- 789 -- Left_Son -- 790 -------------- 791 792 function Left_Son (Node : Node_Type) return Count_Type is 793 begin 794 return Node.Left; 795 end Left_Son; 796 797 ------------ 798 -- Length -- 799 ------------ 800 801 function Length (Container : Map) return Count_Type is 802 begin 803 return Container.Length; 804 end Length; 805 806 ---------- 807 -- Move -- 808 ---------- 809 810 procedure Move (Target : in out Map; Source : in out Map) is 811 NN : Tree_Types.Nodes_Type renames Source.Nodes; 812 X : Node_Access; 813 814 begin 815 if Target'Address = Source'Address then 816 return; 817 end if; 818 819 if Target.Capacity < Length (Source) then 820 raise Constraint_Error with -- ??? 821 "Source length exceeds Target capacity"; 822 end if; 823 824 Clear (Target); 825 826 loop 827 X := First (Source).Node; 828 exit when X = 0; 829 830 -- Here we insert a copy of the source element into the target, and 831 -- then delete the element from the source. Another possibility is 832 -- that delete it first (and hang onto its index), then insert it. 833 -- ??? 834 835 Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? 836 837 Tree_Operations.Delete_Node_Sans_Free (Source, X); 838 Formal_Ordered_Maps.Free (Source, X); 839 end loop; 840 end Move; 841 842 ---------- 843 -- Next -- 844 ---------- 845 846 procedure Next (Container : Map; Position : in out Cursor) is 847 begin 848 Position := Next (Container, Position); 849 end Next; 850 851 function Next (Container : Map; Position : Cursor) return Cursor is 852 begin 853 if Position = No_Element then 854 return No_Element; 855 end if; 856 857 if not Has_Element (Container, Position) then 858 raise Constraint_Error; 859 end if; 860 861 pragma Assert (Vet (Container, Position.Node), 862 "bad cursor in Next"); 863 864 return (Node => Tree_Operations.Next (Container, Position.Node)); 865 end Next; 866 867 ------------- 868 -- Overlap -- 869 ------------- 870 871 function Overlap (Left, Right : Map) return Boolean is 872 begin 873 if Length (Left) = 0 or Length (Right) = 0 then 874 return False; 875 end if; 876 877 declare 878 L_Node : Count_Type := First (Left).Node; 879 R_Node : Count_Type := First (Right).Node; 880 L_Last : constant Count_Type := Next (Left, Last (Left).Node); 881 R_Last : constant Count_Type := Next (Right, Last (Right).Node); 882 883 begin 884 if Left'Address = Right'Address then 885 return True; 886 end if; 887 888 loop 889 if L_Node = L_Last 890 or else R_Node = R_Last 891 then 892 return False; 893 end if; 894 895 if Left.Nodes (L_Node).Key < Right.Nodes (R_Node).Key then 896 L_Node := Next (Left, L_Node); 897 898 elsif Right.Nodes (R_Node).Key < Left.Nodes (L_Node).Key then 899 R_Node := Next (Right, R_Node); 900 901 else 902 return True; 903 end if; 904 end loop; 905 end; 906 end Overlap; 907 908 ------------ 909 -- Parent -- 910 ------------ 911 912 function Parent (Node : Node_Type) return Count_Type is 913 begin 914 return Node.Parent; 915 end Parent; 916 917 -------------- 918 -- Previous -- 919 -------------- 920 921 procedure Previous (Container : Map; Position : in out Cursor) is 922 begin 923 Position := Previous (Container, Position); 924 end Previous; 925 926 function Previous (Container : Map; Position : Cursor) return Cursor is 927 begin 928 if Position = No_Element then 929 return No_Element; 930 end if; 931 932 if not Has_Element (Container, Position) then 933 raise Constraint_Error; 934 end if; 935 936 pragma Assert (Vet (Container, Position.Node), 937 "bad cursor in Previous"); 938 939 declare 940 Node : constant Count_Type := 941 Tree_Operations.Previous (Container, Position.Node); 942 943 begin 944 if Node = 0 then 945 return No_Element; 946 end if; 947 948 return (Node => Node); 949 end; 950 end Previous; 951 952 ------------- 953 -- Replace -- 954 ------------- 955 956 procedure Replace 957 (Container : in out Map; 958 Key : Key_Type; 959 New_Item : Element_Type) 960 is 961 begin 962 declare 963 Node : constant Node_Access := Key_Ops.Find (Container, Key); 964 965 begin 966 if Node = 0 then 967 raise Constraint_Error with "key not in map"; 968 end if; 969 970 declare 971 N : Node_Type renames Container.Nodes (Node); 972 begin 973 N.Key := Key; 974 N.Element := New_Item; 975 end; 976 end; 977 end Replace; 978 979 --------------------- 980 -- Replace_Element -- 981 --------------------- 982 983 procedure Replace_Element 984 (Container : in out Map; 985 Position : Cursor; 986 New_Item : Element_Type) 987 is 988 begin 989 if not Has_Element (Container, Position) then 990 raise Constraint_Error with 991 "Position cursor of Replace_Element has no element"; 992 end if; 993 994 pragma Assert (Vet (Container, Position.Node), 995 "Position cursor of Replace_Element is bad"); 996 997 Container.Nodes (Position.Node).Element := New_Item; 998 end Replace_Element; 999 1000 --------------- 1001 -- Right_Son -- 1002 --------------- 1003 1004 function Right_Son (Node : Node_Type) return Count_Type is 1005 begin 1006 return Node.Right; 1007 end Right_Son; 1008 1009 --------------- 1010 -- Set_Color -- 1011 --------------- 1012 1013 procedure Set_Color (Node : in out Node_Type; Color : Color_Type) is 1014 begin 1015 Node.Color := Color; 1016 end Set_Color; 1017 1018 -------------- 1019 -- Set_Left -- 1020 -------------- 1021 1022 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is 1023 begin 1024 Node.Left := Left; 1025 end Set_Left; 1026 1027 ---------------- 1028 -- Set_Parent -- 1029 ---------------- 1030 1031 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is 1032 begin 1033 Node.Parent := Parent; 1034 end Set_Parent; 1035 1036 --------------- 1037 -- Set_Right -- 1038 --------------- 1039 1040 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is 1041 begin 1042 Node.Right := Right; 1043 end Set_Right; 1044 1045 ------------------ 1046 -- Strict_Equal -- 1047 ------------------ 1048 1049 function Strict_Equal (Left, Right : Map) return Boolean is 1050 LNode : Count_Type := First (Left).Node; 1051 RNode : Count_Type := First (Right).Node; 1052 1053 begin 1054 if Length (Left) /= Length (Right) then 1055 return False; 1056 end if; 1057 1058 while LNode = RNode loop 1059 if LNode = 0 then 1060 return True; 1061 end if; 1062 1063 if Left.Nodes (LNode).Element /= Right.Nodes (RNode).Element 1064 or else Left.Nodes (LNode).Key /= Right.Nodes (RNode).Key 1065 then 1066 exit; 1067 end if; 1068 1069 LNode := Next (Left, LNode); 1070 RNode := Next (Right, RNode); 1071 end loop; 1072 1073 return False; 1074 end Strict_Equal; 1075 1076end Ada.Containers.Formal_Ordered_Maps; 1077