1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT LIBRARY COMPONENTS                          --
4--                                                                          --
5--           ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS          --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2004-2018, Free Software Foundation, Inc.         --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- This unit was originally developed by Matthew J Heaney.                  --
28------------------------------------------------------------------------------
29
30with System; use type System.Address;
31
32package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
33
34   pragma Warnings (Off, "variable ""Busy*"" is not referenced");
35   pragma Warnings (Off, "variable ""Lock*"" is not referenced");
36   --  See comment in Ada.Containers.Helpers
37
38   -------------------
39   -- Checked_Index --
40   -------------------
41
42   function Checked_Index
43     (Hash_Table : aliased in out Hash_Table_Type'Class;
44      Node       : Count_Type) return Hash_Type
45   is
46      Lock : With_Lock (Hash_Table.TC'Unrestricted_Access);
47   begin
48      return Index (Hash_Table, Hash_Table.Nodes (Node));
49   end Checked_Index;
50
51   -----------
52   -- Clear --
53   -----------
54
55   procedure Clear (HT : in out Hash_Table_Type'Class) is
56   begin
57      TC_Check (HT.TC);
58
59      HT.Length := 0;
60      --  HT.Busy := 0;
61      --  HT.Lock := 0;
62      HT.Free := -1;
63      HT.Buckets := (others => 0);  -- optimize this somehow ???
64   end Clear;
65
66   --------------------------
67   -- Delete_Node_At_Index --
68   --------------------------
69
70   procedure Delete_Node_At_Index
71     (HT   : in out Hash_Table_Type'Class;
72      Indx : Hash_Type;
73      X    : Count_Type)
74   is
75      Prev : Count_Type;
76      Curr : Count_Type;
77
78   begin
79      Prev := HT.Buckets (Indx);
80
81      if Checks and then Prev = 0 then
82         raise Program_Error with
83           "attempt to delete node from empty hash bucket";
84      end if;
85
86      if Prev = X then
87         HT.Buckets (Indx) := Next (HT.Nodes (Prev));
88         HT.Length := HT.Length - 1;
89         return;
90      end if;
91
92      if Checks and then HT.Length = 1 then
93         raise Program_Error with
94           "attempt to delete node not in its proper hash bucket";
95      end if;
96
97      loop
98         Curr := Next (HT.Nodes (Prev));
99
100         if Checks and then Curr = 0 then
101            raise Program_Error with
102              "attempt to delete node not in its proper hash bucket";
103         end if;
104
105         Prev := Curr;
106      end loop;
107   end Delete_Node_At_Index;
108
109   ---------------------------
110   -- Delete_Node_Sans_Free --
111   ---------------------------
112
113   procedure Delete_Node_Sans_Free
114     (HT : in out Hash_Table_Type'Class;
115      X  : Count_Type)
116   is
117      pragma Assert (X /= 0);
118
119      Indx : Hash_Type;
120      Prev : Count_Type;
121      Curr : Count_Type;
122
123   begin
124      if Checks and then HT.Length = 0 then
125         raise Program_Error with
126           "attempt to delete node from empty hashed container";
127      end if;
128
129      Indx := Checked_Index (HT, X);
130      Prev := HT.Buckets (Indx);
131
132      if Checks and then Prev = 0 then
133         raise Program_Error with
134           "attempt to delete node from empty hash bucket";
135      end if;
136
137      if Prev = X then
138         HT.Buckets (Indx) := Next (HT.Nodes (Prev));
139         HT.Length := HT.Length - 1;
140         return;
141      end if;
142
143      if Checks and then HT.Length = 1 then
144         raise Program_Error with
145           "attempt to delete node not in its proper hash bucket";
146      end if;
147
148      loop
149         Curr := Next (HT.Nodes (Prev));
150
151         if Checks and then Curr = 0 then
152            raise Program_Error with
153              "attempt to delete node not in its proper hash bucket";
154         end if;
155
156         if Curr = X then
157            Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr)));
158            HT.Length := HT.Length - 1;
159            return;
160         end if;
161
162         Prev := Curr;
163      end loop;
164   end Delete_Node_Sans_Free;
165
166   -----------
167   -- First --
168   -----------
169
170   function First (HT : Hash_Table_Type'Class) return Count_Type is
171      Indx : Hash_Type;
172
173   begin
174      if HT.Length = 0 then
175         return 0;
176      end if;
177
178      Indx := HT.Buckets'First;
179      loop
180         if HT.Buckets (Indx) /= 0 then
181            return HT.Buckets (Indx);
182         end if;
183
184         Indx := Indx + 1;
185      end loop;
186   end First;
187
188   ----------
189   -- Free --
190   ----------
191
192   procedure Free
193     (HT : in out Hash_Table_Type'Class;
194      X  : Count_Type)
195   is
196      N : Nodes_Type renames HT.Nodes;
197
198   begin
199      --  This subprogram "deallocates" a node by relinking the node off of the
200      --  active list and onto the free list. Previously it would flag index
201      --  value 0 as an error. The precondition was weakened, so that index
202      --  value 0 is now allowed, and this value is interpreted to mean "do
203      --  nothing". This makes its behavior analogous to the behavior of
204      --  Ada.Unchecked_Deallocation, and allows callers to avoid having to add
205      --  special-case checks at the point of call.
206
207      if X = 0 then
208         return;
209      end if;
210
211      pragma Assert (X <= HT.Capacity);
212
213      --  pragma Assert (N (X).Prev >= 0);  -- node is active
214      --  Find a way to mark a node as active vs. inactive; we could
215      --  use a special value in Color_Type for this.  ???
216
217      --  The hash table actually contains two data structures: a list for
218      --  the "active" nodes that contain elements that have been inserted
219      --  onto the container, and another for the "inactive" nodes of the free
220      --  store.
221      --
222      --  We desire that merely declaring an object should have only minimal
223      --  cost; specially, we want to avoid having to initialize the free
224      --  store (to fill in the links), especially if the capacity is large.
225      --
226      --  The head of the free list is indicated by Container.Free. If its
227      --  value is non-negative, then the free store has been initialized
228      --  in the "normal" way: Container.Free points to the head of the list
229      --  of free (inactive) nodes, and the value 0 means the free list is
230      --  empty. Each node on the free list has been initialized to point
231      --  to the next free node (via its Parent component), and the value 0
232      --  means that this is the last free node.
233      --
234      --  If Container.Free is negative, then the links on the free store
235      --  have not been initialized. In this case the link values are
236      --  implied: the free store comprises the components of the node array
237      --  started with the absolute value of Container.Free, and continuing
238      --  until the end of the array (Nodes'Last).
239      --
240      --  ???
241      --  It might be possible to perform an optimization here. Suppose that
242      --  the free store can be represented as having two parts: one
243      --  comprising the non-contiguous inactive nodes linked together
244      --  in the normal way, and the other comprising the contiguous
245      --  inactive nodes (that are not linked together, at the end of the
246      --  nodes array). This would allow us to never have to initialize
247      --  the free store, except in a lazy way as nodes become inactive.
248
249      --  When an element is deleted from the list container, its node
250      --  becomes inactive, and so we set its Next component to value of
251      --  the node's index (in the nodes array), to indicate that it is
252      --  now inactive. This provides a useful way to detect a dangling
253      --  cursor reference.  ???
254
255      Set_Next (N (X), Next => X);  -- Node is deallocated (not on active list)
256
257      if HT.Free >= 0 then
258         --  The free store has previously been initialized. All we need to
259         --  do here is link the newly-free'd node onto the free list.
260
261         Set_Next (N (X), HT.Free);
262         HT.Free := X;
263
264      elsif X + 1 = abs HT.Free then
265         --  The free store has not been initialized, and the node becoming
266         --  inactive immediately precedes the start of the free store. All
267         --  we need to do is move the start of the free store back by one.
268
269         HT.Free := HT.Free + 1;
270
271      else
272         --  The free store has not been initialized, and the node becoming
273         --  inactive does not immediately precede the free store. Here we
274         --  first initialize the free store (meaning the links are given
275         --  values in the traditional way), and then link the newly-free'd
276         --  node onto the head of the free store.
277
278         --  ???
279         --  See the comments above for an optimization opportunity. If
280         --  the next link for a node on the free store is negative, then
281         --  this means the remaining nodes on the free store are
282         --  physically contiguous, starting as the absolute value of
283         --  that index value.
284
285         HT.Free := abs HT.Free;
286
287         if HT.Free > HT.Capacity then
288            HT.Free := 0;
289
290         else
291            for I in HT.Free .. HT.Capacity - 1 loop
292               Set_Next (Node => N (I), Next => I + 1);
293            end loop;
294
295            Set_Next (Node => N (HT.Capacity), Next => 0);
296         end if;
297
298         Set_Next (Node => N (X), Next => HT.Free);
299         HT.Free := X;
300      end if;
301   end Free;
302
303   ----------------------
304   -- Generic_Allocate --
305   ----------------------
306
307   procedure Generic_Allocate
308     (HT   : in out Hash_Table_Type'Class;
309      Node : out Count_Type)
310   is
311      N : Nodes_Type renames HT.Nodes;
312
313   begin
314      if HT.Free >= 0 then
315         Node := HT.Free;
316
317         --  We always perform the assignment first, before we
318         --  change container state, in order to defend against
319         --  exceptions duration assignment.
320
321         Set_Element (N (Node));
322         HT.Free := Next (N (Node));
323
324      else
325         --  A negative free store value means that the links of the nodes
326         --  in the free store have not been initialized. In this case, the
327         --  nodes are physically contiguous in the array, starting at the
328         --  index that is the absolute value of the Container.Free, and
329         --  continuing until the end of the array (Nodes'Last).
330
331         Node := abs HT.Free;
332
333         --  As above, we perform this assignment first, before modifying
334         --  any container state.
335
336         Set_Element (N (Node));
337         HT.Free := HT.Free - 1;
338      end if;
339   end Generic_Allocate;
340
341   -------------------
342   -- Generic_Equal --
343   -------------------
344
345   function Generic_Equal
346     (L, R : Hash_Table_Type'Class) return Boolean
347   is
348      --  Per AI05-0022, the container implementation is required to detect
349      --  element tampering by a generic actual subprogram.
350
351      Lock_L : With_Lock (L.TC'Unrestricted_Access);
352      Lock_R : With_Lock (R.TC'Unrestricted_Access);
353
354      L_Index : Hash_Type;
355      L_Node  : Count_Type;
356
357      N : Count_Type;
358
359   begin
360      if L'Address = R'Address then
361         return True;
362      end if;
363
364      if L.Length /= R.Length then
365         return False;
366      end if;
367
368      if L.Length = 0 then
369         return True;
370      end if;
371
372      --  Find the first node of hash table L
373
374      L_Index := L.Buckets'First;
375      loop
376         L_Node := L.Buckets (L_Index);
377         exit when L_Node /= 0;
378         L_Index := L_Index + 1;
379      end loop;
380
381      --  For each node of hash table L, search for an equivalent node in hash
382      --  table R.
383
384      N := L.Length;
385      loop
386         if not Find (HT => R, Key => L.Nodes (L_Node)) then
387            return False;
388         end if;
389
390         N := N - 1;
391
392         L_Node := Next (L.Nodes (L_Node));
393
394         if L_Node = 0 then
395
396            --  We have exhausted the nodes in this bucket
397
398            if N = 0 then
399               return True;
400            end if;
401
402            --  Find the next bucket
403
404            loop
405               L_Index := L_Index + 1;
406               L_Node := L.Buckets (L_Index);
407               exit when L_Node /= 0;
408            end loop;
409         end if;
410      end loop;
411   end Generic_Equal;
412
413   -----------------------
414   -- Generic_Iteration --
415   -----------------------
416
417   procedure Generic_Iteration (HT : Hash_Table_Type'Class) is
418      Node : Count_Type;
419
420   begin
421      if HT.Length = 0 then
422         return;
423      end if;
424
425      for Indx in HT.Buckets'Range loop
426         Node := HT.Buckets (Indx);
427         while Node /= 0 loop
428            Process (Node);
429            Node := Next (HT.Nodes (Node));
430         end loop;
431      end loop;
432   end Generic_Iteration;
433
434   ------------------
435   -- Generic_Read --
436   ------------------
437
438   procedure Generic_Read
439     (Stream : not null access Root_Stream_Type'Class;
440      HT     : out Hash_Table_Type'Class)
441   is
442      N  : Count_Type'Base;
443
444   begin
445      Clear (HT);
446
447      Count_Type'Base'Read (Stream, N);
448
449      if Checks and then N < 0 then
450         raise Program_Error with "stream appears to be corrupt";
451      end if;
452
453      if N = 0 then
454         return;
455      end if;
456
457      if Checks and then N > HT.Capacity then
458         raise Capacity_Error with "too many elements in stream";
459      end if;
460
461      for J in 1 .. N loop
462         declare
463            Node : constant Count_Type := New_Node (Stream);
464            Indx : constant Hash_Type := Checked_Index (HT, Node);
465            B    : Count_Type renames HT.Buckets (Indx);
466         begin
467            Set_Next (HT.Nodes (Node), Next => B);
468            B := Node;
469         end;
470
471         HT.Length := HT.Length + 1;
472      end loop;
473   end Generic_Read;
474
475   -------------------
476   -- Generic_Write --
477   -------------------
478
479   procedure Generic_Write
480     (Stream : not null access Root_Stream_Type'Class;
481      HT     : Hash_Table_Type'Class)
482   is
483      procedure Write (Node : Count_Type);
484      pragma Inline (Write);
485
486      procedure Write is new Generic_Iteration (Write);
487
488      -----------
489      -- Write --
490      -----------
491
492      procedure Write (Node : Count_Type) is
493      begin
494         Write (Stream, HT.Nodes (Node));
495      end Write;
496
497   begin
498      Count_Type'Base'Write (Stream, HT.Length);
499      Write (HT);
500   end Generic_Write;
501
502   -----------
503   -- Index --
504   -----------
505
506   function Index
507     (Buckets : Buckets_Type;
508      Node    : Node_Type) return Hash_Type is
509   begin
510      return Buckets'First + Hash_Node (Node) mod Buckets'Length;
511   end Index;
512
513   function Index
514     (HT   : Hash_Table_Type'Class;
515      Node : Node_Type) return Hash_Type is
516   begin
517      return Index (HT.Buckets, Node);
518   end Index;
519
520   ----------
521   -- Next --
522   ----------
523
524   function Next
525     (HT   : Hash_Table_Type'Class;
526      Node : Count_Type) return Count_Type
527   is
528      Result : Count_Type;
529      First  : Hash_Type;
530
531   begin
532      Result := Next (HT.Nodes (Node));
533
534      if Result /= 0 then  -- another node in same bucket
535         return Result;
536      end if;
537
538      --  This was the last node in the bucket, so move to the next
539      --  bucket, and start searching for next node from there.
540
541      First := Checked_Index (HT'Unrestricted_Access.all, Node) + 1;
542      for Indx in First .. HT.Buckets'Last loop
543         Result := HT.Buckets (Indx);
544
545         if Result /= 0 then  -- bucket is not empty
546            return Result;
547         end if;
548      end loop;
549
550      return 0;
551   end Next;
552
553end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;
554