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-2015, 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 New_Item : Element_Type; 582 pragma Unmodified (New_Item); 583 -- Default-initialized element (ok to reference, see below) 584 585 begin 586 Node.Key := Key; 587 588 -- There is no explicit element provided, but in an instance the 589 -- element type may be a scalar with a Default_Value aspect, or a 590 -- composite type with such a scalar component, or components with 591 -- default initialization, so insert a possibly initialized element 592 -- under the given key. 593 594 Node.Element := New_Item; 595 end Assign_Key; 596 597 -------------- 598 -- New_Node -- 599 -------------- 600 601 function New_Node return Count_Type is 602 Result : Count_Type; 603 begin 604 Allocate (Container, Result); 605 return Result; 606 end New_Node; 607 608 -- Start of processing for Insert 609 610 begin 611 -- The buckets array length is specified by the user as a discriminant 612 -- of the container type, so it is possible for the buckets array to 613 -- have a length of zero. We must check for this case specifically, in 614 -- order to prevent divide-by-zero errors later, when we compute the 615 -- buckets array index value for a key, given its hash value. 616 617 if Checks and then Container.Buckets'Length = 0 then 618 raise Capacity_Error with "No capacity for insertion"; 619 end if; 620 621 Local_Insert (Container, Key, Position.Node, Inserted); 622 Position.Container := Container'Unchecked_Access; 623 end Insert; 624 625 procedure Insert 626 (Container : in out Map; 627 Key : Key_Type; 628 New_Item : Element_Type; 629 Position : out Cursor; 630 Inserted : out Boolean) 631 is 632 procedure Assign_Key (Node : in out Node_Type); 633 pragma Inline (Assign_Key); 634 635 function New_Node return Count_Type; 636 pragma Inline (New_Node); 637 638 procedure Local_Insert is 639 new Key_Ops.Generic_Conditional_Insert (New_Node); 640 641 procedure Allocate is 642 new HT_Ops.Generic_Allocate (Assign_Key); 643 644 ----------------- 645 -- Assign_Key -- 646 ----------------- 647 648 procedure Assign_Key (Node : in out Node_Type) is 649 begin 650 Node.Key := Key; 651 Node.Element := New_Item; 652 end Assign_Key; 653 654 -------------- 655 -- New_Node -- 656 -------------- 657 658 function New_Node return Count_Type is 659 Result : Count_Type; 660 begin 661 Allocate (Container, Result); 662 return Result; 663 end New_Node; 664 665 -- Start of processing for Insert 666 667 begin 668 -- The buckets array length is specified by the user as a discriminant 669 -- of the container type, so it is possible for the buckets array to 670 -- have a length of zero. We must check for this case specifically, in 671 -- order to prevent divide-by-zero errors later, when we compute the 672 -- buckets array index value for a key, given its hash value. 673 674 if Checks and then Container.Buckets'Length = 0 then 675 raise Capacity_Error with "No capacity for insertion"; 676 end if; 677 678 Local_Insert (Container, Key, Position.Node, Inserted); 679 Position.Container := Container'Unchecked_Access; 680 end Insert; 681 682 procedure Insert 683 (Container : in out Map; 684 Key : Key_Type; 685 New_Item : Element_Type) 686 is 687 Position : Cursor; 688 pragma Unreferenced (Position); 689 690 Inserted : Boolean; 691 692 begin 693 Insert (Container, Key, New_Item, Position, Inserted); 694 695 if Checks and then not Inserted then 696 raise Constraint_Error with 697 "attempt to insert key already in map"; 698 end if; 699 end Insert; 700 701 -------------- 702 -- Is_Empty -- 703 -------------- 704 705 function Is_Empty (Container : Map) return Boolean is 706 begin 707 return Container.Length = 0; 708 end Is_Empty; 709 710 ------------- 711 -- Iterate -- 712 ------------- 713 714 procedure Iterate 715 (Container : Map; 716 Process : not null access procedure (Position : Cursor)) 717 is 718 procedure Process_Node (Node : Count_Type); 719 pragma Inline (Process_Node); 720 721 procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); 722 723 ------------------ 724 -- Process_Node -- 725 ------------------ 726 727 procedure Process_Node (Node : Count_Type) is 728 begin 729 Process (Cursor'(Container'Unrestricted_Access, Node)); 730 end Process_Node; 731 732 Busy : With_Busy (Container.TC'Unrestricted_Access); 733 734 -- Start of processing for Iterate 735 736 begin 737 Local_Iterate (Container); 738 end Iterate; 739 740 function Iterate 741 (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class 742 is 743 begin 744 return It : constant Iterator := 745 (Limited_Controlled with 746 Container => Container'Unrestricted_Access) 747 do 748 Busy (Container.TC'Unrestricted_Access.all); 749 end return; 750 end Iterate; 751 752 --------- 753 -- Key -- 754 --------- 755 756 function Key (Position : Cursor) return Key_Type is 757 begin 758 if Checks and then Position.Node = 0 then 759 raise Constraint_Error with 760 "Position cursor of function Key equals No_Element"; 761 end if; 762 763 pragma Assert (Vet (Position), "bad cursor in function Key"); 764 765 return Position.Container.Nodes (Position.Node).Key; 766 end Key; 767 768 ------------ 769 -- Length -- 770 ------------ 771 772 function Length (Container : Map) return Count_Type is 773 begin 774 return Container.Length; 775 end Length; 776 777 ---------- 778 -- Move -- 779 ---------- 780 781 procedure Move 782 (Target : in out Map; 783 Source : in out Map) 784 is 785 begin 786 if Target'Address = Source'Address then 787 return; 788 end if; 789 790 TC_Check (Source.TC); 791 792 Target.Assign (Source); 793 Source.Clear; 794 end Move; 795 796 ---------- 797 -- Next -- 798 ---------- 799 800 function Next (Node : Node_Type) return Count_Type is 801 begin 802 return Node.Next; 803 end Next; 804 805 function Next (Position : Cursor) return Cursor is 806 begin 807 if Position.Node = 0 then 808 return No_Element; 809 end if; 810 811 pragma Assert (Vet (Position), "bad cursor in function Next"); 812 813 declare 814 M : Map renames Position.Container.all; 815 Node : constant Count_Type := HT_Ops.Next (M, Position.Node); 816 begin 817 if Node = 0 then 818 return No_Element; 819 else 820 return Cursor'(Position.Container, Node); 821 end if; 822 end; 823 end Next; 824 825 procedure Next (Position : in out Cursor) is 826 begin 827 Position := Next (Position); 828 end Next; 829 830 function Next 831 (Object : Iterator; 832 Position : Cursor) return Cursor 833 is 834 begin 835 if Position.Container = null then 836 return No_Element; 837 end if; 838 839 if Checks and then Position.Container /= Object.Container then 840 raise Program_Error with 841 "Position cursor of Next designates wrong map"; 842 end if; 843 844 return Next (Position); 845 end Next; 846 847 ---------------------- 848 -- Pseudo_Reference -- 849 ---------------------- 850 851 function Pseudo_Reference 852 (Container : aliased Map'Class) return Reference_Control_Type 853 is 854 TC : constant Tamper_Counts_Access := 855 Container.TC'Unrestricted_Access; 856 begin 857 return R : constant Reference_Control_Type := (Controlled with TC) do 858 Lock (TC.all); 859 end return; 860 end Pseudo_Reference; 861 862 ------------------- 863 -- Query_Element -- 864 ------------------- 865 866 procedure Query_Element 867 (Position : Cursor; 868 Process : not null access 869 procedure (Key : Key_Type; Element : Element_Type)) 870 is 871 begin 872 if Checks and then Position.Node = 0 then 873 raise Constraint_Error with 874 "Position cursor of Query_Element equals No_Element"; 875 end if; 876 877 pragma Assert (Vet (Position), "bad cursor in Query_Element"); 878 879 declare 880 M : Map renames Position.Container.all; 881 N : Node_Type renames M.Nodes (Position.Node); 882 Lock : With_Lock (M.TC'Unrestricted_Access); 883 begin 884 Process (N.Key, N.Element); 885 end; 886 end Query_Element; 887 888 ---------- 889 -- Read -- 890 ---------- 891 892 procedure Read 893 (Stream : not null access Root_Stream_Type'Class; 894 Container : out Map) 895 is 896 function Read_Node 897 (Stream : not null access Root_Stream_Type'Class) return Count_Type; 898 -- pragma Inline (Read_Node); ??? 899 900 procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); 901 902 --------------- 903 -- Read_Node -- 904 --------------- 905 906 function Read_Node 907 (Stream : not null access Root_Stream_Type'Class) return Count_Type 908 is 909 procedure Read_Element (Node : in out Node_Type); 910 -- pragma Inline (Read_Element); ??? 911 912 procedure Allocate is 913 new HT_Ops.Generic_Allocate (Read_Element); 914 915 procedure Read_Element (Node : in out Node_Type) is 916 begin 917 Key_Type'Read (Stream, Node.Key); 918 Element_Type'Read (Stream, Node.Element); 919 end Read_Element; 920 921 Node : Count_Type; 922 923 -- Start of processing for Read_Node 924 925 begin 926 Allocate (Container, Node); 927 return Node; 928 end Read_Node; 929 930 -- Start of processing for Read 931 932 begin 933 Read_Nodes (Stream, Container); 934 end Read; 935 936 procedure Read 937 (Stream : not null access Root_Stream_Type'Class; 938 Item : out Cursor) 939 is 940 begin 941 raise Program_Error with "attempt to stream map cursor"; 942 end Read; 943 944 procedure Read 945 (Stream : not null access Root_Stream_Type'Class; 946 Item : out Reference_Type) 947 is 948 begin 949 raise Program_Error with "attempt to stream reference"; 950 end Read; 951 952 procedure Read 953 (Stream : not null access Root_Stream_Type'Class; 954 Item : out Constant_Reference_Type) 955 is 956 begin 957 raise Program_Error with "attempt to stream reference"; 958 end Read; 959 960 --------------- 961 -- Reference -- 962 --------------- 963 964 function Reference 965 (Container : aliased in out Map; 966 Position : Cursor) return Reference_Type 967 is 968 begin 969 if Checks and then Position.Container = null then 970 raise Constraint_Error with 971 "Position cursor has no element"; 972 end if; 973 974 if Checks and then Position.Container /= Container'Unrestricted_Access 975 then 976 raise Program_Error with 977 "Position cursor designates wrong map"; 978 end if; 979 980 pragma Assert (Vet (Position), 981 "Position cursor in function Reference is bad"); 982 983 declare 984 N : Node_Type renames Container.Nodes (Position.Node); 985 TC : constant Tamper_Counts_Access := 986 Container.TC'Unrestricted_Access; 987 begin 988 return R : constant Reference_Type := 989 (Element => N.Element'Access, 990 Control => (Controlled with TC)) 991 do 992 Lock (TC.all); 993 end return; 994 end; 995 end Reference; 996 997 function Reference 998 (Container : aliased in out Map; 999 Key : Key_Type) return Reference_Type 1000 is 1001 Node : constant Count_Type := Key_Ops.Find (Container, Key); 1002 1003 begin 1004 if Checks and then Node = 0 then 1005 raise Constraint_Error with "key not in map"; 1006 end if; 1007 1008 declare 1009 N : Node_Type renames Container.Nodes (Node); 1010 TC : constant Tamper_Counts_Access := 1011 Container.TC'Unrestricted_Access; 1012 begin 1013 return R : constant Reference_Type := 1014 (Element => N.Element'Access, 1015 Control => (Controlled with TC)) 1016 do 1017 Lock (TC.all); 1018 end return; 1019 end; 1020 end Reference; 1021 1022 ------------- 1023 -- Replace -- 1024 ------------- 1025 1026 procedure Replace 1027 (Container : in out Map; 1028 Key : Key_Type; 1029 New_Item : Element_Type) 1030 is 1031 Node : constant Count_Type := Key_Ops.Find (Container, Key); 1032 1033 begin 1034 if Checks and then Node = 0 then 1035 raise Constraint_Error with 1036 "attempt to replace key not in map"; 1037 end if; 1038 1039 TE_Check (Container.TC); 1040 1041 declare 1042 N : Node_Type renames Container.Nodes (Node); 1043 begin 1044 N.Key := Key; 1045 N.Element := New_Item; 1046 end; 1047 end Replace; 1048 1049 --------------------- 1050 -- Replace_Element -- 1051 --------------------- 1052 1053 procedure Replace_Element 1054 (Container : in out Map; 1055 Position : Cursor; 1056 New_Item : Element_Type) 1057 is 1058 begin 1059 if Checks and then Position.Node = 0 then 1060 raise Constraint_Error with 1061 "Position cursor of Replace_Element equals No_Element"; 1062 end if; 1063 1064 if Checks and then Position.Container /= Container'Unrestricted_Access 1065 then 1066 raise Program_Error with 1067 "Position cursor of Replace_Element designates wrong map"; 1068 end if; 1069 1070 TE_Check (Position.Container.TC); 1071 1072 pragma Assert (Vet (Position), "bad cursor in Replace_Element"); 1073 1074 Container.Nodes (Position.Node).Element := New_Item; 1075 end Replace_Element; 1076 1077 ---------------------- 1078 -- Reserve_Capacity -- 1079 ---------------------- 1080 1081 procedure Reserve_Capacity 1082 (Container : in out Map; 1083 Capacity : Count_Type) 1084 is 1085 begin 1086 if Checks and then Capacity > Container.Capacity then 1087 raise Capacity_Error with "requested capacity is too large"; 1088 end if; 1089 end Reserve_Capacity; 1090 1091 -------------- 1092 -- Set_Next -- 1093 -------------- 1094 1095 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is 1096 begin 1097 Node.Next := Next; 1098 end Set_Next; 1099 1100 -------------------- 1101 -- Update_Element -- 1102 -------------------- 1103 1104 procedure Update_Element 1105 (Container : in out Map; 1106 Position : Cursor; 1107 Process : not null access procedure (Key : Key_Type; 1108 Element : in out Element_Type)) 1109 is 1110 begin 1111 if Checks and then Position.Node = 0 then 1112 raise Constraint_Error with 1113 "Position cursor of Update_Element equals No_Element"; 1114 end if; 1115 1116 if Checks and then Position.Container /= Container'Unrestricted_Access 1117 then 1118 raise Program_Error with 1119 "Position cursor of Update_Element designates wrong map"; 1120 end if; 1121 1122 pragma Assert (Vet (Position), "bad cursor in Update_Element"); 1123 1124 declare 1125 N : Node_Type renames Container.Nodes (Position.Node); 1126 Lock : With_Lock (Container.TC'Unrestricted_Access); 1127 begin 1128 Process (N.Key, N.Element); 1129 end; 1130 end Update_Element; 1131 1132 --------- 1133 -- Vet -- 1134 --------- 1135 1136 function Vet (Position : Cursor) return Boolean is 1137 begin 1138 if Position.Node = 0 then 1139 return Position.Container = null; 1140 end if; 1141 1142 if Position.Container = null then 1143 return False; 1144 end if; 1145 1146 declare 1147 M : Map renames Position.Container.all; 1148 X : Count_Type; 1149 1150 begin 1151 if M.Length = 0 then 1152 return False; 1153 end if; 1154 1155 if M.Capacity = 0 then 1156 return False; 1157 end if; 1158 1159 if M.Buckets'Length = 0 then 1160 return False; 1161 end if; 1162 1163 if Position.Node > M.Capacity then 1164 return False; 1165 end if; 1166 1167 if M.Nodes (Position.Node).Next = Position.Node then 1168 return False; 1169 end if; 1170 1171 X := M.Buckets (Key_Ops.Checked_Index 1172 (M, M.Nodes (Position.Node).Key)); 1173 1174 for J in 1 .. M.Length loop 1175 if X = Position.Node then 1176 return True; 1177 end if; 1178 1179 if X = 0 then 1180 return False; 1181 end if; 1182 1183 if X = M.Nodes (X).Next then -- to prevent unnecessary looping 1184 return False; 1185 end if; 1186 1187 X := M.Nodes (X).Next; 1188 end loop; 1189 1190 return False; 1191 end; 1192 end Vet; 1193 1194 ----------- 1195 -- Write -- 1196 ----------- 1197 1198 procedure Write 1199 (Stream : not null access Root_Stream_Type'Class; 1200 Container : Map) 1201 is 1202 procedure Write_Node 1203 (Stream : not null access Root_Stream_Type'Class; 1204 Node : Node_Type); 1205 pragma Inline (Write_Node); 1206 1207 procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); 1208 1209 ---------------- 1210 -- Write_Node -- 1211 ---------------- 1212 1213 procedure Write_Node 1214 (Stream : not null access Root_Stream_Type'Class; 1215 Node : Node_Type) 1216 is 1217 begin 1218 Key_Type'Write (Stream, Node.Key); 1219 Element_Type'Write (Stream, Node.Element); 1220 end Write_Node; 1221 1222 -- Start of processing for Write 1223 1224 begin 1225 Write_Nodes (Stream, Container); 1226 end Write; 1227 1228 procedure Write 1229 (Stream : not null access Root_Stream_Type'Class; 1230 Item : Cursor) 1231 is 1232 begin 1233 raise Program_Error with "attempt to stream map cursor"; 1234 end Write; 1235 1236 procedure Write 1237 (Stream : not null access Root_Stream_Type'Class; 1238 Item : Reference_Type) 1239 is 1240 begin 1241 raise Program_Error with "attempt to stream reference"; 1242 end Write; 1243 1244 procedure Write 1245 (Stream : not null access Root_Stream_Type'Class; 1246 Item : Constant_Reference_Type) 1247 is 1248 begin 1249 raise Program_Error with "attempt to stream reference"; 1250 end Write; 1251 1252end Ada.Containers.Bounded_Hashed_Maps; 1253