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