1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- 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.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 = 0 then 278 C := Source.Length; 279 280 elsif Capacity >= Source.Length then 281 C := Capacity; 282 283 elsif Checks then 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 (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); 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 Node : constant Node_Access := HT_Ops.First (Container.HT); 541 begin 542 if Node = null then 543 return No_Element; 544 else 545 return Cursor'(Container'Unrestricted_Access, Node); 546 end if; 547 end First; 548 549 function First (Object : Iterator) return Cursor is 550 begin 551 return Object.Container.First; 552 end First; 553 554 ---------- 555 -- Free -- 556 ---------- 557 558 procedure Free (X : in out Node_Access) is 559 procedure Deallocate is 560 new Ada.Unchecked_Deallocation (Node_Type, Node_Access); 561 562 begin 563 if X = null then 564 return; 565 end if; 566 567 X.Next := X; -- detect mischief (in Vet) 568 569 begin 570 Free_Key (X.Key); 571 572 exception 573 when others => 574 X.Key := null; 575 576 begin 577 Free_Element (X.Element); 578 exception 579 when others => 580 X.Element := null; 581 end; 582 583 Deallocate (X); 584 raise; 585 end; 586 587 begin 588 Free_Element (X.Element); 589 exception 590 when others => 591 X.Element := null; 592 Deallocate (X); 593 raise; 594 end; 595 596 Deallocate (X); 597 end Free; 598 599 ------------------------ 600 -- Get_Element_Access -- 601 ------------------------ 602 603 function Get_Element_Access 604 (Position : Cursor) return not null Element_Access is 605 begin 606 return Position.Node.Element; 607 end Get_Element_Access; 608 609 ----------------- 610 -- Has_Element -- 611 ----------------- 612 613 function Has_Element (Position : Cursor) return Boolean is 614 begin 615 pragma Assert (Vet (Position), "bad cursor in Has_Element"); 616 return Position.Node /= null; 617 end Has_Element; 618 619 --------------- 620 -- Hash_Node -- 621 --------------- 622 623 function Hash_Node (Node : Node_Access) return Hash_Type is 624 begin 625 return Hash (Node.Key.all); 626 end Hash_Node; 627 628 ------------- 629 -- Include -- 630 ------------- 631 632 procedure Include 633 (Container : in out Map; 634 Key : Key_Type; 635 New_Item : Element_Type) 636 is 637 Position : Cursor; 638 Inserted : Boolean; 639 640 K : Key_Access; 641 E : Element_Access; 642 643 begin 644 Insert (Container, Key, New_Item, Position, Inserted); 645 646 if not Inserted then 647 TE_Check (Container.HT.TC); 648 649 K := Position.Node.Key; 650 E := Position.Node.Element; 651 652 Position.Node.Key := new Key_Type'(Key); 653 654 declare 655 -- The element allocator may need an accessibility check in the 656 -- case the actual type is class-wide or has access discriminants 657 -- (see RM 4.8(10.1) and AI12-0035). 658 659 pragma Unsuppress (Accessibility_Check); 660 661 begin 662 Position.Node.Element := new Element_Type'(New_Item); 663 664 exception 665 when others => 666 Free_Key (K); 667 raise; 668 end; 669 670 Free_Key (K); 671 Free_Element (E); 672 end if; 673 end Include; 674 675 ------------ 676 -- Insert -- 677 ------------ 678 679 procedure Insert 680 (Container : in out Map; 681 Key : Key_Type; 682 New_Item : Element_Type; 683 Position : out Cursor; 684 Inserted : out Boolean) 685 is 686 function New_Node (Next : Node_Access) return Node_Access; 687 688 procedure Local_Insert is 689 new Key_Ops.Generic_Conditional_Insert (New_Node); 690 691 -------------- 692 -- New_Node -- 693 -------------- 694 695 function New_Node (Next : Node_Access) return Node_Access is 696 K : Key_Access := new Key_Type'(Key); 697 E : Element_Access; 698 699 -- The element allocator may need an accessibility check in the case 700 -- the actual type is class-wide or has access discriminants (see 701 -- RM 4.8(10.1) and AI12-0035). 702 703 pragma Unsuppress (Accessibility_Check); 704 705 begin 706 E := new Element_Type'(New_Item); 707 return new Node_Type'(K, E, Next); 708 709 exception 710 when others => 711 Free_Key (K); 712 Free_Element (E); 713 raise; 714 end New_Node; 715 716 HT : Hash_Table_Type renames Container.HT; 717 718 -- Start of processing for Insert 719 720 begin 721 if HT_Ops.Capacity (HT) = 0 then 722 HT_Ops.Reserve_Capacity (HT, 1); 723 end if; 724 725 Local_Insert (HT, Key, Position.Node, Inserted); 726 727 if Inserted 728 and then HT.Length > HT_Ops.Capacity (HT) 729 then 730 HT_Ops.Reserve_Capacity (HT, HT.Length); 731 end if; 732 733 Position.Container := Container'Unchecked_Access; 734 end Insert; 735 736 procedure Insert 737 (Container : in out Map; 738 Key : Key_Type; 739 New_Item : Element_Type) 740 is 741 Position : Cursor; 742 pragma Unreferenced (Position); 743 744 Inserted : Boolean; 745 746 begin 747 Insert (Container, Key, New_Item, Position, Inserted); 748 749 if Checks and then not Inserted then 750 raise Constraint_Error with 751 "attempt to insert key already in map"; 752 end if; 753 end Insert; 754 755 -------------- 756 -- Is_Empty -- 757 -------------- 758 759 function Is_Empty (Container : Map) return Boolean is 760 begin 761 return Container.HT.Length = 0; 762 end Is_Empty; 763 764 ------------- 765 -- Iterate -- 766 ------------- 767 768 procedure Iterate 769 (Container : Map; 770 Process : not null access procedure (Position : Cursor)) 771 is 772 procedure Process_Node (Node : Node_Access); 773 pragma Inline (Process_Node); 774 775 procedure Local_Iterate is 776 new HT_Ops.Generic_Iteration (Process_Node); 777 778 ------------------ 779 -- Process_Node -- 780 ------------------ 781 782 procedure Process_Node (Node : Node_Access) is 783 begin 784 Process (Cursor'(Container'Unrestricted_Access, Node)); 785 end Process_Node; 786 787 Busy : With_Busy (Container.HT.TC'Unrestricted_Access); 788 789 -- Start of processing for Iterate 790 791 begin 792 Local_Iterate (Container.HT); 793 end Iterate; 794 795 function Iterate 796 (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class 797 is 798 begin 799 return It : constant Iterator := 800 (Limited_Controlled with Container => Container'Unrestricted_Access) 801 do 802 Busy (Container.HT.TC'Unrestricted_Access.all); 803 end return; 804 end Iterate; 805 806 --------- 807 -- Key -- 808 --------- 809 810 function Key (Position : Cursor) return Key_Type is 811 begin 812 if Checks and then Position.Node = null then 813 raise Constraint_Error with 814 "Position cursor of function Key equals No_Element"; 815 end if; 816 817 if Checks and then Position.Node.Key = null then 818 raise Program_Error with 819 "Position cursor of function Key is bad"; 820 end if; 821 822 pragma Assert (Vet (Position), "bad cursor in function Key"); 823 824 return Position.Node.Key.all; 825 end Key; 826 827 ------------ 828 -- Length -- 829 ------------ 830 831 function Length (Container : Map) return Count_Type is 832 begin 833 return Container.HT.Length; 834 end Length; 835 836 ---------- 837 -- Move -- 838 ---------- 839 840 procedure Move 841 (Target : in out Map; 842 Source : in out Map) 843 is 844 begin 845 HT_Ops.Move (Target => Target.HT, Source => Source.HT); 846 end Move; 847 848 ---------- 849 -- Next -- 850 ---------- 851 852 function Next (Node : Node_Access) return Node_Access is 853 begin 854 return Node.Next; 855 end Next; 856 857 procedure Next (Position : in out Cursor) is 858 begin 859 Position := Next (Position); 860 end Next; 861 862 function Next (Position : Cursor) return Cursor is 863 begin 864 if Position.Node = null then 865 return No_Element; 866 end if; 867 868 if Checks and then 869 (Position.Node.Key = null or else Position.Node.Element = null) 870 then 871 raise Program_Error with "Position cursor of Next is bad"; 872 end if; 873 874 pragma Assert (Vet (Position), "Position cursor of Next is bad"); 875 876 declare 877 HT : Hash_Table_Type renames Position.Container.HT; 878 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); 879 begin 880 if Node = null then 881 return No_Element; 882 else 883 return Cursor'(Position.Container, Node); 884 end if; 885 end; 886 end Next; 887 888 function Next (Object : Iterator; Position : Cursor) return Cursor is 889 begin 890 if Position.Container = null then 891 return No_Element; 892 end if; 893 894 if Checks and then Position.Container /= Object.Container then 895 raise Program_Error with 896 "Position cursor of Next designates wrong map"; 897 end if; 898 899 return Next (Position); 900 end Next; 901 902 ---------------------- 903 -- Pseudo_Reference -- 904 ---------------------- 905 906 function Pseudo_Reference 907 (Container : aliased Map'Class) return Reference_Control_Type 908 is 909 TC : constant Tamper_Counts_Access := 910 Container.HT.TC'Unrestricted_Access; 911 begin 912 return R : constant Reference_Control_Type := (Controlled with TC) do 913 Lock (TC.all); 914 end return; 915 end Pseudo_Reference; 916 917 ------------------- 918 -- Query_Element -- 919 ------------------- 920 921 procedure Query_Element 922 (Position : Cursor; 923 Process : not null access procedure (Key : Key_Type; 924 Element : Element_Type)) 925 is 926 begin 927 if Checks and then Position.Node = null then 928 raise Constraint_Error with 929 "Position cursor of Query_Element equals No_Element"; 930 end if; 931 932 if Checks and then 933 (Position.Node.Key = null or else Position.Node.Element = null) 934 then 935 raise Program_Error with 936 "Position cursor of Query_Element is bad"; 937 end if; 938 939 pragma Assert (Vet (Position), "bad cursor in Query_Element"); 940 941 declare 942 M : Map renames Position.Container.all; 943 HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; 944 Lock : With_Lock (HT.TC'Unrestricted_Access); 945 K : Key_Type renames Position.Node.Key.all; 946 E : Element_Type renames Position.Node.Element.all; 947 begin 948 Process (K, E); 949 end; 950 end Query_Element; 951 952 ---------- 953 -- Read -- 954 ---------- 955 956 procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); 957 958 procedure Read 959 (Stream : not null access Root_Stream_Type'Class; 960 Container : out Map) 961 is 962 begin 963 Read_Nodes (Stream, Container.HT); 964 end Read; 965 966 procedure Read 967 (Stream : not null access Root_Stream_Type'Class; 968 Item : out Cursor) 969 is 970 begin 971 raise Program_Error with "attempt to stream map cursor"; 972 end Read; 973 974 procedure Read 975 (Stream : not null access Root_Stream_Type'Class; 976 Item : out Reference_Type) 977 is 978 begin 979 raise Program_Error with "attempt to stream reference"; 980 end Read; 981 982 procedure Read 983 (Stream : not null access Root_Stream_Type'Class; 984 Item : out Constant_Reference_Type) 985 is 986 begin 987 raise Program_Error with "attempt to stream reference"; 988 end Read; 989 990 --------------- 991 -- Read_Node -- 992 --------------- 993 994 function Read_Node 995 (Stream : not null access Root_Stream_Type'Class) return Node_Access 996 is 997 Node : Node_Access := new Node_Type; 998 999 begin 1000 begin 1001 Node.Key := new Key_Type'(Key_Type'Input (Stream)); 1002 exception 1003 when others => 1004 Free (Node); 1005 raise; 1006 end; 1007 1008 begin 1009 Node.Element := new Element_Type'(Element_Type'Input (Stream)); 1010 exception 1011 when others => 1012 Free_Key (Node.Key); 1013 Free (Node); 1014 raise; 1015 end; 1016 1017 return Node; 1018 end Read_Node; 1019 1020 --------------- 1021 -- Reference -- 1022 --------------- 1023 1024 function Reference 1025 (Container : aliased in out Map; 1026 Position : Cursor) return Reference_Type 1027 is 1028 begin 1029 if Checks and then Position.Container = null then 1030 raise Constraint_Error with 1031 "Position cursor has no element"; 1032 end if; 1033 1034 if Checks and then Position.Container /= Container'Unrestricted_Access 1035 then 1036 raise Program_Error with 1037 "Position cursor designates wrong map"; 1038 end if; 1039 1040 if Checks and then Position.Node.Element = null then 1041 raise Program_Error with 1042 "Position cursor has no element"; 1043 end if; 1044 1045 pragma Assert 1046 (Vet (Position), 1047 "Position cursor in function Reference is bad"); 1048 1049 declare 1050 M : Map renames Position.Container.all; 1051 HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; 1052 TC : constant Tamper_Counts_Access := 1053 HT.TC'Unrestricted_Access; 1054 begin 1055 return R : constant Reference_Type := 1056 (Element => Position.Node.Element.all'Access, 1057 Control => (Controlled with TC)) 1058 do 1059 Lock (TC.all); 1060 end return; 1061 end; 1062 end Reference; 1063 1064 function Reference 1065 (Container : aliased in out Map; 1066 Key : Key_Type) return Reference_Type 1067 is 1068 HT : Hash_Table_Type renames Container.HT; 1069 Node : constant Node_Access := Key_Ops.Find (HT, Key); 1070 1071 begin 1072 if Checks and then Node = null then 1073 raise Constraint_Error with "key not in map"; 1074 end if; 1075 1076 if Checks and then Node.Element = null then 1077 raise Program_Error with "key has no element"; 1078 end if; 1079 1080 declare 1081 TC : constant Tamper_Counts_Access := 1082 HT.TC'Unrestricted_Access; 1083 begin 1084 return R : constant Reference_Type := 1085 (Element => Node.Element.all'Access, 1086 Control => (Controlled with TC)) 1087 do 1088 Lock (TC.all); 1089 end return; 1090 end; 1091 end Reference; 1092 1093 ------------- 1094 -- Replace -- 1095 ------------- 1096 1097 procedure Replace 1098 (Container : in out Map; 1099 Key : Key_Type; 1100 New_Item : Element_Type) 1101 is 1102 Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); 1103 1104 K : Key_Access; 1105 E : Element_Access; 1106 1107 begin 1108 if Checks and then Node = null then 1109 raise Constraint_Error with 1110 "attempt to replace key not in map"; 1111 end if; 1112 1113 TE_Check (Container.HT.TC); 1114 1115 K := Node.Key; 1116 E := Node.Element; 1117 1118 Node.Key := new Key_Type'(Key); 1119 1120 declare 1121 -- The element allocator may need an accessibility check in the case 1122 -- the actual type is class-wide or has access discriminants (see 1123 -- RM 4.8(10.1) and AI12-0035). 1124 1125 pragma Unsuppress (Accessibility_Check); 1126 1127 begin 1128 Node.Element := new Element_Type'(New_Item); 1129 1130 exception 1131 when others => 1132 Free_Key (K); 1133 raise; 1134 end; 1135 1136 Free_Key (K); 1137 Free_Element (E); 1138 end Replace; 1139 1140 --------------------- 1141 -- Replace_Element -- 1142 --------------------- 1143 1144 procedure Replace_Element 1145 (Container : in out Map; 1146 Position : Cursor; 1147 New_Item : Element_Type) 1148 is 1149 begin 1150 if Checks and then Position.Node = null then 1151 raise Constraint_Error with 1152 "Position cursor of Replace_Element equals No_Element"; 1153 end if; 1154 1155 if Checks and then 1156 (Position.Node.Key = null or else Position.Node.Element = null) 1157 then 1158 raise Program_Error with 1159 "Position cursor of Replace_Element is bad"; 1160 end if; 1161 1162 if Checks and then Position.Container /= Container'Unrestricted_Access 1163 then 1164 raise Program_Error with 1165 "Position cursor of Replace_Element designates wrong map"; 1166 end if; 1167 1168 TE_Check (Position.Container.HT.TC); 1169 1170 pragma Assert (Vet (Position), "bad cursor in Replace_Element"); 1171 1172 declare 1173 X : Element_Access := Position.Node.Element; 1174 1175 -- The element allocator may need an accessibility check in the case 1176 -- the actual type is class-wide or has access discriminants (see 1177 -- RM 4.8(10.1) and AI12-0035). 1178 1179 pragma Unsuppress (Accessibility_Check); 1180 1181 begin 1182 Position.Node.Element := new Element_Type'(New_Item); 1183 Free_Element (X); 1184 end; 1185 end Replace_Element; 1186 1187 ---------------------- 1188 -- Reserve_Capacity -- 1189 ---------------------- 1190 1191 procedure Reserve_Capacity 1192 (Container : in out Map; 1193 Capacity : Count_Type) 1194 is 1195 begin 1196 HT_Ops.Reserve_Capacity (Container.HT, Capacity); 1197 end Reserve_Capacity; 1198 1199 -------------- 1200 -- Set_Next -- 1201 -------------- 1202 1203 procedure Set_Next (Node : Node_Access; Next : Node_Access) is 1204 begin 1205 Node.Next := Next; 1206 end Set_Next; 1207 1208 -------------------- 1209 -- Update_Element -- 1210 -------------------- 1211 1212 procedure Update_Element 1213 (Container : in out Map; 1214 Position : Cursor; 1215 Process : not null access procedure (Key : Key_Type; 1216 Element : in out Element_Type)) 1217 is 1218 begin 1219 if Checks and then Position.Node = null then 1220 raise Constraint_Error with 1221 "Position cursor of Update_Element equals No_Element"; 1222 end if; 1223 1224 if Checks and then 1225 (Position.Node.Key = null or else Position.Node.Element = null) 1226 then 1227 raise Program_Error with 1228 "Position cursor of Update_Element is bad"; 1229 end if; 1230 1231 if Checks and then Position.Container /= Container'Unrestricted_Access 1232 then 1233 raise Program_Error with 1234 "Position cursor of Update_Element designates wrong map"; 1235 end if; 1236 1237 pragma Assert (Vet (Position), "bad cursor in Update_Element"); 1238 1239 declare 1240 HT : Hash_Table_Type renames Container.HT; 1241 Lock : With_Lock (HT.TC'Unrestricted_Access); 1242 K : Key_Type renames Position.Node.Key.all; 1243 E : Element_Type renames Position.Node.Element.all; 1244 begin 1245 Process (K, E); 1246 end; 1247 end Update_Element; 1248 1249 --------- 1250 -- Vet -- 1251 --------- 1252 1253 function Vet (Position : Cursor) return Boolean is 1254 begin 1255 if Position.Node = null then 1256 return Position.Container = null; 1257 end if; 1258 1259 if Position.Container = null then 1260 return False; 1261 end if; 1262 1263 if Position.Node.Next = Position.Node then 1264 return False; 1265 end if; 1266 1267 if Position.Node.Key = null then 1268 return False; 1269 end if; 1270 1271 if Position.Node.Element = null then 1272 return False; 1273 end if; 1274 1275 declare 1276 HT : Hash_Table_Type renames Position.Container.HT; 1277 X : Node_Access; 1278 1279 begin 1280 if HT.Length = 0 then 1281 return False; 1282 end if; 1283 1284 if HT.Buckets = null 1285 or else HT.Buckets'Length = 0 1286 then 1287 return False; 1288 end if; 1289 1290 X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key.all)); 1291 1292 for J in 1 .. HT.Length loop 1293 if X = Position.Node then 1294 return True; 1295 end if; 1296 1297 if X = null then 1298 return False; 1299 end if; 1300 1301 if X = X.Next then -- to prevent unnecessary looping 1302 return False; 1303 end if; 1304 1305 X := X.Next; 1306 end loop; 1307 1308 return False; 1309 end; 1310 end Vet; 1311 1312 ----------- 1313 -- Write -- 1314 ----------- 1315 1316 procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); 1317 1318 procedure Write 1319 (Stream : not null access Root_Stream_Type'Class; 1320 Container : Map) 1321 is 1322 begin 1323 Write_Nodes (Stream, Container.HT); 1324 end Write; 1325 1326 procedure Write 1327 (Stream : not null access Root_Stream_Type'Class; 1328 Item : Cursor) 1329 is 1330 begin 1331 raise Program_Error with "attempt to stream map cursor"; 1332 end Write; 1333 1334 procedure Write 1335 (Stream : not null access Root_Stream_Type'Class; 1336 Item : Reference_Type) 1337 is 1338 begin 1339 raise Program_Error with "attempt to stream reference"; 1340 end Write; 1341 1342 procedure Write 1343 (Stream : not null access Root_Stream_Type'Class; 1344 Item : Constant_Reference_Type) 1345 is 1346 begin 1347 raise Program_Error with "attempt to stream reference"; 1348 end Write; 1349 1350 ---------------- 1351 -- Write_Node -- 1352 ---------------- 1353 1354 procedure Write_Node 1355 (Stream : not null access Root_Stream_Type'Class; 1356 Node : Node_Access) 1357 is 1358 begin 1359 Key_Type'Output (Stream, Node.Key.all); 1360 Element_Type'Output (Stream, Node.Element.all); 1361 end Write_Node; 1362 1363end Ada.Containers.Indefinite_Hashed_Maps; 1364