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