1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS -- 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-- 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 30package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is 31 32 pragma Warnings (Off, "variable ""Busy*"" is not referenced"); 33 pragma Warnings (Off, "variable ""Lock*"" is not referenced"); 34 -- See comment in Ada.Containers.Helpers 35 36 ----------------------------- 37 -- Checked_Equivalent_Keys -- 38 ----------------------------- 39 40 function Checked_Equivalent_Keys 41 (HT : aliased in out Hash_Table_Type'Class; 42 Key : Key_Type; 43 Node : Count_Type) return Boolean 44 is 45 Lock : With_Lock (HT.TC'Unrestricted_Access); 46 begin 47 return Equivalent_Keys (Key, HT.Nodes (Node)); 48 end Checked_Equivalent_Keys; 49 50 ------------------- 51 -- Checked_Index -- 52 ------------------- 53 54 function Checked_Index 55 (HT : aliased in out Hash_Table_Type'Class; 56 Key : Key_Type) return Hash_Type 57 is 58 Lock : With_Lock (HT.TC'Unrestricted_Access); 59 begin 60 return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; 61 end Checked_Index; 62 63 -------------------------- 64 -- Delete_Key_Sans_Free -- 65 -------------------------- 66 67 procedure Delete_Key_Sans_Free 68 (HT : in out Hash_Table_Type'Class; 69 Key : Key_Type; 70 X : out Count_Type) 71 is 72 Indx : Hash_Type; 73 Prev : Count_Type; 74 75 begin 76 if HT.Length = 0 then 77 X := 0; 78 return; 79 end if; 80 81 -- Per AI05-0022, the container implementation is required to detect 82 -- element tampering by a generic actual subprogram. 83 84 TC_Check (HT.TC); 85 86 Indx := Checked_Index (HT, Key); 87 X := HT.Buckets (Indx); 88 89 if X = 0 then 90 return; 91 end if; 92 93 if Checked_Equivalent_Keys (HT, Key, X) then 94 TC_Check (HT.TC); 95 HT.Buckets (Indx) := Next (HT.Nodes (X)); 96 HT.Length := HT.Length - 1; 97 return; 98 end if; 99 100 loop 101 Prev := X; 102 X := Next (HT.Nodes (Prev)); 103 104 if X = 0 then 105 return; 106 end if; 107 108 if Checked_Equivalent_Keys (HT, Key, X) then 109 TC_Check (HT.TC); 110 Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X))); 111 HT.Length := HT.Length - 1; 112 return; 113 end if; 114 end loop; 115 end Delete_Key_Sans_Free; 116 117 ---------- 118 -- Find -- 119 ---------- 120 121 function Find 122 (HT : Hash_Table_Type'Class; 123 Key : Key_Type) return Count_Type 124 is 125 Indx : Hash_Type; 126 Node : Count_Type; 127 128 begin 129 if HT.Length = 0 then 130 return 0; 131 end if; 132 133 Indx := Checked_Index (HT'Unrestricted_Access.all, Key); 134 135 Node := HT.Buckets (Indx); 136 while Node /= 0 loop 137 if Checked_Equivalent_Keys 138 (HT'Unrestricted_Access.all, Key, Node) 139 then 140 return Node; 141 end if; 142 Node := Next (HT.Nodes (Node)); 143 end loop; 144 145 return 0; 146 end Find; 147 148 -------------------------------- 149 -- Generic_Conditional_Insert -- 150 -------------------------------- 151 152 procedure Generic_Conditional_Insert 153 (HT : in out Hash_Table_Type'Class; 154 Key : Key_Type; 155 Node : out Count_Type; 156 Inserted : out Boolean) 157 is 158 Indx : Hash_Type; 159 160 begin 161 -- Per AI05-0022, the container implementation is required to detect 162 -- element tampering by a generic actual subprogram. 163 164 TC_Check (HT.TC); 165 166 Indx := Checked_Index (HT, Key); 167 Node := HT.Buckets (Indx); 168 169 if Node = 0 then 170 if Checks and then HT.Length = HT.Capacity then 171 raise Capacity_Error with "no more capacity for insertion"; 172 end if; 173 174 Node := New_Node; 175 Set_Next (HT.Nodes (Node), Next => 0); 176 177 Inserted := True; 178 179 HT.Buckets (Indx) := Node; 180 HT.Length := HT.Length + 1; 181 182 return; 183 end if; 184 185 loop 186 if Checked_Equivalent_Keys (HT, Key, Node) then 187 Inserted := False; 188 return; 189 end if; 190 191 Node := Next (HT.Nodes (Node)); 192 193 exit when Node = 0; 194 end loop; 195 196 if Checks and then HT.Length = HT.Capacity then 197 raise Capacity_Error with "no more capacity for insertion"; 198 end if; 199 200 Node := New_Node; 201 Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx)); 202 203 Inserted := True; 204 205 HT.Buckets (Indx) := Node; 206 HT.Length := HT.Length + 1; 207 end Generic_Conditional_Insert; 208 209 ----------------------------- 210 -- Generic_Replace_Element -- 211 ----------------------------- 212 213 procedure Generic_Replace_Element 214 (HT : in out Hash_Table_Type'Class; 215 Node : Count_Type; 216 Key : Key_Type) 217 is 218 pragma Assert (HT.Length > 0); 219 pragma Assert (Node /= 0); 220 221 BB : Buckets_Type renames HT.Buckets; 222 NN : Nodes_Type renames HT.Nodes; 223 224 Old_Indx : Hash_Type; 225 New_Indx : constant Hash_Type := Checked_Index (HT, Key); 226 227 New_Bucket : Count_Type renames BB (New_Indx); 228 N, M : Count_Type; 229 230 begin 231 -- Per AI05-0022, the container implementation is required to detect 232 -- element tampering by a generic actual subprogram. 233 234 -- The following block appears to be vestigial -- this should be done 235 -- using Checked_Index instead. Also, we might have to move the actual 236 -- tampering checks to the top of the subprogram, in order to prevent 237 -- infinite recursion when calling Hash. (This is similar to how Insert 238 -- and Delete are implemented.) This implies that we will have to defer 239 -- the computation of New_Index until after the tampering check. ??? 240 241 declare 242 Lock : With_Lock (HT.TC'Unrestricted_Access); 243 begin 244 Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length; 245 end; 246 247 -- Replace_Element is allowed to change a node's key to Key 248 -- (generic formal operation Assign provides the mechanism), but 249 -- only if Key is not already in the hash table. (In a unique-key 250 -- hash table as this one, a key is mapped to exactly one node.) 251 252 if Checked_Equivalent_Keys (HT, Key, Node) then 253 TE_Check (HT.TC); 254 255 -- The new Key value is mapped to this same Node, so Node 256 -- stays in the same bucket. 257 258 Assign (NN (Node), Key); 259 return; 260 end if; 261 262 -- Key is not equivalent to Node, so we now have to determine if it's 263 -- equivalent to some other node in the hash table. This is the case 264 -- irrespective of whether Key is in the same or a different bucket from 265 -- Node. 266 267 N := New_Bucket; 268 while N /= 0 loop 269 if Checks and then Checked_Equivalent_Keys (HT, Key, N) then 270 pragma Assert (N /= Node); 271 raise Program_Error with 272 "attempt to replace existing element"; 273 end if; 274 275 N := Next (NN (N)); 276 end loop; 277 278 -- We have determined that Key is not already in the hash table, so 279 -- the change is tentatively allowed. We now perform the standard 280 -- checks to determine whether the hash table is locked (because you 281 -- cannot change an element while it's in use by Query_Element or 282 -- Update_Element), or if the container is busy (because moving a 283 -- node to a different bucket would interfere with iteration). 284 285 if Old_Indx = New_Indx then 286 -- The node is already in the bucket implied by Key. In this case 287 -- we merely change its value without moving it. 288 289 TE_Check (HT.TC); 290 291 Assign (NN (Node), Key); 292 return; 293 end if; 294 295 -- The node is a bucket different from the bucket implied by Key 296 297 TC_Check (HT.TC); 298 299 -- Do the assignment first, before moving the node, so that if Assign 300 -- propagates an exception, then the hash table will not have been 301 -- modified (except for any possible side-effect Assign had on Node). 302 303 Assign (NN (Node), Key); 304 305 -- Now we can safely remove the node from its current bucket 306 307 N := BB (Old_Indx); -- get value of first node in old bucket 308 pragma Assert (N /= 0); 309 310 if N = Node then -- node is first node in its bucket 311 BB (Old_Indx) := Next (NN (Node)); 312 313 else 314 pragma Assert (HT.Length > 1); 315 316 loop 317 M := Next (NN (N)); 318 pragma Assert (M /= 0); 319 320 if M = Node then 321 Set_Next (NN (N), Next => Next (NN (Node))); 322 exit; 323 end if; 324 325 N := M; 326 end loop; 327 end if; 328 329 -- Now we link the node into its new bucket (corresponding to Key) 330 331 Set_Next (NN (Node), Next => New_Bucket); 332 New_Bucket := Node; 333 end Generic_Replace_Element; 334 335 ----------- 336 -- Index -- 337 ----------- 338 339 function Index 340 (HT : Hash_Table_Type'Class; 341 Key : Key_Type) return Hash_Type is 342 begin 343 return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; 344 end Index; 345 346end Ada.Containers.Hash_Tables.Generic_Bounded_Keys; 347