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