File : a-cfhama.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2010-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
28 with Ada.Containers.Hash_Tables.Generic_Bounded_Operations;
29 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
30
31 with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
32 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
33
34 with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
35
36 with System; use type System.Address;
37
38 package body Ada.Containers.Formal_Hashed_Maps with
39 SPARK_Mode => Off
40 is
41
42 -----------------------
43 -- Local Subprograms --
44 -----------------------
45
46 -- All local subprograms require comments ???
47
48 function Equivalent_Keys
49 (Key : Key_Type;
50 Node : Node_Type) return Boolean;
51 pragma Inline (Equivalent_Keys);
52
53 procedure Free
54 (HT : in out Map;
55 X : Count_Type);
56
57 generic
58 with procedure Set_Element (Node : in out Node_Type);
59 procedure Generic_Allocate
60 (HT : in out Map;
61 Node : out Count_Type);
62
63 function Hash_Node (Node : Node_Type) return Hash_Type;
64 pragma Inline (Hash_Node);
65
66 function Next (Node : Node_Type) return Count_Type;
67 pragma Inline (Next);
68
69 procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
70 pragma Inline (Set_Next);
71
72 function Vet (Container : Map; Position : Cursor) return Boolean;
73
74 --------------------------
75 -- Local Instantiations --
76 --------------------------
77
78 package HT_Ops is
79 new Hash_Tables.Generic_Bounded_Operations
80 (HT_Types => HT_Types,
81 Hash_Node => Hash_Node,
82 Next => Next,
83 Set_Next => Set_Next);
84
85 package Key_Ops is
86 new Hash_Tables.Generic_Bounded_Keys
87 (HT_Types => HT_Types,
88 Next => Next,
89 Set_Next => Set_Next,
90 Key_Type => Key_Type,
91 Hash => Hash,
92 Equivalent_Keys => Equivalent_Keys);
93
94 ---------
95 -- "=" --
96 ---------
97
98 function "=" (Left, Right : Map) return Boolean is
99 begin
100 if Length (Left) /= Length (Right) then
101 return False;
102 end if;
103
104 if Length (Left) = 0 then
105 return True;
106 end if;
107
108 declare
109 Node : Count_Type;
110 ENode : Count_Type;
111
112 begin
113 Node := Left.First.Node;
114 while Node /= 0 loop
115 ENode := Find (Container => Right,
116 Key => Left.Nodes (Node).Key).Node;
117
118 if ENode = 0 or else
119 Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
120 then
121 return False;
122 end if;
123
124 Node := HT_Ops.Next (Left, Node);
125 end loop;
126
127 return True;
128 end;
129 end "=";
130
131 ------------
132 -- Assign --
133 ------------
134
135 procedure Assign (Target : in out Map; Source : Map) is
136 procedure Insert_Element (Source_Node : Count_Type);
137 pragma Inline (Insert_Element);
138
139 procedure Insert_Elements is
140 new HT_Ops.Generic_Iteration (Insert_Element);
141
142 --------------------
143 -- Insert_Element --
144 --------------------
145
146 procedure Insert_Element (Source_Node : Count_Type) is
147 N : Node_Type renames Source.Nodes (Source_Node);
148 begin
149 Insert (Target, N.Key, N.Element);
150 end Insert_Element;
151
152 -- Start of processing for Assign
153
154 begin
155 if Target'Address = Source'Address then
156 return;
157 end if;
158
159 if Target.Capacity < Length (Source) then
160 raise Constraint_Error with -- correct exception ???
161 "Source length exceeds Target capacity";
162 end if;
163
164 Clear (Target);
165
166 Insert_Elements (Source);
167 end Assign;
168
169 --------------
170 -- Capacity --
171 --------------
172
173 function Capacity (Container : Map) return Count_Type is
174 begin
175 return Container.Nodes'Length;
176 end Capacity;
177
178 -----------
179 -- Clear --
180 -----------
181
182 procedure Clear (Container : in out Map) is
183 begin
184 HT_Ops.Clear (Container);
185 end Clear;
186
187 --------------
188 -- Contains --
189 --------------
190
191 function Contains (Container : Map; Key : Key_Type) return Boolean is
192 begin
193 return Find (Container, Key) /= No_Element;
194 end Contains;
195
196 ----------
197 -- Copy --
198 ----------
199
200 function Copy
201 (Source : Map;
202 Capacity : Count_Type := 0) return Map
203 is
204 C : constant Count_Type :=
205 Count_Type'Max (Capacity, Source.Capacity);
206 H : Hash_Type;
207 N : Count_Type;
208 Target : Map (C, Source.Modulus);
209 Cu : Cursor;
210
211 begin
212 if 0 < Capacity and then Capacity < Source.Capacity then
213 raise Capacity_Error;
214 end if;
215
216 Target.Length := Source.Length;
217 Target.Free := Source.Free;
218
219 H := 1;
220 while H <= Source.Modulus loop
221 Target.Buckets (H) := Source.Buckets (H);
222 H := H + 1;
223 end loop;
224
225 N := 1;
226 while N <= Source.Capacity loop
227 Target.Nodes (N) := Source.Nodes (N);
228 N := N + 1;
229 end loop;
230
231 while N <= C loop
232 Cu := (Node => N);
233 Free (Target, Cu.Node);
234 N := N + 1;
235 end loop;
236
237 return Target;
238 end Copy;
239
240 ---------------------
241 -- Current_To_Last --
242 ---------------------
243
244 function Current_To_Last (Container : Map; Current : Cursor) return Map is
245 Curs : Cursor := First (Container);
246 C : Map (Container.Capacity, Container.Modulus) :=
247 Copy (Container, Container.Capacity);
248 Node : Count_Type;
249
250 begin
251 if Curs = No_Element then
252 Clear (C);
253 return C;
254
255 elsif Current /= No_Element and not Has_Element (Container, Current) then
256 raise Constraint_Error;
257
258 else
259 while Curs.Node /= Current.Node loop
260 Node := Curs.Node;
261 Delete (C, Curs);
262 Curs := Next (Container, (Node => Node));
263 end loop;
264
265 return C;
266 end if;
267 end Current_To_Last;
268
269 ---------------------
270 -- Default_Modulus --
271 ---------------------
272
273 function Default_Modulus (Capacity : Count_Type) return Hash_Type is
274 begin
275 return To_Prime (Capacity);
276 end Default_Modulus;
277
278 ------------
279 -- Delete --
280 ------------
281
282 procedure Delete (Container : in out Map; Key : Key_Type) is
283 X : Count_Type;
284
285 begin
286 Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
287
288 if X = 0 then
289 raise Constraint_Error with "attempt to delete key not in map";
290 end if;
291
292 Free (Container, X);
293 end Delete;
294
295 procedure Delete (Container : in out Map; Position : in out Cursor) is
296 begin
297 if not Has_Element (Container, Position) then
298 raise Constraint_Error with
299 "Position cursor of Delete has no element";
300 end if;
301
302 pragma Assert (Vet (Container, Position), "bad cursor in Delete");
303
304 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
305
306 Free (Container, Position.Node);
307 end Delete;
308
309 -------------
310 -- Element --
311 -------------
312
313 function Element (Container : Map; Key : Key_Type) return Element_Type is
314 Node : constant Count_Type := Find (Container, Key).Node;
315
316 begin
317 if Node = 0 then
318 raise Constraint_Error with
319 "no element available because key not in map";
320 end if;
321
322 return Container.Nodes (Node).Element;
323 end Element;
324
325 function Element (Container : Map; Position : Cursor) return Element_Type is
326 begin
327 if not Has_Element (Container, Position) then
328 raise Constraint_Error with "Position cursor equals No_Element";
329 end if;
330
331 pragma Assert (Vet (Container, Position),
332 "bad cursor in function Element");
333
334 return Container.Nodes (Position.Node).Element;
335 end Element;
336
337 ---------------------
338 -- Equivalent_Keys --
339 ---------------------
340
341 function Equivalent_Keys
342 (Key : Key_Type;
343 Node : Node_Type) return Boolean
344 is
345 begin
346 return Equivalent_Keys (Key, Node.Key);
347 end Equivalent_Keys;
348
349 function Equivalent_Keys
350 (Left : Map;
351 CLeft : Cursor;
352 Right : Map;
353 CRight : Cursor) return Boolean
354 is
355 begin
356 if not Has_Element (Left, CLeft) then
357 raise Constraint_Error with
358 "Left cursor of Equivalent_Keys has no element";
359 end if;
360
361 if not Has_Element (Right, CRight) then
362 raise Constraint_Error with
363 "Right cursor of Equivalent_Keys has no element";
364 end if;
365
366 pragma Assert (Vet (Left, CLeft),
367 "Left cursor of Equivalent_Keys is bad");
368 pragma Assert (Vet (Right, CRight),
369 "Right cursor of Equivalent_Keys is bad");
370
371 declare
372 LN : Node_Type renames Left.Nodes (CLeft.Node);
373 RN : Node_Type renames Right.Nodes (CRight.Node);
374 begin
375 return Equivalent_Keys (LN.Key, RN.Key);
376 end;
377 end Equivalent_Keys;
378
379 function Equivalent_Keys
380 (Left : Map;
381 CLeft : Cursor;
382 Right : Key_Type) return Boolean
383 is
384 begin
385 if not Has_Element (Left, CLeft) then
386 raise Constraint_Error with
387 "Left cursor of Equivalent_Keys has no element";
388 end if;
389
390 pragma Assert (Vet (Left, CLeft),
391 "Left cursor in Equivalent_Keys is bad");
392
393 declare
394 LN : Node_Type renames Left.Nodes (CLeft.Node);
395 begin
396 return Equivalent_Keys (LN.Key, Right);
397 end;
398 end Equivalent_Keys;
399
400 function Equivalent_Keys
401 (Left : Key_Type;
402 Right : Map;
403 CRight : Cursor) return Boolean
404 is
405 begin
406 if Has_Element (Right, CRight) then
407 raise Constraint_Error with
408 "Right cursor of Equivalent_Keys has no element";
409 end if;
410
411 pragma Assert (Vet (Right, CRight),
412 "Right cursor of Equivalent_Keys is bad");
413
414 declare
415 RN : Node_Type renames Right.Nodes (CRight.Node);
416
417 begin
418 return Equivalent_Keys (Left, RN.Key);
419 end;
420 end Equivalent_Keys;
421
422 -------------
423 -- Exclude --
424 -------------
425
426 procedure Exclude (Container : in out Map; Key : Key_Type) is
427 X : Count_Type;
428 begin
429 Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
430 Free (Container, X);
431 end Exclude;
432
433 ----------
434 -- Find --
435 ----------
436
437 function Find (Container : Map; Key : Key_Type) return Cursor is
438 Node : constant Count_Type := Key_Ops.Find (Container, Key);
439
440 begin
441 if Node = 0 then
442 return No_Element;
443 end if;
444
445 return (Node => Node);
446 end Find;
447
448 -----------
449 -- First --
450 -----------
451
452 function First (Container : Map) return Cursor is
453 Node : constant Count_Type := HT_Ops.First (Container);
454
455 begin
456 if Node = 0 then
457 return No_Element;
458 end if;
459
460 return (Node => Node);
461 end First;
462
463 -----------------------
464 -- First_To_Previous --
465 -----------------------
466
467 function First_To_Previous
468 (Container : Map;
469 Current : Cursor) return Map is
470 Curs : Cursor;
471 C : Map (Container.Capacity, Container.Modulus) :=
472 Copy (Container, Container.Capacity);
473 Node : Count_Type;
474
475 begin
476 Curs := Current;
477
478 if Curs = No_Element then
479 return C;
480
481 elsif not Has_Element (Container, Curs) then
482 raise Constraint_Error;
483
484 else
485 while Curs.Node /= 0 loop
486 Node := Curs.Node;
487 Delete (C, Curs);
488 Curs := Next (Container, (Node => Node));
489 end loop;
490
491 return C;
492 end if;
493 end First_To_Previous;
494
495 ----------
496 -- Free --
497 ----------
498
499 procedure Free (HT : in out Map; X : Count_Type) is
500 begin
501 HT.Nodes (X).Has_Element := False;
502 HT_Ops.Free (HT, X);
503 end Free;
504
505 ----------------------
506 -- Generic_Allocate --
507 ----------------------
508
509 procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is
510
511 procedure Allocate is
512 new HT_Ops.Generic_Allocate (Set_Element);
513
514 begin
515 Allocate (HT, Node);
516 HT.Nodes (Node).Has_Element := True;
517 end Generic_Allocate;
518
519 -----------------
520 -- Has_Element --
521 -----------------
522
523 function Has_Element (Container : Map; Position : Cursor) return Boolean is
524 begin
525 if Position.Node = 0
526 or else not Container.Nodes (Position.Node).Has_Element
527 then
528 return False;
529 else
530 return True;
531 end if;
532 end Has_Element;
533
534 ---------------
535 -- Hash_Node --
536 ---------------
537
538 function Hash_Node (Node : Node_Type) return Hash_Type is
539 begin
540 return Hash (Node.Key);
541 end Hash_Node;
542
543 -------------
544 -- Include --
545 -------------
546
547 procedure Include
548 (Container : in out Map;
549 Key : Key_Type;
550 New_Item : Element_Type)
551 is
552 Position : Cursor;
553 Inserted : Boolean;
554
555 begin
556 Insert (Container, Key, New_Item, Position, Inserted);
557
558 if not Inserted then
559 declare
560 N : Node_Type renames Container.Nodes (Position.Node);
561 begin
562 N.Key := Key;
563 N.Element := New_Item;
564 end;
565 end if;
566 end Include;
567
568 ------------
569 -- Insert --
570 ------------
571
572 procedure Insert
573 (Container : in out Map;
574 Key : Key_Type;
575 New_Item : Element_Type;
576 Position : out Cursor;
577 Inserted : out Boolean)
578 is
579 procedure Assign_Key (Node : in out Node_Type);
580 pragma Inline (Assign_Key);
581
582 function New_Node return Count_Type;
583 pragma Inline (New_Node);
584
585 procedure Local_Insert is
586 new Key_Ops.Generic_Conditional_Insert (New_Node);
587
588 procedure Allocate is
589 new Generic_Allocate (Assign_Key);
590
591 -----------------
592 -- Assign_Key --
593 -----------------
594
595 procedure Assign_Key (Node : in out Node_Type) is
596 begin
597 Node.Key := Key;
598 Node.Element := New_Item;
599 end Assign_Key;
600
601 --------------
602 -- New_Node --
603 --------------
604
605 function New_Node return Count_Type is
606 Result : Count_Type;
607 begin
608 Allocate (Container, Result);
609 return Result;
610 end New_Node;
611
612 -- Start of processing for Insert
613
614 begin
615 Local_Insert (Container, Key, Position.Node, Inserted);
616 end Insert;
617
618 procedure Insert
619 (Container : in out Map;
620 Key : Key_Type;
621 New_Item : Element_Type)
622 is
623 Position : Cursor;
624 pragma Unreferenced (Position);
625
626 Inserted : Boolean;
627
628 begin
629 Insert (Container, Key, New_Item, Position, Inserted);
630
631 if not Inserted then
632 raise Constraint_Error with
633 "attempt to insert key already in map";
634 end if;
635 end Insert;
636
637 --------------
638 -- Is_Empty --
639 --------------
640
641 function Is_Empty (Container : Map) return Boolean is
642 begin
643 return Length (Container) = 0;
644 end Is_Empty;
645
646 ---------
647 -- Key --
648 ---------
649
650 function Key (Container : Map; Position : Cursor) return Key_Type is
651 begin
652 if not Has_Element (Container, Position) then
653 raise Constraint_Error with
654 "Position cursor of function Key has no element";
655 end if;
656
657 pragma Assert (Vet (Container, Position), "bad cursor in function Key");
658
659 return Container.Nodes (Position.Node).Key;
660 end Key;
661
662 ------------
663 -- Length --
664 ------------
665
666 function Length (Container : Map) return Count_Type is
667 begin
668 return Container.Length;
669 end Length;
670
671 ----------
672 -- Move --
673 ----------
674
675 procedure Move
676 (Target : in out Map;
677 Source : in out Map)
678 is
679 NN : HT_Types.Nodes_Type renames Source.Nodes;
680 X, Y : Count_Type;
681
682 begin
683 if Target'Address = Source'Address then
684 return;
685 end if;
686
687 if Target.Capacity < Length (Source) then
688 raise Constraint_Error with -- ???
689 "Source length exceeds Target capacity";
690 end if;
691
692 Clear (Target);
693
694 if Source.Length = 0 then
695 return;
696 end if;
697
698 X := HT_Ops.First (Source);
699 while X /= 0 loop
700 Insert (Target, NN (X).Key, NN (X).Element); -- optimize???
701
702 Y := HT_Ops.Next (Source, X);
703
704 HT_Ops.Delete_Node_Sans_Free (Source, X);
705 Free (Source, X);
706
707 X := Y;
708 end loop;
709 end Move;
710
711 ----------
712 -- Next --
713 ----------
714
715 function Next (Node : Node_Type) return Count_Type is
716 begin
717 return Node.Next;
718 end Next;
719
720 function Next (Container : Map; Position : Cursor) return Cursor is
721 begin
722 if Position.Node = 0 then
723 return No_Element;
724 end if;
725
726 if not Has_Element (Container, Position) then
727 raise Constraint_Error
728 with "Position has no element";
729 end if;
730
731 pragma Assert (Vet (Container, Position), "bad cursor in function Next");
732
733 declare
734 Node : constant Count_Type := HT_Ops.Next (Container, Position.Node);
735
736 begin
737 if Node = 0 then
738 return No_Element;
739 end if;
740
741 return (Node => Node);
742 end;
743 end Next;
744
745 procedure Next (Container : Map; Position : in out Cursor) is
746 begin
747 Position := Next (Container, Position);
748 end Next;
749
750 -------------
751 -- Overlap --
752 -------------
753
754 function Overlap (Left, Right : Map) return Boolean is
755 Left_Node : Count_Type;
756 Left_Nodes : Nodes_Type renames Left.Nodes;
757
758 begin
759 if Length (Right) = 0 or Length (Left) = 0 then
760 return False;
761 end if;
762
763 if Left'Address = Right'Address then
764 return True;
765 end if;
766
767 Left_Node := First (Left).Node;
768 while Left_Node /= 0 loop
769 declare
770 N : Node_Type renames Left_Nodes (Left_Node);
771 E : Key_Type renames N.Key;
772 begin
773 if Find (Right, E).Node /= 0 then
774 return True;
775 end if;
776 end;
777
778 Left_Node := HT_Ops.Next (Left, Left_Node);
779 end loop;
780
781 return False;
782 end Overlap;
783
784 -------------
785 -- Replace --
786 -------------
787
788 procedure Replace
789 (Container : in out Map;
790 Key : Key_Type;
791 New_Item : Element_Type)
792 is
793 Node : constant Count_Type := Key_Ops.Find (Container, Key);
794
795 begin
796 if Node = 0 then
797 raise Constraint_Error with
798 "attempt to replace key not in map";
799 end if;
800
801 declare
802 N : Node_Type renames Container.Nodes (Node);
803 begin
804 N.Key := Key;
805 N.Element := New_Item;
806 end;
807 end Replace;
808
809 ---------------------
810 -- Replace_Element --
811 ---------------------
812
813 procedure Replace_Element
814 (Container : in out Map;
815 Position : Cursor;
816 New_Item : Element_Type)
817 is
818 begin
819 if not Has_Element (Container, Position) then
820 raise Constraint_Error with
821 "Position cursor of Replace_Element has no element";
822 end if;
823
824 pragma Assert (Vet (Container, Position),
825 "bad cursor in Replace_Element");
826
827 Container.Nodes (Position.Node).Element := New_Item;
828 end Replace_Element;
829
830 ----------------------
831 -- Reserve_Capacity --
832 ----------------------
833
834 procedure Reserve_Capacity
835 (Container : in out Map;
836 Capacity : Count_Type)
837 is
838 begin
839 if Capacity > Container.Capacity then
840 raise Capacity_Error with "requested capacity is too large";
841 end if;
842 end Reserve_Capacity;
843
844 --------------
845 -- Set_Next --
846 --------------
847
848 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
849 begin
850 Node.Next := Next;
851 end Set_Next;
852
853 ------------------
854 -- Strict_Equal --
855 ------------------
856
857 function Strict_Equal (Left, Right : Map) return Boolean is
858 CuL : Cursor := First (Left);
859 CuR : Cursor := First (Right);
860
861 begin
862 if Length (Left) /= Length (Right) then
863 return False;
864 end if;
865
866 while CuL.Node /= 0 or else CuR.Node /= 0 loop
867 if CuL.Node /= CuR.Node
868 or else
869 Left.Nodes (CuL.Node).Element /= Right.Nodes (CuR.Node).Element
870 or else Left.Nodes (CuL.Node).Key /= Right.Nodes (CuR.Node).Key
871 then
872 return False;
873 end if;
874
875 CuL := Next (Left, CuL);
876 CuR := Next (Right, CuR);
877 end loop;
878
879 return True;
880 end Strict_Equal;
881
882 ---------
883 -- Vet --
884 ---------
885
886 function Vet (Container : Map; Position : Cursor) return Boolean is
887 begin
888 if Position.Node = 0 then
889 return True;
890 end if;
891
892 declare
893 X : Count_Type;
894
895 begin
896 if Container.Length = 0 then
897 return False;
898 end if;
899
900 if Container.Capacity = 0 then
901 return False;
902 end if;
903
904 if Container.Buckets'Length = 0 then
905 return False;
906 end if;
907
908 if Position.Node > Container.Capacity then
909 return False;
910 end if;
911
912 if Container.Nodes (Position.Node).Next = Position.Node then
913 return False;
914 end if;
915
916 X := Container.Buckets
917 (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key));
918
919 for J in 1 .. Container.Length loop
920 if X = Position.Node then
921 return True;
922 end if;
923
924 if X = 0 then
925 return False;
926 end if;
927
928 if X = Container.Nodes (X).Next then
929
930 -- Prevent unnecessary looping
931
932 return False;
933 end if;
934
935 X := Container.Nodes (X).Next;
936 end loop;
937
938 return False;
939 end;
940 end Vet;
941
942 end Ada.Containers.Formal_Hashed_Maps;