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