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