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-2018, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- This unit was originally developed by Matthew J Heaney. -- 28------------------------------------------------------------------------------ 29 30with Ada.Containers.Hash_Tables.Generic_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 Lock (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 Lock (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 : Count_Type; 266 M : Hash_Type; 267 268 begin 269 if Capacity = 0 then 270 C := Source.Length; 271 272 elsif Capacity >= Source.Length then 273 C := Capacity; 274 275 elsif Checks then 276 raise Capacity_Error with "Capacity value too small"; 277 end if; 278 279 if Modulus = 0 then 280 M := Default_Modulus (C); 281 else 282 M := Modulus; 283 end if; 284 285 return Target : Map (Capacity => C, Modulus => M) do 286 Assign (Target => Target, Source => Source); 287 end return; 288 end Copy; 289 290 --------------------- 291 -- Default_Modulus -- 292 --------------------- 293 294 function Default_Modulus (Capacity : Count_Type) return Hash_Type is 295 begin 296 return To_Prime (Capacity); 297 end Default_Modulus; 298 299 ------------ 300 -- Delete -- 301 ------------ 302 303 procedure Delete (Container : in out Map; Key : Key_Type) is 304 X : Count_Type; 305 306 begin 307 Key_Ops.Delete_Key_Sans_Free (Container, Key, X); 308 309 if Checks and then X = 0 then 310 raise Constraint_Error with "attempt to delete key not in map"; 311 end if; 312 313 HT_Ops.Free (Container, X); 314 end Delete; 315 316 procedure Delete (Container : in out Map; Position : in out Cursor) is 317 begin 318 if Checks and then Position.Node = 0 then 319 raise Constraint_Error with 320 "Position cursor of Delete equals No_Element"; 321 end if; 322 323 if Checks and then Position.Container /= Container'Unrestricted_Access 324 then 325 raise Program_Error with 326 "Position cursor of Delete designates wrong map"; 327 end if; 328 329 TC_Check (Container.TC); 330 331 pragma Assert (Vet (Position), "bad cursor in Delete"); 332 333 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); 334 HT_Ops.Free (Container, Position.Node); 335 336 Position := No_Element; 337 end Delete; 338 339 ------------- 340 -- Element -- 341 ------------- 342 343 function Element (Container : Map; Key : Key_Type) return Element_Type is 344 Node : constant Count_Type := 345 Key_Ops.Find (Container'Unrestricted_Access.all, Key); 346 347 begin 348 if Checks and then Node = 0 then 349 raise Constraint_Error with 350 "no element available because key not in map"; 351 end if; 352 353 return Container.Nodes (Node).Element; 354 end Element; 355 356 function Element (Position : Cursor) return Element_Type is 357 begin 358 if Checks and then Position.Node = 0 then 359 raise Constraint_Error with 360 "Position cursor of function Element equals No_Element"; 361 end if; 362 363 pragma Assert (Vet (Position), "bad cursor in function Element"); 364 365 return Position.Container.Nodes (Position.Node).Element; 366 end Element; 367 368 ------------------------- 369 -- Equivalent_Key_Node -- 370 ------------------------- 371 372 function Equivalent_Key_Node 373 (Key : Key_Type; 374 Node : Node_Type) return Boolean is 375 begin 376 return Equivalent_Keys (Key, Node.Key); 377 end Equivalent_Key_Node; 378 379 --------------------- 380 -- Equivalent_Keys -- 381 --------------------- 382 383 function Equivalent_Keys (Left, Right : Cursor) 384 return Boolean is 385 begin 386 if Checks and then Left.Node = 0 then 387 raise Constraint_Error with 388 "Left cursor of Equivalent_Keys equals No_Element"; 389 end if; 390 391 if Checks and then Right.Node = 0 then 392 raise Constraint_Error with 393 "Right cursor of Equivalent_Keys equals No_Element"; 394 end if; 395 396 pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad"); 397 pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); 398 399 declare 400 LN : Node_Type renames Left.Container.Nodes (Left.Node); 401 RN : Node_Type renames Right.Container.Nodes (Right.Node); 402 403 begin 404 return Equivalent_Keys (LN.Key, RN.Key); 405 end; 406 end Equivalent_Keys; 407 408 function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is 409 begin 410 if Checks and then Left.Node = 0 then 411 raise Constraint_Error with 412 "Left cursor of Equivalent_Keys equals No_Element"; 413 end if; 414 415 pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad"); 416 417 declare 418 LN : Node_Type renames Left.Container.Nodes (Left.Node); 419 420 begin 421 return Equivalent_Keys (LN.Key, Right); 422 end; 423 end Equivalent_Keys; 424 425 function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is 426 begin 427 if Checks and then Right.Node = 0 then 428 raise Constraint_Error with 429 "Right cursor of Equivalent_Keys equals No_Element"; 430 end if; 431 432 pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); 433 434 declare 435 RN : Node_Type renames Right.Container.Nodes (Right.Node); 436 437 begin 438 return Equivalent_Keys (Left, RN.Key); 439 end; 440 end Equivalent_Keys; 441 442 ------------- 443 -- Exclude -- 444 ------------- 445 446 procedure Exclude (Container : in out Map; Key : Key_Type) is 447 X : Count_Type; 448 begin 449 Key_Ops.Delete_Key_Sans_Free (Container, Key, X); 450 HT_Ops.Free (Container, X); 451 end Exclude; 452 453 -------------- 454 -- Finalize -- 455 -------------- 456 457 procedure Finalize (Object : in out Iterator) is 458 begin 459 if Object.Container /= null then 460 Unbusy (Object.Container.TC); 461 end if; 462 end Finalize; 463 464 ---------- 465 -- Find -- 466 ---------- 467 468 function Find (Container : Map; Key : Key_Type) return Cursor is 469 Node : constant Count_Type := 470 Key_Ops.Find (Container'Unrestricted_Access.all, Key); 471 begin 472 if Node = 0 then 473 return No_Element; 474 else 475 return Cursor'(Container'Unrestricted_Access, Node); 476 end if; 477 end Find; 478 479 ----------- 480 -- First -- 481 ----------- 482 483 function First (Container : Map) return Cursor is 484 Node : constant Count_Type := HT_Ops.First (Container); 485 begin 486 if Node = 0 then 487 return No_Element; 488 else 489 return Cursor'(Container'Unrestricted_Access, Node); 490 end if; 491 end First; 492 493 function First (Object : Iterator) return Cursor is 494 begin 495 return Object.Container.First; 496 end First; 497 498 ------------------------ 499 -- Get_Element_Access -- 500 ------------------------ 501 502 function Get_Element_Access 503 (Position : Cursor) return not null Element_Access is 504 begin 505 return Position.Container.Nodes (Position.Node).Element'Access; 506 end Get_Element_Access; 507 508 ----------------- 509 -- Has_Element -- 510 ----------------- 511 512 function Has_Element (Position : Cursor) return Boolean is 513 begin 514 pragma Assert (Vet (Position), "bad cursor in Has_Element"); 515 return Position.Node /= 0; 516 end Has_Element; 517 518 --------------- 519 -- Hash_Node -- 520 --------------- 521 522 function Hash_Node (Node : Node_Type) return Hash_Type is 523 begin 524 return Hash (Node.Key); 525 end Hash_Node; 526 527 ------------- 528 -- Include -- 529 ------------- 530 531 procedure Include 532 (Container : in out Map; 533 Key : Key_Type; 534 New_Item : Element_Type) 535 is 536 Position : Cursor; 537 Inserted : Boolean; 538 539 begin 540 Insert (Container, Key, New_Item, Position, Inserted); 541 542 if not Inserted then 543 TE_Check (Container.TC); 544 545 declare 546 N : Node_Type renames Container.Nodes (Position.Node); 547 begin 548 N.Key := Key; 549 N.Element := New_Item; 550 end; 551 end if; 552 end Include; 553 554 ------------ 555 -- Insert -- 556 ------------ 557 558 procedure Insert 559 (Container : in out Map; 560 Key : Key_Type; 561 Position : out Cursor; 562 Inserted : out Boolean) 563 is 564 procedure Assign_Key (Node : in out Node_Type); 565 pragma Inline (Assign_Key); 566 567 function New_Node return Count_Type; 568 pragma Inline (New_Node); 569 570 procedure Local_Insert is 571 new Key_Ops.Generic_Conditional_Insert (New_Node); 572 573 procedure Allocate is 574 new HT_Ops.Generic_Allocate (Assign_Key); 575 576 ----------------- 577 -- Assign_Key -- 578 ----------------- 579 580 procedure Assign_Key (Node : in out Node_Type) is 581 pragma Warnings (Off); 582 Default_Initialized_Item : Element_Type; 583 pragma Unmodified (Default_Initialized_Item); 584 -- Default-initialized element (ok to reference, see below) 585 586 begin 587 Node.Key := Key; 588 589 -- There is no explicit element provided, but in an instance the 590 -- element type may be a scalar with a Default_Value aspect, or a 591 -- composite type with such a scalar component, or components with 592 -- default initialization, so insert a possibly initialized element 593 -- under the given key. 594 595 Node.Element := Default_Initialized_Item; 596 pragma Warnings (On); 597 end Assign_Key; 598 599 -------------- 600 -- New_Node -- 601 -------------- 602 603 function New_Node return Count_Type is 604 Result : Count_Type; 605 begin 606 Allocate (Container, Result); 607 return Result; 608 end New_Node; 609 610 -- Start of processing for Insert 611 612 begin 613 -- The buckets array length is specified by the user as a discriminant 614 -- of the container type, so it is possible for the buckets array to 615 -- have a length of zero. We must check for this case specifically, in 616 -- order to prevent divide-by-zero errors later, when we compute the 617 -- buckets array index value for a key, given its hash value. 618 619 if Checks and then Container.Buckets'Length = 0 then 620 raise Capacity_Error with "No capacity for insertion"; 621 end if; 622 623 Local_Insert (Container, Key, Position.Node, Inserted); 624 Position.Container := Container'Unchecked_Access; 625 end Insert; 626 627 procedure Insert 628 (Container : in out Map; 629 Key : Key_Type; 630 New_Item : Element_Type; 631 Position : out Cursor; 632 Inserted : out Boolean) 633 is 634 procedure Assign_Key (Node : in out Node_Type); 635 pragma Inline (Assign_Key); 636 637 function New_Node return Count_Type; 638 pragma Inline (New_Node); 639 640 procedure Local_Insert is 641 new Key_Ops.Generic_Conditional_Insert (New_Node); 642 643 procedure Allocate is 644 new HT_Ops.Generic_Allocate (Assign_Key); 645 646 ----------------- 647 -- Assign_Key -- 648 ----------------- 649 650 procedure Assign_Key (Node : in out Node_Type) is 651 begin 652 Node.Key := Key; 653 Node.Element := New_Item; 654 end Assign_Key; 655 656 -------------- 657 -- New_Node -- 658 -------------- 659 660 function New_Node return Count_Type is 661 Result : Count_Type; 662 begin 663 Allocate (Container, Result); 664 return Result; 665 end New_Node; 666 667 -- Start of processing for Insert 668 669 begin 670 -- The buckets array length is specified by the user as a discriminant 671 -- of the container type, so it is possible for the buckets array to 672 -- have a length of zero. We must check for this case specifically, in 673 -- order to prevent divide-by-zero errors later, when we compute the 674 -- buckets array index value for a key, given its hash value. 675 676 if Checks and then Container.Buckets'Length = 0 then 677 raise Capacity_Error with "No capacity for insertion"; 678 end if; 679 680 Local_Insert (Container, Key, Position.Node, Inserted); 681 Position.Container := Container'Unchecked_Access; 682 end Insert; 683 684 procedure Insert 685 (Container : in out Map; 686 Key : Key_Type; 687 New_Item : Element_Type) 688 is 689 Position : Cursor; 690 pragma Unreferenced (Position); 691 692 Inserted : Boolean; 693 694 begin 695 Insert (Container, Key, New_Item, Position, Inserted); 696 697 if Checks and then not Inserted then 698 raise Constraint_Error with 699 "attempt to insert key already in map"; 700 end if; 701 end Insert; 702 703 -------------- 704 -- Is_Empty -- 705 -------------- 706 707 function Is_Empty (Container : Map) return Boolean is 708 begin 709 return Container.Length = 0; 710 end Is_Empty; 711 712 ------------- 713 -- Iterate -- 714 ------------- 715 716 procedure Iterate 717 (Container : Map; 718 Process : not null access procedure (Position : Cursor)) 719 is 720 procedure Process_Node (Node : Count_Type); 721 pragma Inline (Process_Node); 722 723 procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); 724 725 ------------------ 726 -- Process_Node -- 727 ------------------ 728 729 procedure Process_Node (Node : Count_Type) is 730 begin 731 Process (Cursor'(Container'Unrestricted_Access, Node)); 732 end Process_Node; 733 734 Busy : With_Busy (Container.TC'Unrestricted_Access); 735 736 -- Start of processing for Iterate 737 738 begin 739 Local_Iterate (Container); 740 end Iterate; 741 742 function Iterate 743 (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class 744 is 745 begin 746 return It : constant Iterator := 747 (Limited_Controlled with 748 Container => Container'Unrestricted_Access) 749 do 750 Busy (Container.TC'Unrestricted_Access.all); 751 end return; 752 end Iterate; 753 754 --------- 755 -- Key -- 756 --------- 757 758 function Key (Position : Cursor) return Key_Type is 759 begin 760 if Checks and then Position.Node = 0 then 761 raise Constraint_Error with 762 "Position cursor of function Key equals No_Element"; 763 end if; 764 765 pragma Assert (Vet (Position), "bad cursor in function Key"); 766 767 return Position.Container.Nodes (Position.Node).Key; 768 end Key; 769 770 ------------ 771 -- Length -- 772 ------------ 773 774 function Length (Container : Map) return Count_Type is 775 begin 776 return Container.Length; 777 end Length; 778 779 ---------- 780 -- Move -- 781 ---------- 782 783 procedure Move 784 (Target : in out Map; 785 Source : in out Map) 786 is 787 begin 788 if Target'Address = Source'Address then 789 return; 790 end if; 791 792 TC_Check (Source.TC); 793 794 Target.Assign (Source); 795 Source.Clear; 796 end Move; 797 798 ---------- 799 -- Next -- 800 ---------- 801 802 function Next (Node : Node_Type) return Count_Type is 803 begin 804 return Node.Next; 805 end Next; 806 807 function Next (Position : Cursor) return Cursor is 808 begin 809 if Position.Node = 0 then 810 return No_Element; 811 end if; 812 813 pragma Assert (Vet (Position), "bad cursor in function Next"); 814 815 declare 816 M : Map renames Position.Container.all; 817 Node : constant Count_Type := HT_Ops.Next (M, Position.Node); 818 begin 819 if Node = 0 then 820 return No_Element; 821 else 822 return Cursor'(Position.Container, Node); 823 end if; 824 end; 825 end Next; 826 827 procedure Next (Position : in out Cursor) is 828 begin 829 Position := Next (Position); 830 end Next; 831 832 function Next 833 (Object : Iterator; 834 Position : Cursor) return Cursor 835 is 836 begin 837 if Position.Container = null then 838 return No_Element; 839 end if; 840 841 if Checks and then Position.Container /= Object.Container then 842 raise Program_Error with 843 "Position cursor of Next designates wrong map"; 844 end if; 845 846 return Next (Position); 847 end Next; 848 849 ---------------------- 850 -- Pseudo_Reference -- 851 ---------------------- 852 853 function Pseudo_Reference 854 (Container : aliased Map'Class) return Reference_Control_Type 855 is 856 TC : constant Tamper_Counts_Access := 857 Container.TC'Unrestricted_Access; 858 begin 859 return R : constant Reference_Control_Type := (Controlled with TC) do 860 Lock (TC.all); 861 end return; 862 end Pseudo_Reference; 863 864 ------------------- 865 -- Query_Element -- 866 ------------------- 867 868 procedure Query_Element 869 (Position : Cursor; 870 Process : not null access 871 procedure (Key : Key_Type; Element : Element_Type)) 872 is 873 begin 874 if Checks and then Position.Node = 0 then 875 raise Constraint_Error with 876 "Position cursor of Query_Element equals No_Element"; 877 end if; 878 879 pragma Assert (Vet (Position), "bad cursor in Query_Element"); 880 881 declare 882 M : Map renames Position.Container.all; 883 N : Node_Type renames M.Nodes (Position.Node); 884 Lock : With_Lock (M.TC'Unrestricted_Access); 885 begin 886 Process (N.Key, N.Element); 887 end; 888 end Query_Element; 889 890 ---------- 891 -- Read -- 892 ---------- 893 894 procedure Read 895 (Stream : not null access Root_Stream_Type'Class; 896 Container : out Map) 897 is 898 function Read_Node 899 (Stream : not null access Root_Stream_Type'Class) return Count_Type; 900 -- pragma Inline (Read_Node); ??? 901 902 procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); 903 904 --------------- 905 -- Read_Node -- 906 --------------- 907 908 function Read_Node 909 (Stream : not null access Root_Stream_Type'Class) return Count_Type 910 is 911 procedure Read_Element (Node : in out Node_Type); 912 -- pragma Inline (Read_Element); ??? 913 914 procedure Allocate is 915 new HT_Ops.Generic_Allocate (Read_Element); 916 917 procedure Read_Element (Node : in out Node_Type) is 918 begin 919 Key_Type'Read (Stream, Node.Key); 920 Element_Type'Read (Stream, Node.Element); 921 end Read_Element; 922 923 Node : Count_Type; 924 925 -- Start of processing for Read_Node 926 927 begin 928 Allocate (Container, Node); 929 return Node; 930 end Read_Node; 931 932 -- Start of processing for Read 933 934 begin 935 Read_Nodes (Stream, Container); 936 end Read; 937 938 procedure Read 939 (Stream : not null access Root_Stream_Type'Class; 940 Item : out Cursor) 941 is 942 begin 943 raise Program_Error with "attempt to stream map cursor"; 944 end Read; 945 946 procedure Read 947 (Stream : not null access Root_Stream_Type'Class; 948 Item : out Reference_Type) 949 is 950 begin 951 raise Program_Error with "attempt to stream reference"; 952 end Read; 953 954 procedure Read 955 (Stream : not null access Root_Stream_Type'Class; 956 Item : out Constant_Reference_Type) 957 is 958 begin 959 raise Program_Error with "attempt to stream reference"; 960 end Read; 961 962 --------------- 963 -- Reference -- 964 --------------- 965 966 function Reference 967 (Container : aliased in out Map; 968 Position : Cursor) return Reference_Type 969 is 970 begin 971 if Checks and then Position.Container = null then 972 raise Constraint_Error with 973 "Position cursor has no element"; 974 end if; 975 976 if Checks and then Position.Container /= Container'Unrestricted_Access 977 then 978 raise Program_Error with 979 "Position cursor designates wrong map"; 980 end if; 981 982 pragma Assert (Vet (Position), 983 "Position cursor in function Reference is bad"); 984 985 declare 986 N : Node_Type renames Container.Nodes (Position.Node); 987 TC : constant Tamper_Counts_Access := 988 Container.TC'Unrestricted_Access; 989 begin 990 return R : constant Reference_Type := 991 (Element => N.Element'Access, 992 Control => (Controlled with TC)) 993 do 994 Lock (TC.all); 995 end return; 996 end; 997 end Reference; 998 999 function Reference 1000 (Container : aliased in out Map; 1001 Key : Key_Type) return Reference_Type 1002 is 1003 Node : constant Count_Type := Key_Ops.Find (Container, Key); 1004 1005 begin 1006 if Checks and then Node = 0 then 1007 raise Constraint_Error with "key not in map"; 1008 end if; 1009 1010 declare 1011 N : Node_Type renames Container.Nodes (Node); 1012 TC : constant Tamper_Counts_Access := 1013 Container.TC'Unrestricted_Access; 1014 begin 1015 return R : constant Reference_Type := 1016 (Element => N.Element'Access, 1017 Control => (Controlled with TC)) 1018 do 1019 Lock (TC.all); 1020 end return; 1021 end; 1022 end Reference; 1023 1024 ------------- 1025 -- Replace -- 1026 ------------- 1027 1028 procedure Replace 1029 (Container : in out Map; 1030 Key : Key_Type; 1031 New_Item : Element_Type) 1032 is 1033 Node : constant Count_Type := Key_Ops.Find (Container, Key); 1034 1035 begin 1036 if Checks and then Node = 0 then 1037 raise Constraint_Error with 1038 "attempt to replace key not in map"; 1039 end if; 1040 1041 TE_Check (Container.TC); 1042 1043 declare 1044 N : Node_Type renames Container.Nodes (Node); 1045 begin 1046 N.Key := Key; 1047 N.Element := New_Item; 1048 end; 1049 end Replace; 1050 1051 --------------------- 1052 -- Replace_Element -- 1053 --------------------- 1054 1055 procedure Replace_Element 1056 (Container : in out Map; 1057 Position : Cursor; 1058 New_Item : Element_Type) 1059 is 1060 begin 1061 if Checks and then Position.Node = 0 then 1062 raise Constraint_Error with 1063 "Position cursor of Replace_Element equals No_Element"; 1064 end if; 1065 1066 if Checks and then Position.Container /= Container'Unrestricted_Access 1067 then 1068 raise Program_Error with 1069 "Position cursor of Replace_Element designates wrong map"; 1070 end if; 1071 1072 TE_Check (Position.Container.TC); 1073 1074 pragma Assert (Vet (Position), "bad cursor in Replace_Element"); 1075 1076 Container.Nodes (Position.Node).Element := New_Item; 1077 end Replace_Element; 1078 1079 ---------------------- 1080 -- Reserve_Capacity -- 1081 ---------------------- 1082 1083 procedure Reserve_Capacity 1084 (Container : in out Map; 1085 Capacity : Count_Type) 1086 is 1087 begin 1088 if Checks and then Capacity > Container.Capacity then 1089 raise Capacity_Error with "requested capacity is too large"; 1090 end if; 1091 end Reserve_Capacity; 1092 1093 -------------- 1094 -- Set_Next -- 1095 -------------- 1096 1097 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is 1098 begin 1099 Node.Next := Next; 1100 end Set_Next; 1101 1102 -------------------- 1103 -- Update_Element -- 1104 -------------------- 1105 1106 procedure Update_Element 1107 (Container : in out Map; 1108 Position : Cursor; 1109 Process : not null access procedure (Key : Key_Type; 1110 Element : in out Element_Type)) 1111 is 1112 begin 1113 if Checks and then Position.Node = 0 then 1114 raise Constraint_Error with 1115 "Position cursor of Update_Element equals No_Element"; 1116 end if; 1117 1118 if Checks and then Position.Container /= Container'Unrestricted_Access 1119 then 1120 raise Program_Error with 1121 "Position cursor of Update_Element designates wrong map"; 1122 end if; 1123 1124 pragma Assert (Vet (Position), "bad cursor in Update_Element"); 1125 1126 declare 1127 N : Node_Type renames Container.Nodes (Position.Node); 1128 Lock : With_Lock (Container.TC'Unrestricted_Access); 1129 begin 1130 Process (N.Key, N.Element); 1131 end; 1132 end Update_Element; 1133 1134 --------- 1135 -- Vet -- 1136 --------- 1137 1138 function Vet (Position : Cursor) return Boolean is 1139 begin 1140 if Position.Node = 0 then 1141 return Position.Container = null; 1142 end if; 1143 1144 if Position.Container = null then 1145 return False; 1146 end if; 1147 1148 declare 1149 M : Map renames Position.Container.all; 1150 X : Count_Type; 1151 1152 begin 1153 if M.Length = 0 then 1154 return False; 1155 end if; 1156 1157 if M.Capacity = 0 then 1158 return False; 1159 end if; 1160 1161 if M.Buckets'Length = 0 then 1162 return False; 1163 end if; 1164 1165 if Position.Node > M.Capacity then 1166 return False; 1167 end if; 1168 1169 if M.Nodes (Position.Node).Next = Position.Node then 1170 return False; 1171 end if; 1172 1173 X := M.Buckets (Key_Ops.Checked_Index 1174 (M, M.Nodes (Position.Node).Key)); 1175 1176 for J in 1 .. M.Length loop 1177 if X = Position.Node then 1178 return True; 1179 end if; 1180 1181 if X = 0 then 1182 return False; 1183 end if; 1184 1185 if X = M.Nodes (X).Next then -- to prevent unnecessary looping 1186 return False; 1187 end if; 1188 1189 X := M.Nodes (X).Next; 1190 end loop; 1191 1192 return False; 1193 end; 1194 end Vet; 1195 1196 ----------- 1197 -- Write -- 1198 ----------- 1199 1200 procedure Write 1201 (Stream : not null access Root_Stream_Type'Class; 1202 Container : Map) 1203 is 1204 procedure Write_Node 1205 (Stream : not null access Root_Stream_Type'Class; 1206 Node : Node_Type); 1207 pragma Inline (Write_Node); 1208 1209 procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); 1210 1211 ---------------- 1212 -- Write_Node -- 1213 ---------------- 1214 1215 procedure Write_Node 1216 (Stream : not null access Root_Stream_Type'Class; 1217 Node : Node_Type) 1218 is 1219 begin 1220 Key_Type'Write (Stream, Node.Key); 1221 Element_Type'Write (Stream, Node.Element); 1222 end Write_Node; 1223 1224 -- Start of processing for Write 1225 1226 begin 1227 Write_Nodes (Stream, Container); 1228 end Write; 1229 1230 procedure Write 1231 (Stream : not null access Root_Stream_Type'Class; 1232 Item : Cursor) 1233 is 1234 begin 1235 raise Program_Error with "attempt to stream map cursor"; 1236 end Write; 1237 1238 procedure Write 1239 (Stream : not null access Root_Stream_Type'Class; 1240 Item : Reference_Type) 1241 is 1242 begin 1243 raise Program_Error with "attempt to stream reference"; 1244 end Write; 1245 1246 procedure Write 1247 (Stream : not null access Root_Stream_Type'Class; 1248 Item : Constant_Reference_Type) 1249 is 1250 begin 1251 raise Program_Error with "attempt to stream reference"; 1252 end Write; 1253 1254end Ada.Containers.Bounded_Hashed_Maps; 1255