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