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-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 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 is 38 39 ----------------------------- 40 -- Node Access Subprograms -- 41 ----------------------------- 42 43 -- These subprograms provide a functional interface to access fields 44 -- of a node, and a procedural interface for modifying these values. 45 46 function Color 47 (Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type; 48 pragma Inline (Color); 49 50 function Left_Son (Node : Node_Type) return Count_Type; 51 pragma Inline (Left); 52 53 function Parent (Node : Node_Type) return Count_Type; 54 pragma Inline (Parent); 55 56 function Right_Son (Node : Node_Type) return Count_Type; 57 pragma Inline (Right); 58 59 procedure Set_Color 60 (Node : in out Node_Type; 61 Color : Ada.Containers.Red_Black_Trees.Color_Type); 62 pragma Inline (Set_Color); 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_Parent (Node : in out Node_Type; Parent : Count_Type); 71 pragma Inline (Set_Parent); 72 73 ----------------------- 74 -- Local Subprograms -- 75 ----------------------- 76 77 -- All need comments ??? 78 79 generic 80 with procedure Set_Element (Node : in out Node_Type); 81 procedure Generic_Allocate 82 (Tree : in out Tree_Types.Tree_Type'Class; 83 Node : out Count_Type); 84 85 procedure Free (Tree : in out Map; X : Count_Type); 86 87 function Is_Greater_Key_Node 88 (Left : Key_Type; 89 Right : Node_Type) return Boolean; 90 pragma Inline (Is_Greater_Key_Node); 91 92 function Is_Less_Key_Node 93 (Left : Key_Type; 94 Right : Node_Type) return Boolean; 95 pragma Inline (Is_Less_Key_Node); 96 97 -------------------------- 98 -- Local Instantiations -- 99 -------------------------- 100 101 package Tree_Operations is 102 new Red_Black_Trees.Generic_Bounded_Operations 103 (Tree_Types => Tree_Types, 104 Left => Left_Son, 105 Right => Right_Son); 106 107 use Tree_Operations; 108 109 package Key_Ops is 110 new Red_Black_Trees.Generic_Bounded_Keys 111 (Tree_Operations => Tree_Operations, 112 Key_Type => Key_Type, 113 Is_Less_Key_Node => Is_Less_Key_Node, 114 Is_Greater_Key_Node => Is_Greater_Key_Node); 115 116 --------- 117 -- "=" -- 118 --------- 119 120 function "=" (Left, Right : Map) return Boolean is 121 Lst : Count_Type; 122 Node : Count_Type; 123 ENode : Count_Type; 124 125 begin 126 if Length (Left) /= Length (Right) then 127 return False; 128 end if; 129 130 if Is_Empty (Left) then 131 return True; 132 end if; 133 134 Lst := Next (Left, Last (Left).Node); 135 136 Node := First (Left).Node; 137 while Node /= Lst loop 138 ENode := Find (Right, Left.Nodes (Node).Key).Node; 139 140 if ENode = 0 or else 141 Left.Nodes (Node).Element /= Right.Nodes (ENode).Element 142 then 143 return False; 144 end if; 145 146 Node := Next (Left, Node); 147 end loop; 148 149 return True; 150 end "="; 151 152 ------------ 153 -- Assign -- 154 ------------ 155 156 procedure Assign (Target : in out Map; Source : Map) is 157 procedure Append_Element (Source_Node : Count_Type); 158 159 procedure Append_Elements is 160 new Tree_Operations.Generic_Iteration (Append_Element); 161 162 -------------------- 163 -- Append_Element -- 164 -------------------- 165 166 procedure Append_Element (Source_Node : Count_Type) is 167 SN : Node_Type renames Source.Nodes (Source_Node); 168 169 procedure Set_Element (Node : in out Node_Type); 170 pragma Inline (Set_Element); 171 172 function New_Node return Count_Type; 173 pragma Inline (New_Node); 174 175 procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node); 176 177 procedure Unconditional_Insert_Sans_Hint is 178 new Key_Ops.Generic_Unconditional_Insert (Insert_Post); 179 180 procedure Unconditional_Insert_Avec_Hint is 181 new Key_Ops.Generic_Unconditional_Insert_With_Hint 182 (Insert_Post, 183 Unconditional_Insert_Sans_Hint); 184 185 procedure Allocate is new Generic_Allocate (Set_Element); 186 187 -------------- 188 -- New_Node -- 189 -------------- 190 191 function New_Node return Count_Type is 192 Result : Count_Type; 193 begin 194 Allocate (Target, Result); 195 return Result; 196 end New_Node; 197 198 ----------------- 199 -- Set_Element -- 200 ----------------- 201 202 procedure Set_Element (Node : in out Node_Type) is 203 begin 204 Node.Key := SN.Key; 205 Node.Element := SN.Element; 206 end Set_Element; 207 208 Target_Node : Count_Type; 209 210 -- Start of processing for Append_Element 211 212 begin 213 Unconditional_Insert_Avec_Hint 214 (Tree => Target, 215 Hint => 0, 216 Key => SN.Key, 217 Node => Target_Node); 218 end Append_Element; 219 220 -- Start of processing for Assign 221 222 begin 223 if Target'Address = Source'Address then 224 return; 225 end if; 226 227 if Target.Capacity < Length (Source) then 228 raise Storage_Error with "not enough capacity"; -- SE or CE? ??? 229 end if; 230 231 Tree_Operations.Clear_Tree (Target); 232 Append_Elements (Source); 233 end Assign; 234 235 ------------- 236 -- Ceiling -- 237 ------------- 238 239 function Ceiling (Container : Map; Key : Key_Type) return Cursor is 240 Node : constant Count_Type := Key_Ops.Ceiling (Container, Key); 241 242 begin 243 if Node = 0 then 244 return No_Element; 245 end if; 246 247 return (Node => Node); 248 end Ceiling; 249 250 ----------- 251 -- Clear -- 252 ----------- 253 254 procedure Clear (Container : in out Map) is 255 begin 256 Tree_Operations.Clear_Tree (Container); 257 end Clear; 258 259 ----------- 260 -- Color -- 261 ----------- 262 263 function Color (Node : Node_Type) return Color_Type is 264 begin 265 return Node.Color; 266 end Color; 267 268 -------------- 269 -- Contains -- 270 -------------- 271 272 function Contains (Container : Map; Key : Key_Type) return Boolean is 273 begin 274 return Find (Container, Key) /= No_Element; 275 end Contains; 276 277 ---------- 278 -- Copy -- 279 ---------- 280 281 function Copy (Source : Map; Capacity : Count_Type := 0) return Map is 282 Node : Count_Type := 1; 283 N : Count_Type; 284 285 begin 286 return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do 287 if Length (Source) > 0 then 288 Target.Length := Source.Length; 289 Target.Root := Source.Root; 290 Target.First := Source.First; 291 Target.Last := Source.Last; 292 Target.Free := Source.Free; 293 294 while Node <= Source.Capacity loop 295 Target.Nodes (Node).Element := 296 Source.Nodes (Node).Element; 297 Target.Nodes (Node).Key := 298 Source.Nodes (Node).Key; 299 Target.Nodes (Node).Parent := 300 Source.Nodes (Node).Parent; 301 Target.Nodes (Node).Left := 302 Source.Nodes (Node).Left; 303 Target.Nodes (Node).Right := 304 Source.Nodes (Node).Right; 305 Target.Nodes (Node).Color := 306 Source.Nodes (Node).Color; 307 Target.Nodes (Node).Has_Element := 308 Source.Nodes (Node).Has_Element; 309 Node := Node + 1; 310 end loop; 311 312 while Node <= Target.Capacity loop 313 N := Node; 314 Formal_Ordered_Maps.Free (Tree => Target, X => N); 315 Node := Node + 1; 316 end loop; 317 end if; 318 end return; 319 end Copy; 320 321 ------------ 322 -- Delete -- 323 ------------ 324 325 procedure Delete (Container : in out Map; Position : in out Cursor) is 326 begin 327 if not Has_Element (Container, Position) then 328 raise Constraint_Error with 329 "Position cursor of Delete has no element"; 330 end if; 331 332 pragma Assert (Vet (Container, Position.Node), 333 "Position cursor of Delete is bad"); 334 335 Tree_Operations.Delete_Node_Sans_Free (Container, 336 Position.Node); 337 Formal_Ordered_Maps.Free (Container, Position.Node); 338 end Delete; 339 340 procedure Delete (Container : in out Map; Key : Key_Type) is 341 X : constant Node_Access := Key_Ops.Find (Container, Key); 342 343 begin 344 if X = 0 then 345 raise Constraint_Error with "key not in map"; 346 end if; 347 348 Tree_Operations.Delete_Node_Sans_Free (Container, X); 349 Formal_Ordered_Maps.Free (Container, X); 350 end Delete; 351 352 ------------------ 353 -- Delete_First -- 354 ------------------ 355 356 procedure Delete_First (Container : in out Map) is 357 X : constant Node_Access := First (Container).Node; 358 begin 359 if X /= 0 then 360 Tree_Operations.Delete_Node_Sans_Free (Container, X); 361 Formal_Ordered_Maps.Free (Container, X); 362 end if; 363 end Delete_First; 364 365 ----------------- 366 -- Delete_Last -- 367 ----------------- 368 369 procedure Delete_Last (Container : in out Map) is 370 X : constant Node_Access := Last (Container).Node; 371 begin 372 if X /= 0 then 373 Tree_Operations.Delete_Node_Sans_Free (Container, X); 374 Formal_Ordered_Maps.Free (Container, X); 375 end if; 376 end Delete_Last; 377 378 ------------- 379 -- Element -- 380 ------------- 381 382 function Element (Container : Map; Position : Cursor) return Element_Type is 383 begin 384 if not Has_Element (Container, Position) then 385 raise Constraint_Error with 386 "Position cursor of function Element has no element"; 387 end if; 388 389 pragma Assert (Vet (Container, Position.Node), 390 "Position cursor of function Element is bad"); 391 392 return Container.Nodes (Position.Node).Element; 393 394 end Element; 395 396 function Element (Container : Map; Key : Key_Type) return Element_Type is 397 Node : constant Node_Access := Find (Container, Key).Node; 398 399 begin 400 if Node = 0 then 401 raise Constraint_Error with "key not in map"; 402 end if; 403 404 return Container.Nodes (Node).Element; 405 end Element; 406 407 --------------------- 408 -- Equivalent_Keys -- 409 --------------------- 410 411 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is 412 begin 413 if Left < Right 414 or else Right < Left 415 then 416 return False; 417 else 418 return True; 419 end if; 420 end Equivalent_Keys; 421 422 ------------- 423 -- Exclude -- 424 ------------- 425 426 procedure Exclude (Container : in out Map; Key : Key_Type) is 427 X : constant Node_Access := Key_Ops.Find (Container, Key); 428 begin 429 if X /= 0 then 430 Tree_Operations.Delete_Node_Sans_Free (Container, X); 431 Formal_Ordered_Maps.Free (Container, X); 432 end if; 433 end Exclude; 434 435 ---------- 436 -- Find -- 437 ---------- 438 439 function Find (Container : Map; Key : Key_Type) return Cursor is 440 Node : constant Count_Type := Key_Ops.Find (Container, Key); 441 442 begin 443 if Node = 0 then 444 return No_Element; 445 end if; 446 447 return (Node => Node); 448 end Find; 449 450 ----------- 451 -- First -- 452 ----------- 453 454 function First (Container : Map) return Cursor is 455 begin 456 if Length (Container) = 0 then 457 return No_Element; 458 end if; 459 460 return (Node => Container.First); 461 end First; 462 463 ------------------- 464 -- First_Element -- 465 ------------------- 466 467 function First_Element (Container : Map) return Element_Type is 468 begin 469 if Is_Empty (Container) then 470 raise Constraint_Error with "map is empty"; 471 end if; 472 473 return Container.Nodes (First (Container).Node).Element; 474 end First_Element; 475 476 --------------- 477 -- First_Key -- 478 --------------- 479 480 function First_Key (Container : Map) return Key_Type is 481 begin 482 if Is_Empty (Container) then 483 raise Constraint_Error with "map is empty"; 484 end if; 485 486 return Container.Nodes (First (Container).Node).Key; 487 end First_Key; 488 489 ----------- 490 -- Floor -- 491 ----------- 492 493 function Floor (Container : Map; Key : Key_Type) return Cursor is 494 Node : constant Count_Type := Key_Ops.Floor (Container, Key); 495 496 begin 497 if Node = 0 then 498 return No_Element; 499 end if; 500 501 return (Node => Node); 502 end Floor; 503 504 ---------- 505 -- Free -- 506 ---------- 507 508 procedure Free 509 (Tree : in out Map; 510 X : Count_Type) 511 is 512 begin 513 Tree.Nodes (X).Has_Element := False; 514 Tree_Operations.Free (Tree, X); 515 end Free; 516 517 ---------------------- 518 -- Generic_Allocate -- 519 ---------------------- 520 521 procedure Generic_Allocate 522 (Tree : in out Tree_Types.Tree_Type'Class; 523 Node : out Count_Type) 524 is 525 procedure Allocate is 526 new Tree_Operations.Generic_Allocate (Set_Element); 527 begin 528 Allocate (Tree, Node); 529 Tree.Nodes (Node).Has_Element := True; 530 end Generic_Allocate; 531 532 ----------------- 533 -- Has_Element -- 534 ----------------- 535 536 function Has_Element (Container : Map; Position : Cursor) return Boolean is 537 begin 538 if Position.Node = 0 then 539 return False; 540 end if; 541 542 return Container.Nodes (Position.Node).Has_Element; 543 end Has_Element; 544 545 ------------- 546 -- Include -- 547 ------------- 548 549 procedure Include 550 (Container : in out Map; 551 Key : Key_Type; 552 New_Item : Element_Type) 553 is 554 Position : Cursor; 555 Inserted : Boolean; 556 557 begin 558 Insert (Container, Key, New_Item, Position, Inserted); 559 560 if not Inserted then 561 if Container.Lock > 0 then 562 raise Program_Error with 563 "attempt to tamper with cursors (map is locked)"; 564 end if; 565 566 declare 567 N : Node_Type renames Container.Nodes (Position.Node); 568 begin 569 N.Key := Key; 570 N.Element := New_Item; 571 end; 572 end if; 573 end Include; 574 575 procedure Insert 576 (Container : in out Map; 577 Key : Key_Type; 578 New_Item : Element_Type; 579 Position : out Cursor; 580 Inserted : out Boolean) 581 is 582 function New_Node return Node_Access; 583 -- Comment ??? 584 585 procedure Insert_Post is 586 new Key_Ops.Generic_Insert_Post (New_Node); 587 588 procedure Insert_Sans_Hint is 589 new Key_Ops.Generic_Conditional_Insert (Insert_Post); 590 591 -------------- 592 -- New_Node -- 593 -------------- 594 595 function New_Node return Node_Access is 596 procedure Initialize (Node : in out Node_Type); 597 procedure Allocate_Node is new Generic_Allocate (Initialize); 598 599 procedure Initialize (Node : in out Node_Type) is 600 begin 601 Node.Key := Key; 602 Node.Element := New_Item; 603 end Initialize; 604 605 X : Node_Access; 606 607 begin 608 Allocate_Node (Container, X); 609 return X; 610 end New_Node; 611 612 -- Start of processing for Insert 613 614 begin 615 Insert_Sans_Hint 616 (Container, 617 Key, 618 Position.Node, 619 Inserted); 620 end Insert; 621 622 procedure Insert 623 (Container : in out Map; 624 Key : Key_Type; 625 New_Item : Element_Type) 626 is 627 Position : Cursor; 628 Inserted : Boolean; 629 630 begin 631 Insert (Container, Key, New_Item, Position, Inserted); 632 633 if not Inserted then 634 raise Constraint_Error with "key already in map"; 635 end if; 636 end Insert; 637 638 ------------ 639 -- Insert -- 640 ------------ 641 642 procedure Insert 643 (Container : in out Map; 644 Key : Key_Type; 645 Position : out Cursor; 646 Inserted : out Boolean) 647 is 648 function New_Node return Node_Access; 649 650 procedure Insert_Post is 651 new Key_Ops.Generic_Insert_Post (New_Node); 652 653 procedure Insert_Sans_Hint is 654 new Key_Ops.Generic_Conditional_Insert (Insert_Post); 655 656 -------------- 657 -- New_Node -- 658 -------------- 659 660 function New_Node return Node_Access is 661 procedure Initialize (Node : in out Node_Type); 662 procedure Allocate_Node is new Generic_Allocate (Initialize); 663 664 ---------------- 665 -- Initialize -- 666 ---------------- 667 668 procedure Initialize (Node : in out Node_Type) is 669 begin 670 Node.Key := Key; 671 end Initialize; 672 673 X : Node_Access; 674 675 -- Start of processing for New_Node 676 677 begin 678 Allocate_Node (Container, X); 679 return X; 680 end New_Node; 681 682 -- Start of processing for Insert 683 684 begin 685 Insert_Sans_Hint (Container, Key, Position.Node, Inserted); 686 end Insert; 687 688 -------------- 689 -- Is_Empty -- 690 -------------- 691 692 function Is_Empty (Container : Map) return Boolean is 693 begin 694 return Length (Container) = 0; 695 end Is_Empty; 696 697 ------------------------- 698 -- Is_Greater_Key_Node -- 699 ------------------------- 700 701 function Is_Greater_Key_Node 702 (Left : Key_Type; 703 Right : Node_Type) return Boolean 704 is 705 begin 706 -- k > node same as node < k 707 708 return Right.Key < Left; 709 end Is_Greater_Key_Node; 710 711 ---------------------- 712 -- Is_Less_Key_Node -- 713 ---------------------- 714 715 function Is_Less_Key_Node 716 (Left : Key_Type; 717 Right : Node_Type) return Boolean 718 is 719 begin 720 return Left < Right.Key; 721 end Is_Less_Key_Node; 722 723 ------------- 724 -- Iterate -- 725 ------------- 726 727 procedure Iterate 728 (Container : Map; 729 Process : 730 not null access procedure (Container : Map; Position : Cursor)) 731 is 732 procedure Process_Node (Node : Node_Access); 733 pragma Inline (Process_Node); 734 735 procedure Local_Iterate is 736 new Tree_Operations.Generic_Iteration (Process_Node); 737 738 ------------------ 739 -- Process_Node -- 740 ------------------ 741 742 procedure Process_Node (Node : Node_Access) is 743 begin 744 Process (Container, (Node => Node)); 745 end Process_Node; 746 747 B : Natural renames Container'Unrestricted_Access.Busy; 748 749 -- Start of processing for Iterate 750 751 begin 752 B := B + 1; 753 754 begin 755 Local_Iterate (Container); 756 exception 757 when others => 758 B := B - 1; 759 raise; 760 end; 761 762 B := B - 1; 763 end Iterate; 764 765 --------- 766 -- Key -- 767 --------- 768 769 function Key (Container : Map; Position : Cursor) return Key_Type is 770 begin 771 if not Has_Element (Container, Position) then 772 raise Constraint_Error with 773 "Position cursor of function Key has no element"; 774 end if; 775 776 pragma Assert (Vet (Container, Position.Node), 777 "Position cursor of function Key is bad"); 778 779 return Container.Nodes (Position.Node).Key; 780 end Key; 781 782 ---------- 783 -- Last -- 784 ---------- 785 786 function Last (Container : Map) return Cursor is 787 begin 788 if Length (Container) = 0 then 789 return No_Element; 790 end if; 791 792 return (Node => Container.Last); 793 end Last; 794 795 ------------------ 796 -- Last_Element -- 797 ------------------ 798 799 function Last_Element (Container : Map) return Element_Type is 800 begin 801 if Is_Empty (Container) then 802 raise Constraint_Error with "map is empty"; 803 end if; 804 805 return Container.Nodes (Last (Container).Node).Element; 806 end Last_Element; 807 808 -------------- 809 -- Last_Key -- 810 -------------- 811 812 function Last_Key (Container : Map) return Key_Type is 813 begin 814 if Is_Empty (Container) then 815 raise Constraint_Error with "map is empty"; 816 end if; 817 818 return Container.Nodes (Last (Container).Node).Key; 819 end Last_Key; 820 821 ---------- 822 -- Left -- 823 ---------- 824 825 function Left (Container : Map; Position : Cursor) return Map is 826 Curs : Cursor := Position; 827 C : Map (Container.Capacity) := Copy (Container, Container.Capacity); 828 Node : Count_Type; 829 830 begin 831 if Curs = No_Element then 832 return C; 833 end if; 834 835 if not Has_Element (Container, Curs) then 836 raise Constraint_Error; 837 end if; 838 839 while Curs.Node /= 0 loop 840 Node := Curs.Node; 841 Delete (C, Curs); 842 Curs := Next (Container, (Node => Node)); 843 end loop; 844 845 return C; 846 end Left; 847 848 -------------- 849 -- Left_Son -- 850 -------------- 851 852 function Left_Son (Node : Node_Type) return Count_Type is 853 begin 854 return Node.Left; 855 end Left_Son; 856 857 ------------ 858 -- Length -- 859 ------------ 860 861 function Length (Container : Map) return Count_Type is 862 begin 863 return Container.Length; 864 end Length; 865 866 ---------- 867 -- Move -- 868 ---------- 869 870 procedure Move (Target : in out Map; Source : in out Map) is 871 NN : Tree_Types.Nodes_Type renames Source.Nodes; 872 X : Node_Access; 873 874 begin 875 if Target'Address = Source'Address then 876 return; 877 end if; 878 879 if Target.Capacity < Length (Source) then 880 raise Constraint_Error with -- ??? 881 "Source length exceeds Target capacity"; 882 end if; 883 884 if Source.Busy > 0 then 885 raise Program_Error with 886 "attempt to tamper with cursors of Source (list is busy)"; 887 end if; 888 889 Clear (Target); 890 891 loop 892 X := First (Source).Node; 893 exit when X = 0; 894 895 -- Here we insert a copy of the source element into the target, and 896 -- then delete the element from the source. Another possibility is 897 -- that delete it first (and hang onto its index), then insert it. 898 -- ??? 899 900 Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? 901 902 Tree_Operations.Delete_Node_Sans_Free (Source, X); 903 Formal_Ordered_Maps.Free (Source, X); 904 end loop; 905 end Move; 906 907 ---------- 908 -- Next -- 909 ---------- 910 911 procedure Next (Container : Map; Position : in out Cursor) is 912 begin 913 Position := Next (Container, Position); 914 end Next; 915 916 function Next (Container : Map; Position : Cursor) return Cursor is 917 begin 918 if Position = No_Element then 919 return No_Element; 920 end if; 921 922 if not Has_Element (Container, Position) then 923 raise Constraint_Error; 924 end if; 925 926 pragma Assert (Vet (Container, Position.Node), 927 "bad cursor in Next"); 928 929 return (Node => Tree_Operations.Next (Container, Position.Node)); 930 end Next; 931 932 ------------- 933 -- Overlap -- 934 ------------- 935 936 function Overlap (Left, Right : Map) return Boolean is 937 begin 938 if Length (Left) = 0 or Length (Right) = 0 then 939 return False; 940 end if; 941 942 declare 943 L_Node : Count_Type := First (Left).Node; 944 R_Node : Count_Type := First (Right).Node; 945 L_Last : constant Count_Type := Next (Left, Last (Left).Node); 946 R_Last : constant Count_Type := Next (Right, Last (Right).Node); 947 948 begin 949 if Left'Address = Right'Address then 950 return True; 951 end if; 952 953 loop 954 if L_Node = L_Last 955 or else R_Node = R_Last 956 then 957 return False; 958 end if; 959 960 if Left.Nodes (L_Node).Key < Right.Nodes (R_Node).Key then 961 L_Node := Next (Left, L_Node); 962 963 elsif Right.Nodes (R_Node).Key < Left.Nodes (L_Node).Key then 964 R_Node := Next (Right, R_Node); 965 966 else 967 return True; 968 end if; 969 end loop; 970 end; 971 end Overlap; 972 973 ------------ 974 -- Parent -- 975 ------------ 976 977 function Parent (Node : Node_Type) return Count_Type is 978 begin 979 return Node.Parent; 980 end Parent; 981 982 -------------- 983 -- Previous -- 984 -------------- 985 986 procedure Previous (Container : Map; Position : in out Cursor) is 987 begin 988 Position := Previous (Container, Position); 989 end Previous; 990 991 function Previous (Container : Map; Position : Cursor) return Cursor is 992 begin 993 if Position = No_Element then 994 return No_Element; 995 end if; 996 997 if not Has_Element (Container, Position) then 998 raise Constraint_Error; 999 end if; 1000 1001 pragma Assert (Vet (Container, Position.Node), 1002 "bad cursor in Previous"); 1003 1004 declare 1005 Node : constant Count_Type := 1006 Tree_Operations.Previous (Container, Position.Node); 1007 1008 begin 1009 if Node = 0 then 1010 return No_Element; 1011 end if; 1012 1013 return (Node => Node); 1014 end; 1015 end Previous; 1016 1017 ------------------- 1018 -- Query_Element -- 1019 ------------------- 1020 1021 procedure Query_Element 1022 (Container : in out Map; 1023 Position : Cursor; 1024 Process : not null access procedure (Key : Key_Type; 1025 Element : Element_Type)) 1026 is 1027 begin 1028 if not Has_Element (Container, Position) then 1029 raise Constraint_Error with 1030 "Position cursor of Query_Element has no element"; 1031 end if; 1032 1033 pragma Assert (Vet (Container, Position.Node), 1034 "Position cursor of Query_Element is bad"); 1035 1036 declare 1037 B : Natural renames Container.Busy; 1038 L : Natural renames Container.Lock; 1039 1040 begin 1041 B := B + 1; 1042 L := L + 1; 1043 1044 declare 1045 N : Node_Type renames Container.Nodes (Position.Node); 1046 K : Key_Type renames N.Key; 1047 E : Element_Type renames N.Element; 1048 1049 begin 1050 Process (K, E); 1051 exception 1052 when others => 1053 L := L - 1; 1054 B := B - 1; 1055 raise; 1056 end; 1057 1058 L := L - 1; 1059 B := B - 1; 1060 end; 1061 end Query_Element; 1062 1063 ---------- 1064 -- Read -- 1065 ---------- 1066 1067 procedure Read 1068 (Stream : not null access Root_Stream_Type'Class; 1069 Container : out Map) 1070 is 1071 procedure Read_Element (Node : in out Node_Type); 1072 pragma Inline (Read_Element); 1073 1074 procedure Allocate is 1075 new Generic_Allocate (Read_Element); 1076 1077 procedure Read_Elements is 1078 new Tree_Operations.Generic_Read (Allocate); 1079 1080 ------------------ 1081 -- Read_Element -- 1082 ------------------ 1083 1084 procedure Read_Element (Node : in out Node_Type) is 1085 begin 1086 Key_Type'Read (Stream, Node.Key); 1087 Element_Type'Read (Stream, Node.Element); 1088 end Read_Element; 1089 1090 -- Start of processing for Read 1091 1092 begin 1093 Read_Elements (Stream, Container); 1094 end Read; 1095 1096 procedure Read 1097 (Stream : not null access Root_Stream_Type'Class; 1098 Item : out Cursor) 1099 is 1100 begin 1101 raise Program_Error with "attempt to stream map cursor"; 1102 end Read; 1103 1104 ------------- 1105 -- Replace -- 1106 ------------- 1107 1108 procedure Replace 1109 (Container : in out Map; 1110 Key : Key_Type; 1111 New_Item : Element_Type) 1112 is 1113 begin 1114 declare 1115 Node : constant Node_Access := Key_Ops.Find (Container, Key); 1116 1117 begin 1118 if Node = 0 then 1119 raise Constraint_Error with "key not in map"; 1120 end if; 1121 1122 if Container.Lock > 0 then 1123 raise Program_Error with 1124 "attempt to tamper with cursors (map is locked)"; 1125 end if; 1126 1127 declare 1128 N : Node_Type renames Container.Nodes (Node); 1129 begin 1130 N.Key := Key; 1131 N.Element := New_Item; 1132 end; 1133 end; 1134 end Replace; 1135 1136 --------------------- 1137 -- Replace_Element -- 1138 --------------------- 1139 1140 procedure Replace_Element 1141 (Container : in out Map; 1142 Position : Cursor; 1143 New_Item : Element_Type) 1144 is 1145 begin 1146 if not Has_Element (Container, Position) then 1147 raise Constraint_Error with 1148 "Position cursor of Replace_Element has no element"; 1149 end if; 1150 1151 if Container.Lock > 0 then 1152 raise Program_Error with 1153 "attempt to tamper with cursors (map is locked)"; 1154 end if; 1155 1156 pragma Assert (Vet (Container, Position.Node), 1157 "Position cursor of Replace_Element is bad"); 1158 1159 Container.Nodes (Position.Node).Element := New_Item; 1160 end Replace_Element; 1161 1162 --------------------- 1163 -- Reverse_Iterate -- 1164 --------------------- 1165 1166 procedure Reverse_Iterate 1167 (Container : Map; 1168 Process : not null access procedure (Container : Map; 1169 Position : Cursor)) 1170 is 1171 procedure Process_Node (Node : Node_Access); 1172 pragma Inline (Process_Node); 1173 1174 procedure Local_Reverse_Iterate is 1175 new Tree_Operations.Generic_Reverse_Iteration (Process_Node); 1176 1177 ------------------ 1178 -- Process_Node -- 1179 ------------------ 1180 1181 procedure Process_Node (Node : Node_Access) is 1182 begin 1183 Process (Container, (Node => Node)); 1184 end Process_Node; 1185 1186 B : Natural renames Container'Unrestricted_Access.Busy; 1187 1188 -- Start of processing for Reverse_Iterate 1189 1190 begin 1191 B := B + 1; 1192 1193 begin 1194 Local_Reverse_Iterate (Container); 1195 exception 1196 when others => 1197 B := B - 1; 1198 raise; 1199 end; 1200 1201 B := B - 1; 1202 end Reverse_Iterate; 1203 1204 ----------- 1205 -- Right -- 1206 ----------- 1207 1208 function Right (Container : Map; Position : Cursor) return Map is 1209 Curs : Cursor := First (Container); 1210 C : Map (Container.Capacity) := Copy (Container, Container.Capacity); 1211 Node : Count_Type; 1212 1213 begin 1214 if Curs = No_Element then 1215 Clear (C); 1216 return C; 1217 1218 end if; 1219 if Position /= No_Element and not Has_Element (Container, Position) then 1220 raise Constraint_Error; 1221 end if; 1222 1223 while Curs.Node /= Position.Node loop 1224 Node := Curs.Node; 1225 Delete (C, Curs); 1226 Curs := Next (Container, (Node => Node)); 1227 end loop; 1228 1229 return C; 1230 end Right; 1231 1232 --------------- 1233 -- Right_Son -- 1234 --------------- 1235 1236 function Right_Son (Node : Node_Type) return Count_Type is 1237 begin 1238 return Node.Right; 1239 end Right_Son; 1240 1241 --------------- 1242 -- Set_Color -- 1243 --------------- 1244 1245 procedure Set_Color (Node : in out Node_Type; Color : Color_Type) is 1246 begin 1247 Node.Color := Color; 1248 end Set_Color; 1249 1250 -------------- 1251 -- Set_Left -- 1252 -------------- 1253 1254 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is 1255 begin 1256 Node.Left := Left; 1257 end Set_Left; 1258 1259 ---------------- 1260 -- Set_Parent -- 1261 ---------------- 1262 1263 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is 1264 begin 1265 Node.Parent := Parent; 1266 end Set_Parent; 1267 1268 --------------- 1269 -- Set_Right -- 1270 --------------- 1271 1272 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is 1273 begin 1274 Node.Right := Right; 1275 end Set_Right; 1276 1277 ------------------ 1278 -- Strict_Equal -- 1279 ------------------ 1280 1281 function Strict_Equal (Left, Right : Map) return Boolean is 1282 LNode : Count_Type := First (Left).Node; 1283 RNode : Count_Type := First (Right).Node; 1284 1285 begin 1286 if Length (Left) /= Length (Right) then 1287 return False; 1288 end if; 1289 1290 while LNode = RNode loop 1291 if LNode = 0 then 1292 return True; 1293 end if; 1294 1295 if Left.Nodes (LNode).Element /= Right.Nodes (RNode).Element 1296 or else Left.Nodes (LNode).Key /= Right.Nodes (RNode).Key 1297 then 1298 exit; 1299 end if; 1300 1301 LNode := Next (Left, LNode); 1302 RNode := Next (Right, RNode); 1303 end loop; 1304 1305 return False; 1306 end Strict_Equal; 1307 1308 -------------------- 1309 -- Update_Element -- 1310 -------------------- 1311 1312 procedure Update_Element 1313 (Container : in out Map; 1314 Position : Cursor; 1315 Process : not null access procedure (Key : Key_Type; 1316 Element : in out Element_Type)) 1317 is 1318 begin 1319 if not Has_Element (Container, Position) then 1320 raise Constraint_Error with 1321 "Position cursor of Update_Element has no element"; 1322 end if; 1323 1324 pragma Assert (Vet (Container, Position.Node), 1325 "Position cursor of Update_Element is bad"); 1326 1327 declare 1328 B : Natural renames Container.Busy; 1329 L : Natural renames Container.Lock; 1330 1331 begin 1332 B := B + 1; 1333 L := L + 1; 1334 1335 declare 1336 N : Node_Type renames Container.Nodes (Position.Node); 1337 K : Key_Type renames N.Key; 1338 E : Element_Type renames N.Element; 1339 1340 begin 1341 Process (K, E); 1342 exception 1343 when others => 1344 L := L - 1; 1345 B := B - 1; 1346 raise; 1347 end; 1348 1349 L := L - 1; 1350 B := B - 1; 1351 end; 1352 end Update_Element; 1353 1354 ----------- 1355 -- Write -- 1356 ----------- 1357 1358 procedure Write 1359 (Stream : not null access Root_Stream_Type'Class; 1360 Container : Map) 1361 is 1362 procedure Write_Node 1363 (Stream : not null access Root_Stream_Type'Class; 1364 Node : Node_Type); 1365 pragma Inline (Write_Node); 1366 1367 procedure Write_Nodes is 1368 new Tree_Operations.Generic_Write (Write_Node); 1369 1370 ---------------- 1371 -- Write_Node -- 1372 ---------------- 1373 1374 procedure Write_Node 1375 (Stream : not null access Root_Stream_Type'Class; 1376 Node : Node_Type) 1377 is 1378 begin 1379 Key_Type'Write (Stream, Node.Key); 1380 Element_Type'Write (Stream, Node.Element); 1381 end Write_Node; 1382 1383 -- Start of processing for Write 1384 1385 begin 1386 Write_Nodes (Stream, Container); 1387 end Write; 1388 1389 procedure Write 1390 (Stream : not null access Root_Stream_Type'Class; 1391 Item : Cursor) 1392 is 1393 begin 1394 raise Program_Error with "attempt to stream map cursor"; 1395 end Write; 1396 1397end Ada.Containers.Formal_Ordered_Maps; 1398