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