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