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