1--  Copyright 1994 Grady Booch
2--  Copyright 1998-2014 Simon Wright <simon@pushface.org>
3
4--  This package is free software; you can redistribute it and/or
5--  modify it under terms of the GNU General Public License as
6--  published by the Free Software Foundation; either version 2, or
7--  (at your option) any later version. This package is distributed in
8--  the hope that it will be useful, but WITHOUT ANY WARRANTY; without
9--  even the implied warranty of MERCHANTABILITY or FITNESS FOR A
10--  PARTICULAR PURPOSE. See the GNU General Public License for more
11--  details. You should have received a copy of the GNU General Public
12--  License distributed with this package; see file COPYING.  If not,
13--  write to the Free Software Foundation, 59 Temple Place - Suite
14--  330, Boston, MA 02111-1307, USA.
15
16--  As a special exception, if other files instantiate generics from
17--  this unit, or you link this unit with other files to produce an
18--  executable, this unit does not by itself cause the resulting
19--  executable to be covered by the GNU General Public License.  This
20--  exception does not however invalidate any other reasons why the
21--  executable file might be covered by the GNU Public License.
22
23package body BC.Support.Hash_Tables is
24
25   package body Tables is
26
27
28      pragma Warnings
29        (Off, "abstract subprogram is not dispatching or overriding*");
30      pragma Warnings (Off, "function ""="" is not referenced");
31      function "=" (L, R : Items.Item) return Boolean is abstract;
32      --  Make sure we don't use any old equality.
33      pragma Warnings
34        (On, "abstract subprogram is not dispatching or overriding*");
35      pragma Warnings (On, "function ""="" is not referenced");
36
37
38      function "=" (L, R : Table) return Boolean is
39      begin
40         --  optimisation if L, R are the same Table?
41         if L.Size = R.Size then
42            for B in 1 .. L.Number_Of_Buckets loop
43               for Index in 1 .. Items.Length (L.Items (B)) loop
44                  declare
45                     This_Item : Items.Item renames
46                       Items.Item_At (L.Items (B), Index);
47                  begin
48                     if not Is_Bound (R, This_Item)
49                       or else not Values.Eq
50                                    (Values.Item_At (L.Values (B), Index),
51                                     Value_Of (R, This_Item))
52                     then
53                        return False;
54                     end if;
55                  end;
56               end loop;
57            end loop;
58            return True;
59         else
60            return False;
61         end if;
62      end "=";
63
64
65      procedure Clear (T : in out Table) is
66      begin
67         for B in 1 .. T.Number_Of_Buckets loop
68            Items.Clear (T.Items (B));
69            Values.Clear (T.Values (B));
70            T.Size := 0;
71         end loop;
72      end Clear;
73
74
75      procedure Bind (T : in out Table; I : Items.Item; V : Values.Value) is
76         Bucket : constant Positive
77           := (Items.Hash (I) mod T.Number_Of_Buckets) + 1;
78      begin
79         if Items.Location (T.Items (Bucket), I, 1) /= 0 then
80            raise BC.Duplicate;
81         end if;
82         Items.Insert (T.Items (Bucket), I);
83         Values.Insert (T.Values (Bucket), V);
84         T.Size := T.Size + 1;
85      end Bind;
86
87
88      procedure Rebind (T : in out Table; I : Items.Item; V : Values.Value) is
89         Bucket : constant Positive
90           := (Items.Hash (I) mod T.Number_Of_Buckets) + 1;
91         Index : constant Natural := Items.Location (T.Items (Bucket), I, 1);
92      begin
93         if Index = 0 then
94            raise BC.Not_Found;
95         end if;
96         Values.Replace (T.Values (Bucket), Index, V);
97      end Rebind;
98
99
100      procedure Unbind (T : in out Table; I : Items.Item) is
101         Bucket : constant Positive
102           := (Items.Hash (I) mod T.Number_Of_Buckets) + 1;
103         Index : constant Natural := Items.Location (T.Items (Bucket), I, 1);
104      begin
105         if Index = 0 then
106            raise BC.Not_Found;
107         end if;
108         Items.Remove (T.Items (Bucket), Index);
109         Values.Remove (T.Values (Bucket), Index);
110         T.Size := T.Size - 1;
111      end Unbind;
112
113
114      function Extent (T : Table) return Natural is
115      begin
116         return T.Size;
117      end Extent;
118
119
120      function Is_Bound (T : Table; I : Items.Item) return Boolean is
121         Bucket : constant Positive
122           := (Items.Hash (I) mod T.Number_Of_Buckets) + 1;
123      begin
124         return Items.Location (T.Items (Bucket), I, 1) /= 0;
125      end Is_Bound;
126
127
128      function Value_Of (T : Table; I : Items.Item) return Values.Value is
129         Bucket : constant Positive
130           := (Items.Hash (I) mod T.Number_Of_Buckets) + 1;
131         Index : constant Natural := Items.Location (T.Items (Bucket), I, 1);
132      begin
133         if Index = 0 then
134            raise BC.Not_Found;
135         end if;
136         return Values.Item_At (T.Values (Bucket), Index);
137      end Value_Of;
138
139
140      procedure Reset (T : Table;
141                       Bucket : out Positive;
142                       Index : out Positive) is
143      begin
144         if T.Size = 0 then
145            Bucket := T.Number_Of_Buckets + 1;
146            Index := Positive'Last;         --  we have to ensure it's > 0
147         else
148            Bucket := 1;
149            loop
150               exit when Bucket > T.Number_Of_Buckets;
151               if Items.Length (T.Items (Bucket)) > 0 then
152                  Index := 1;
153                  return;
154               end if;
155               Bucket := Bucket + 1;
156            end loop;
157            raise Hash_Table_Error;
158         end if;
159      end Reset;
160
161
162      function Is_Done (T : Table;
163                        Bucket : Positive;
164                        Index : Positive) return Boolean is
165         pragma Warnings (Off, Index);
166      begin
167         return Bucket > T.Number_Of_Buckets;
168      end Is_Done;
169
170
171      function Current_Item_Ptr (T : Table;
172                                 Bucket : Positive;
173                                 Index : Positive) return Items.Item_Ptr is
174      begin
175         if Bucket > T.Number_Of_Buckets then
176            raise BC.Not_Found;
177         end if;
178         return Items.Access_Item_At (T.Items (Bucket), Index);
179      end Current_Item_Ptr;
180
181
182      function Current_Value_Ptr (T : Table;
183                                  Bucket : Positive;
184                                  Index : Positive) return Values.Value_Ptr is
185      begin
186         if Bucket > T.Number_Of_Buckets then
187            raise BC.Not_Found;
188         end if;
189         return Values.Access_Item_At (T.Values (Bucket), Index);
190      end Current_Value_Ptr;
191
192
193      procedure Delete_Item_At (T : in out Table;
194                                Bucket : in out Positive;
195                                Index : in out  Positive) is
196      begin
197         if Bucket > T.Number_Of_Buckets then
198            raise BC.Not_Found;
199         end if;
200         Items.Remove (T.Items (Bucket), Index);
201         Values.Remove (T.Values (Bucket), Index);
202         if Index > Items.Length (T.Items (Bucket)) then
203            loop
204               Bucket := Bucket + 1;
205               exit when Bucket > T.Number_Of_Buckets;
206               if Items.Length (T.Items (Bucket)) > 0 then
207                  Index := 1;
208                  exit;
209               end if;
210            end loop;
211         end if;
212         T.Size := T.Size - 1;
213      end Delete_Item_At;
214
215
216      procedure Next (T : Table;
217                      Bucket : in out Positive;
218                      Index : in out  Positive) is
219      begin
220         if Bucket > T.Number_Of_Buckets then
221            raise BC.Not_Found;
222         end if;
223         if Items.Length (T.Items (Bucket)) > Index then
224            Index := Index + 1;
225         else
226            loop
227               Bucket := Bucket + 1;
228               exit when Bucket > T.Number_Of_Buckets;
229               if Items.Length (T.Items (Bucket)) > 0 then
230                  Index := 1;
231                  exit;
232               end if;
233            end loop;
234         end if;
235      end Next;
236
237
238   end Tables;
239
240
241end BC.Support.Hash_Tables;
242