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