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 _ H A S H 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.Hash_Tables.Generic_Bounded_Operations; 29pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); 30 31with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; 32pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); 33 34with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; 35 36with System; use type System.Address; 37 38package body Ada.Containers.Formal_Hashed_Maps is 39 40 ----------------------- 41 -- Local Subprograms -- 42 ----------------------- 43 44 -- All local subprograms require comments ??? 45 46 function Equivalent_Keys 47 (Key : Key_Type; 48 Node : Node_Type) return Boolean; 49 pragma Inline (Equivalent_Keys); 50 51 procedure Free 52 (HT : in out Map; 53 X : Count_Type); 54 55 generic 56 with procedure Set_Element (Node : in out Node_Type); 57 procedure Generic_Allocate 58 (HT : in out Map; 59 Node : out Count_Type); 60 61 function Hash_Node (Node : Node_Type) return Hash_Type; 62 pragma Inline (Hash_Node); 63 64 function Next (Node : Node_Type) return Count_Type; 65 pragma Inline (Next); 66 67 procedure Set_Next (Node : in out Node_Type; Next : Count_Type); 68 pragma Inline (Set_Next); 69 70 function Vet (Container : Map; Position : Cursor) return Boolean; 71 72 -------------------------- 73 -- Local Instantiations -- 74 -------------------------- 75 76 package HT_Ops is 77 new Hash_Tables.Generic_Bounded_Operations 78 (HT_Types => HT_Types, 79 Hash_Node => Hash_Node, 80 Next => Next, 81 Set_Next => Set_Next); 82 83 package Key_Ops is 84 new Hash_Tables.Generic_Bounded_Keys 85 (HT_Types => HT_Types, 86 Next => Next, 87 Set_Next => Set_Next, 88 Key_Type => Key_Type, 89 Hash => Hash, 90 Equivalent_Keys => Equivalent_Keys); 91 92 --------- 93 -- "=" -- 94 --------- 95 96 function "=" (Left, Right : Map) return Boolean is 97 begin 98 if Length (Left) /= Length (Right) then 99 return False; 100 end if; 101 102 if Length (Left) = 0 then 103 return True; 104 end if; 105 106 declare 107 Node : Count_Type; 108 ENode : Count_Type; 109 110 begin 111 Node := Left.First.Node; 112 while Node /= 0 loop 113 ENode := Find (Container => Right, 114 Key => Left.Nodes (Node).Key).Node; 115 116 if ENode = 0 or else 117 Right.Nodes (ENode).Element /= Left.Nodes (Node).Element 118 then 119 return False; 120 end if; 121 122 Node := HT_Ops.Next (Left, Node); 123 end loop; 124 125 return True; 126 end; 127 end "="; 128 129 ------------ 130 -- Assign -- 131 ------------ 132 133 procedure Assign (Target : in out Map; Source : Map) is 134 procedure Insert_Element (Source_Node : Count_Type); 135 pragma Inline (Insert_Element); 136 137 procedure Insert_Elements is 138 new HT_Ops.Generic_Iteration (Insert_Element); 139 140 -------------------- 141 -- Insert_Element -- 142 -------------------- 143 144 procedure Insert_Element (Source_Node : Count_Type) is 145 N : Node_Type renames Source.Nodes (Source_Node); 146 begin 147 Target.Insert (N.Key, N.Element); 148 end Insert_Element; 149 150 -- Start of processing for Assign 151 152 begin 153 if Target'Address = Source'Address then 154 return; 155 end if; 156 157 if Target.Capacity < Length (Source) then 158 raise Constraint_Error with -- correct exception ??? 159 "Source length exceeds Target capacity"; 160 end if; 161 162 -- Check busy bits 163 164 Clear (Target); 165 166 Insert_Elements (Source); 167 end Assign; 168 169 -------------- 170 -- Capacity -- 171 -------------- 172 173 function Capacity (Container : Map) return Count_Type is 174 begin 175 return Container.Nodes'Length; 176 end Capacity; 177 178 ----------- 179 -- Clear -- 180 ----------- 181 182 procedure Clear (Container : in out Map) is 183 begin 184 HT_Ops.Clear (Container); 185 end Clear; 186 187 -------------- 188 -- Contains -- 189 -------------- 190 191 function Contains (Container : Map; Key : Key_Type) return Boolean is 192 begin 193 return Find (Container, Key) /= No_Element; 194 end Contains; 195 196 ---------- 197 -- Copy -- 198 ---------- 199 200 function Copy 201 (Source : Map; 202 Capacity : Count_Type := 0) return Map 203 is 204 C : constant Count_Type := 205 Count_Type'Max (Capacity, Source.Capacity); 206 H : Hash_Type; 207 N : Count_Type; 208 Target : Map (C, Source.Modulus); 209 Cu : Cursor; 210 211 begin 212 Target.Length := Source.Length; 213 Target.Free := Source.Free; 214 215 H := 1; 216 while H <= Source.Modulus loop 217 Target.Buckets (H) := Source.Buckets (H); 218 H := H + 1; 219 end loop; 220 221 N := 1; 222 while N <= Source.Capacity loop 223 Target.Nodes (N) := Source.Nodes (N); 224 N := N + 1; 225 end loop; 226 227 while N <= C loop 228 Cu := (Node => N); 229 Free (Target, Cu.Node); 230 N := N + 1; 231 end loop; 232 233 return Target; 234 end Copy; 235 236 --------------------- 237 -- Default_Modulus -- 238 --------------------- 239 240 function Default_Modulus (Capacity : Count_Type) return Hash_Type is 241 begin 242 return To_Prime (Capacity); 243 end Default_Modulus; 244 245 ------------ 246 -- Delete -- 247 ------------ 248 249 procedure Delete (Container : in out Map; Key : Key_Type) is 250 X : Count_Type; 251 252 begin 253 Key_Ops.Delete_Key_Sans_Free (Container, Key, X); 254 255 if X = 0 then 256 raise Constraint_Error with "attempt to delete key not in map"; 257 end if; 258 259 Free (Container, X); 260 end Delete; 261 262 procedure Delete (Container : in out Map; Position : in out Cursor) is 263 begin 264 if not Has_Element (Container, Position) then 265 raise Constraint_Error with 266 "Position cursor of Delete has no element"; 267 end if; 268 269 if Container.Busy > 0 then 270 raise Program_Error with 271 "Delete attempted to tamper with elements (map is busy)"; 272 end if; 273 274 pragma Assert (Vet (Container, Position), "bad cursor in Delete"); 275 276 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); 277 278 Free (Container, Position.Node); 279 end Delete; 280 281 ------------- 282 -- Element -- 283 ------------- 284 285 function Element (Container : Map; Key : Key_Type) return Element_Type is 286 Node : constant Count_Type := Find (Container, Key).Node; 287 288 begin 289 if Node = 0 then 290 raise Constraint_Error with 291 "no element available because key not in map"; 292 end if; 293 294 return Container.Nodes (Node).Element; 295 end Element; 296 297 function Element (Container : Map; Position : Cursor) return Element_Type is 298 begin 299 if not Has_Element (Container, Position) then 300 raise Constraint_Error with "Position cursor equals No_Element"; 301 end if; 302 303 pragma Assert (Vet (Container, Position), 304 "bad cursor in function Element"); 305 306 return Container.Nodes (Position.Node).Element; 307 end Element; 308 309 --------------------- 310 -- Equivalent_Keys -- 311 --------------------- 312 313 function Equivalent_Keys 314 (Key : Key_Type; 315 Node : Node_Type) return Boolean 316 is 317 begin 318 return Equivalent_Keys (Key, Node.Key); 319 end Equivalent_Keys; 320 321 function Equivalent_Keys 322 (Left : Map; 323 CLeft : Cursor; 324 Right : Map; 325 CRight : Cursor) return Boolean 326 is 327 begin 328 if not Has_Element (Left, CLeft) then 329 raise Constraint_Error with 330 "Left cursor of Equivalent_Keys has no element"; 331 end if; 332 333 if not Has_Element (Right, CRight) then 334 raise Constraint_Error with 335 "Right cursor of Equivalent_Keys has no element"; 336 end if; 337 338 pragma Assert (Vet (Left, CLeft), 339 "Left cursor of Equivalent_Keys is bad"); 340 pragma Assert (Vet (Right, CRight), 341 "Right cursor of Equivalent_Keys is bad"); 342 343 declare 344 LN : Node_Type renames Left.Nodes (CLeft.Node); 345 RN : Node_Type renames Right.Nodes (CRight.Node); 346 begin 347 return Equivalent_Keys (LN.Key, RN.Key); 348 end; 349 end Equivalent_Keys; 350 351 function Equivalent_Keys 352 (Left : Map; 353 CLeft : Cursor; 354 Right : Key_Type) return Boolean 355 is 356 begin 357 if not Has_Element (Left, CLeft) then 358 raise Constraint_Error with 359 "Left cursor of Equivalent_Keys has no element"; 360 end if; 361 362 pragma Assert (Vet (Left, CLeft), 363 "Left cursor in Equivalent_Keys is bad"); 364 365 declare 366 LN : Node_Type renames Left.Nodes (CLeft.Node); 367 begin 368 return Equivalent_Keys (LN.Key, Right); 369 end; 370 end Equivalent_Keys; 371 372 function Equivalent_Keys 373 (Left : Key_Type; 374 Right : Map; 375 CRight : Cursor) return Boolean 376 is 377 begin 378 if Has_Element (Right, CRight) then 379 raise Constraint_Error with 380 "Right cursor of Equivalent_Keys has no element"; 381 end if; 382 383 pragma Assert (Vet (Right, CRight), 384 "Right cursor of Equivalent_Keys is bad"); 385 386 declare 387 RN : Node_Type renames Right.Nodes (CRight.Node); 388 389 begin 390 return Equivalent_Keys (Left, RN.Key); 391 end; 392 end Equivalent_Keys; 393 394 ------------- 395 -- Exclude -- 396 ------------- 397 398 procedure Exclude (Container : in out Map; Key : Key_Type) is 399 X : Count_Type; 400 begin 401 Key_Ops.Delete_Key_Sans_Free (Container, Key, X); 402 Free (Container, X); 403 end Exclude; 404 405 ---------- 406 -- Find -- 407 ---------- 408 409 function Find (Container : Map; Key : Key_Type) return Cursor is 410 Node : constant Count_Type := Key_Ops.Find (Container, Key); 411 412 begin 413 if Node = 0 then 414 return No_Element; 415 end if; 416 417 return (Node => Node); 418 end Find; 419 420 ----------- 421 -- First -- 422 ----------- 423 424 function First (Container : Map) return Cursor is 425 Node : constant Count_Type := HT_Ops.First (Container); 426 427 begin 428 if Node = 0 then 429 return No_Element; 430 end if; 431 432 return (Node => Node); 433 end First; 434 435 ---------- 436 -- Free -- 437 ---------- 438 439 procedure Free (HT : in out Map; X : Count_Type) is 440 begin 441 HT.Nodes (X).Has_Element := False; 442 HT_Ops.Free (HT, X); 443 end Free; 444 445 ---------------------- 446 -- Generic_Allocate -- 447 ---------------------- 448 449 procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is 450 451 procedure Allocate is 452 new HT_Ops.Generic_Allocate (Set_Element); 453 454 begin 455 Allocate (HT, Node); 456 HT.Nodes (Node).Has_Element := True; 457 end Generic_Allocate; 458 459 ----------------- 460 -- Has_Element -- 461 ----------------- 462 463 function Has_Element (Container : Map; Position : Cursor) return Boolean is 464 begin 465 if Position.Node = 0 or else 466 not Container.Nodes (Position.Node).Has_Element then 467 return False; 468 end if; 469 470 return True; 471 end Has_Element; 472 473 --------------- 474 -- Hash_Node -- 475 --------------- 476 477 function Hash_Node (Node : Node_Type) return Hash_Type is 478 begin 479 return Hash (Node.Key); 480 end Hash_Node; 481 482 ------------- 483 -- Include -- 484 ------------- 485 486 procedure Include 487 (Container : in out Map; 488 Key : Key_Type; 489 New_Item : Element_Type) 490 is 491 Position : Cursor; 492 Inserted : Boolean; 493 494 begin 495 Insert (Container, Key, New_Item, Position, Inserted); 496 497 if not Inserted then 498 if Container.Lock > 0 then 499 raise Program_Error with 500 "Include attempted to tamper with cursors (map is locked)"; 501 end if; 502 503 declare 504 N : Node_Type renames Container.Nodes (Position.Node); 505 begin 506 N.Key := Key; 507 N.Element := New_Item; 508 end; 509 end if; 510 end Include; 511 512 ------------ 513 -- Insert -- 514 ------------ 515 516 procedure Insert 517 (Container : in out Map; 518 Key : Key_Type; 519 Position : out Cursor; 520 Inserted : out Boolean) 521 is 522 procedure Assign_Key (Node : in out Node_Type); 523 pragma Inline (Assign_Key); 524 525 function New_Node return Count_Type; 526 pragma Inline (New_Node); 527 528 procedure Local_Insert is 529 new Key_Ops.Generic_Conditional_Insert (New_Node); 530 531 procedure Allocate is 532 new Generic_Allocate (Assign_Key); 533 534 ----------------- 535 -- Assign_Key -- 536 ----------------- 537 538 procedure Assign_Key (Node : in out Node_Type) is 539 begin 540 Node.Key := Key; 541 542 -- What is following commented out line doing here ??? 543 -- Node.Element := New_Item; 544 end Assign_Key; 545 546 -------------- 547 -- New_Node -- 548 -------------- 549 550 function New_Node return Count_Type is 551 Result : Count_Type; 552 begin 553 Allocate (Container, Result); 554 return Result; 555 end New_Node; 556 557 -- Start of processing for Insert 558 559 begin 560 561 Local_Insert (Container, Key, Position.Node, Inserted); 562 end Insert; 563 564 procedure Insert 565 (Container : in out Map; 566 Key : Key_Type; 567 New_Item : Element_Type; 568 Position : out Cursor; 569 Inserted : out Boolean) 570 is 571 procedure Assign_Key (Node : in out Node_Type); 572 pragma Inline (Assign_Key); 573 574 function New_Node return Count_Type; 575 pragma Inline (New_Node); 576 577 procedure Local_Insert is 578 new Key_Ops.Generic_Conditional_Insert (New_Node); 579 580 procedure Allocate is 581 new Generic_Allocate (Assign_Key); 582 583 ----------------- 584 -- Assign_Key -- 585 ----------------- 586 587 procedure Assign_Key (Node : in out Node_Type) is 588 begin 589 Node.Key := Key; 590 Node.Element := New_Item; 591 end Assign_Key; 592 593 -------------- 594 -- New_Node -- 595 -------------- 596 597 function New_Node return Count_Type is 598 Result : Count_Type; 599 begin 600 Allocate (Container, Result); 601 return Result; 602 end New_Node; 603 604 -- Start of processing for Insert 605 606 begin 607 Local_Insert (Container, Key, Position.Node, Inserted); 608 end Insert; 609 610 procedure Insert 611 (Container : in out Map; 612 Key : Key_Type; 613 New_Item : Element_Type) 614 is 615 Position : Cursor; 616 pragma Unreferenced (Position); 617 618 Inserted : Boolean; 619 620 begin 621 Insert (Container, Key, New_Item, Position, Inserted); 622 623 if not Inserted then 624 raise Constraint_Error with 625 "attempt to insert key already in map"; 626 end if; 627 end Insert; 628 629 -------------- 630 -- Is_Empty -- 631 -------------- 632 633 function Is_Empty (Container : Map) return Boolean is 634 begin 635 return Length (Container) = 0; 636 end Is_Empty; 637 638 ------------- 639 -- Iterate -- 640 ------------- 641 642 procedure Iterate 643 (Container : Map; 644 Process : not null 645 access procedure (Container : Map; Position : Cursor)) 646 is 647 procedure Process_Node (Node : Count_Type); 648 pragma Inline (Process_Node); 649 650 procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); 651 652 ------------------ 653 -- Process_Node -- 654 ------------------ 655 656 procedure Process_Node (Node : Count_Type) is 657 begin 658 Process (Container, (Node => Node)); 659 end Process_Node; 660 661 B : Natural renames Container'Unrestricted_Access.Busy; 662 663 -- Start of processing for Iterate 664 665 begin 666 B := B + 1; 667 668 begin 669 Local_Iterate (Container); 670 exception 671 when others => 672 B := B - 1; 673 raise; 674 end; 675 676 B := B - 1; 677 end Iterate; 678 679 --------- 680 -- Key -- 681 --------- 682 683 function Key (Container : Map; Position : Cursor) return Key_Type is 684 begin 685 if not Has_Element (Container, Position) then 686 raise Constraint_Error with 687 "Position cursor of function Key has no element"; 688 end if; 689 690 pragma Assert (Vet (Container, Position), "bad cursor in function Key"); 691 692 return Container.Nodes (Position.Node).Key; 693 end Key; 694 695 ---------- 696 -- Left -- 697 ---------- 698 699 function Left (Container : Map; Position : Cursor) return Map is 700 Curs : Cursor; 701 C : Map (Container.Capacity, Container.Modulus) := 702 Copy (Container, Container.Capacity); 703 Node : Count_Type; 704 705 begin 706 Curs := Position; 707 708 if Curs = No_Element then 709 return C; 710 end if; 711 712 if not Has_Element (Container, Curs) then 713 raise Constraint_Error; 714 end if; 715 716 while Curs.Node /= 0 loop 717 Node := Curs.Node; 718 Delete (C, Curs); 719 Curs := Next (Container, (Node => Node)); 720 end loop; 721 722 return C; 723 end Left; 724 725 ------------ 726 -- Length -- 727 ------------ 728 729 function Length (Container : Map) return Count_Type is 730 begin 731 return Container.Length; 732 end Length; 733 734 ---------- 735 -- Move -- 736 ---------- 737 738 procedure Move 739 (Target : in out Map; 740 Source : in out Map) 741 is 742 NN : HT_Types.Nodes_Type renames Source.Nodes; 743 X, Y : Count_Type; 744 745 begin 746 if Target'Address = Source'Address then 747 return; 748 end if; 749 750 if Target.Capacity < Length (Source) then 751 raise Constraint_Error with -- ??? 752 "Source length exceeds Target capacity"; 753 end if; 754 755 if Source.Busy > 0 then 756 raise Program_Error with 757 "attempt to tamper with cursors of Source (list is busy)"; 758 end if; 759 760 Clear (Target); 761 762 if Source.Length = 0 then 763 return; 764 end if; 765 766 X := HT_Ops.First (Source); 767 while X /= 0 loop 768 Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? 769 770 Y := HT_Ops.Next (Source, X); 771 772 HT_Ops.Delete_Node_Sans_Free (Source, X); 773 Free (Source, X); 774 775 X := Y; 776 end loop; 777 end Move; 778 779 ---------- 780 -- Next -- 781 ---------- 782 783 function Next (Node : Node_Type) return Count_Type is 784 begin 785 return Node.Next; 786 end Next; 787 788 function Next (Container : Map; Position : Cursor) return Cursor is 789 begin 790 if Position.Node = 0 then 791 return No_Element; 792 end if; 793 794 if not Has_Element (Container, Position) then 795 raise Constraint_Error 796 with "Position has no element"; 797 end if; 798 799 pragma Assert (Vet (Container, Position), "bad cursor in function Next"); 800 801 declare 802 Node : constant Count_Type := HT_Ops.Next (Container, Position.Node); 803 804 begin 805 if Node = 0 then 806 return No_Element; 807 end if; 808 809 return (Node => Node); 810 end; 811 end Next; 812 813 procedure Next (Container : Map; Position : in out Cursor) is 814 begin 815 Position := Next (Container, Position); 816 end Next; 817 818 ------------- 819 -- Overlap -- 820 ------------- 821 822 function Overlap (Left, Right : Map) return Boolean is 823 Left_Node : Count_Type; 824 Left_Nodes : Nodes_Type renames Left.Nodes; 825 826 begin 827 if Length (Right) = 0 or Length (Left) = 0 then 828 return False; 829 end if; 830 831 if Left'Address = Right'Address then 832 return True; 833 end if; 834 835 Left_Node := First (Left).Node; 836 while Left_Node /= 0 loop 837 declare 838 N : Node_Type renames Left_Nodes (Left_Node); 839 E : Key_Type renames N.Key; 840 begin 841 if Find (Right, E).Node /= 0 then 842 return True; 843 end if; 844 end; 845 846 Left_Node := HT_Ops.Next (Left, Left_Node); 847 end loop; 848 849 return False; 850 end Overlap; 851 852 ------------------- 853 -- Query_Element -- 854 ------------------- 855 856 procedure Query_Element 857 (Container : in out Map; 858 Position : Cursor; 859 Process : not null access 860 procedure (Key : Key_Type; Element : Element_Type)) 861 is 862 begin 863 if not Has_Element (Container, Position) then 864 raise Constraint_Error with 865 "Position cursor of Query_Element has no element"; 866 end if; 867 868 pragma Assert (Vet (Container, Position), "bad cursor in Query_Element"); 869 870 declare 871 N : Node_Type renames Container.Nodes (Position.Node); 872 B : Natural renames Container.Busy; 873 L : Natural renames Container.Lock; 874 875 begin 876 B := B + 1; 877 L := L + 1; 878 879 declare 880 K : Key_Type renames N.Key; 881 E : Element_Type renames N.Element; 882 begin 883 Process (K, E); 884 exception 885 when others => 886 L := L - 1; 887 B := B - 1; 888 raise; 889 end; 890 891 L := L - 1; 892 B := B - 1; 893 end; 894 end Query_Element; 895 896 ---------- 897 -- Read -- 898 ---------- 899 900 procedure Read 901 (Stream : not null access Root_Stream_Type'Class; 902 Container : out Map) 903 is 904 function Read_Node (Stream : not null access Root_Stream_Type'Class) 905 return Count_Type; 906 907 procedure Read_Nodes is 908 new HT_Ops.Generic_Read (Read_Node); 909 910 --------------- 911 -- Read_Node -- 912 --------------- 913 914 function Read_Node 915 (Stream : not null access Root_Stream_Type'Class) return Count_Type 916 is 917 procedure Read_Element (Node : in out Node_Type); 918 pragma Inline (Read_Element); 919 920 procedure Allocate is 921 new Generic_Allocate (Read_Element); 922 923 procedure Read_Element (Node : in out Node_Type) is 924 begin 925 Element_Type'Read (Stream, Node.Element); 926 end Read_Element; 927 928 Node : Count_Type; 929 930 -- Start of processing for Read_Node 931 932 begin 933 Allocate (Container, Node); 934 return Node; 935 end Read_Node; 936 937 -- Start of processing for Read 938 939 begin 940 Read_Nodes (Stream, Container); 941 end Read; 942 943 procedure Read 944 (Stream : not null access Root_Stream_Type'Class; 945 Item : out Cursor) 946 is 947 begin 948 raise Program_Error with "attempt to stream set cursor"; 949 end Read; 950 951 ------------- 952 -- Replace -- 953 ------------- 954 955 procedure Replace 956 (Container : in out Map; 957 Key : Key_Type; 958 New_Item : Element_Type) 959 is 960 Node : constant Count_Type := Key_Ops.Find (Container, Key); 961 962 begin 963 if Node = 0 then 964 raise Constraint_Error with 965 "attempt to replace key not in map"; 966 end if; 967 968 if Container.Lock > 0 then 969 raise Program_Error with 970 "Replace attempted to tamper with cursors (map is locked)"; 971 end if; 972 973 declare 974 N : Node_Type renames Container.Nodes (Node); 975 begin 976 N.Key := Key; 977 N.Element := New_Item; 978 end; 979 end Replace; 980 981 --------------------- 982 -- Replace_Element -- 983 --------------------- 984 985 procedure Replace_Element 986 (Container : in out Map; 987 Position : Cursor; 988 New_Item : Element_Type) 989 is 990 begin 991 if not Has_Element (Container, Position) then 992 raise Constraint_Error with 993 "Position cursor of Replace_Element has no element"; 994 end if; 995 996 if Container.Lock > 0 then 997 raise Program_Error with 998 "Replace_Element attempted to tamper with cursors (map is locked)"; 999 end if; 1000 1001 pragma Assert (Vet (Container, Position), 1002 "bad cursor in Replace_Element"); 1003 1004 Container.Nodes (Position.Node).Element := New_Item; 1005 end Replace_Element; 1006 1007 ---------------------- 1008 -- Reserve_Capacity -- 1009 ---------------------- 1010 1011 procedure Reserve_Capacity 1012 (Container : in out Map; 1013 Capacity : Count_Type) 1014 is 1015 begin 1016 if Capacity > Container.Capacity then 1017 raise Capacity_Error with "requested capacity is too large"; 1018 end if; 1019 end Reserve_Capacity; 1020 1021 ----------- 1022 -- Right -- 1023 ----------- 1024 1025 function Right (Container : Map; Position : Cursor) return Map is 1026 Curs : Cursor := First (Container); 1027 C : Map (Container.Capacity, Container.Modulus) := 1028 Copy (Container, Container.Capacity); 1029 Node : Count_Type; 1030 1031 begin 1032 if Curs = No_Element then 1033 Clear (C); 1034 return C; 1035 end if; 1036 1037 if Position /= No_Element and not Has_Element (Container, Position) then 1038 raise Constraint_Error; 1039 end if; 1040 1041 while Curs.Node /= Position.Node loop 1042 Node := Curs.Node; 1043 Delete (C, Curs); 1044 Curs := Next (Container, (Node => Node)); 1045 end loop; 1046 1047 return C; 1048 end Right; 1049 1050 -------------- 1051 -- Set_Next -- 1052 -------------- 1053 1054 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is 1055 begin 1056 Node.Next := Next; 1057 end Set_Next; 1058 1059 ------------------ 1060 -- Strict_Equal -- 1061 ------------------ 1062 1063 function Strict_Equal (Left, Right : Map) return Boolean is 1064 CuL : Cursor := First (Left); 1065 CuR : Cursor := First (Right); 1066 1067 begin 1068 if Length (Left) /= Length (Right) then 1069 return False; 1070 end if; 1071 1072 while CuL.Node /= 0 or CuR.Node /= 0 loop 1073 if CuL.Node /= CuR.Node or else 1074 (Left.Nodes (CuL.Node).Element /= 1075 Right.Nodes (CuR.Node).Element or 1076 Left.Nodes (CuL.Node).Key /= 1077 Right.Nodes (CuR.Node).Key) then 1078 return False; 1079 end if; 1080 1081 CuL := Next (Left, CuL); 1082 CuR := Next (Right, CuR); 1083 end loop; 1084 1085 return True; 1086 end Strict_Equal; 1087 1088 -------------------- 1089 -- Update_Element -- 1090 -------------------- 1091 1092 procedure Update_Element 1093 (Container : in out Map; 1094 Position : Cursor; 1095 Process : not null access procedure (Key : Key_Type; 1096 Element : in out Element_Type)) 1097 is 1098 begin 1099 if not Has_Element (Container, Position) then 1100 raise Constraint_Error with 1101 "Position cursor of Update_Element has no element"; 1102 end if; 1103 1104 pragma Assert (Vet (Container, Position), 1105 "bad cursor in Update_Element"); 1106 1107 declare 1108 B : Natural renames Container.Busy; 1109 L : Natural renames Container.Lock; 1110 1111 begin 1112 B := B + 1; 1113 L := L + 1; 1114 1115 declare 1116 N : Node_Type renames Container.Nodes (Position.Node); 1117 K : Key_Type renames N.Key; 1118 E : Element_Type renames N.Element; 1119 1120 begin 1121 Process (K, E); 1122 exception 1123 when others => 1124 L := L - 1; 1125 B := B - 1; 1126 raise; 1127 end; 1128 1129 L := L - 1; 1130 B := B - 1; 1131 end; 1132 end Update_Element; 1133 1134 --------- 1135 -- Vet -- 1136 --------- 1137 1138 function Vet (Container : Map; Position : Cursor) return Boolean is 1139 begin 1140 if Position.Node = 0 then 1141 return True; 1142 end if; 1143 1144 declare 1145 X : Count_Type; 1146 1147 begin 1148 if Container.Length = 0 then 1149 return False; 1150 end if; 1151 1152 if Container.Capacity = 0 then 1153 return False; 1154 end if; 1155 1156 if Container.Buckets'Length = 0 then 1157 return False; 1158 end if; 1159 1160 if Position.Node > Container.Capacity then 1161 return False; 1162 end if; 1163 1164 if Container.Nodes (Position.Node).Next = Position.Node then 1165 return False; 1166 end if; 1167 1168 X := Container.Buckets 1169 (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key)); 1170 1171 for J in 1 .. Container.Length loop 1172 if X = Position.Node then 1173 return True; 1174 end if; 1175 1176 if X = 0 then 1177 return False; 1178 end if; 1179 1180 if X = Container.Nodes (X).Next then 1181 1182 -- Prevent unnecessary looping 1183 1184 return False; 1185 end if; 1186 1187 X := Container.Nodes (X).Next; 1188 end loop; 1189 1190 return False; 1191 end; 1192 end Vet; 1193 1194 ----------- 1195 -- Write -- 1196 ----------- 1197 1198 procedure Write 1199 (Stream : not null access Root_Stream_Type'Class; 1200 Container : Map) 1201 is 1202 procedure Write_Node 1203 (Stream : not null access Root_Stream_Type'Class; 1204 Node : Node_Type); 1205 pragma Inline (Write_Node); 1206 1207 procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); 1208 1209 ---------------- 1210 -- Write_Node -- 1211 ---------------- 1212 1213 procedure Write_Node 1214 (Stream : not null access Root_Stream_Type'Class; 1215 Node : Node_Type) 1216 is 1217 begin 1218 Key_Type'Write (Stream, Node.Key); 1219 Element_Type'Write (Stream, Node.Element); 1220 end Write_Node; 1221 1222 -- Start of processing for Write 1223 1224 begin 1225 Write_Nodes (Stream, Container); 1226 end Write; 1227 1228 procedure Write 1229 (Stream : not null access Root_Stream_Type'Class; 1230 Item : Cursor) 1231 is 1232 begin 1233 raise Program_Error with "attempt to stream map cursor"; 1234 end Write; 1235 1236end Ada.Containers.Formal_Hashed_Maps; 1237