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