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