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