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