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