1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-2010, 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_Keys is 31 32 -------------------------- 33 -- Delete_Key_Sans_Free -- 34 -------------------------- 35 36 procedure Delete_Key_Sans_Free 37 (HT : in out Hash_Table_Type; 38 Key : Key_Type; 39 X : out Node_Access) 40 is 41 Indx : Hash_Type; 42 Prev : Node_Access; 43 44 begin 45 if HT.Length = 0 then 46 X := null; 47 return; 48 end if; 49 50 Indx := Index (HT, Key); 51 X := HT.Buckets (Indx); 52 53 if X = null then 54 return; 55 end if; 56 57 if Equivalent_Keys (Key, X) then 58 if HT.Busy > 0 then 59 raise Program_Error with 60 "attempt to tamper with cursors (container is busy)"; 61 end if; 62 HT.Buckets (Indx) := Next (X); 63 HT.Length := HT.Length - 1; 64 return; 65 end if; 66 67 loop 68 Prev := X; 69 X := Next (Prev); 70 71 if X = null then 72 return; 73 end if; 74 75 if Equivalent_Keys (Key, X) then 76 if HT.Busy > 0 then 77 raise Program_Error with 78 "attempt to tamper with cursors (container is busy)"; 79 end if; 80 Set_Next (Node => Prev, Next => Next (X)); 81 HT.Length := HT.Length - 1; 82 return; 83 end if; 84 end loop; 85 end Delete_Key_Sans_Free; 86 87 ---------- 88 -- Find -- 89 ---------- 90 91 function Find 92 (HT : Hash_Table_Type; 93 Key : Key_Type) return Node_Access is 94 95 Indx : Hash_Type; 96 Node : Node_Access; 97 98 begin 99 if HT.Length = 0 then 100 return null; 101 end if; 102 103 Indx := Index (HT, Key); 104 105 Node := HT.Buckets (Indx); 106 while Node /= null loop 107 if Equivalent_Keys (Key, Node) then 108 return Node; 109 end if; 110 Node := Next (Node); 111 end loop; 112 113 return null; 114 end Find; 115 116 -------------------------------- 117 -- Generic_Conditional_Insert -- 118 -------------------------------- 119 120 procedure Generic_Conditional_Insert 121 (HT : in out Hash_Table_Type; 122 Key : Key_Type; 123 Node : out Node_Access; 124 Inserted : out Boolean) 125 is 126 Indx : constant Hash_Type := Index (HT, Key); 127 B : Node_Access renames HT.Buckets (Indx); 128 129 begin 130 if B = null then 131 if HT.Busy > 0 then 132 raise Program_Error with 133 "attempt to tamper with cursors (container is busy)"; 134 end if; 135 136 if HT.Length = Count_Type'Last then 137 raise Constraint_Error; 138 end if; 139 140 Node := New_Node (Next => null); 141 Inserted := True; 142 143 B := Node; 144 HT.Length := HT.Length + 1; 145 146 return; 147 end if; 148 149 Node := B; 150 loop 151 if Equivalent_Keys (Key, Node) then 152 Inserted := False; 153 return; 154 end if; 155 156 Node := Next (Node); 157 158 exit when Node = null; 159 end loop; 160 161 if HT.Busy > 0 then 162 raise Program_Error with 163 "attempt to tamper with cursors (container is busy)"; 164 end if; 165 166 if HT.Length = Count_Type'Last then 167 raise Constraint_Error; 168 end if; 169 170 Node := New_Node (Next => B); 171 Inserted := True; 172 173 B := Node; 174 HT.Length := HT.Length + 1; 175 end Generic_Conditional_Insert; 176 177 ----------- 178 -- Index -- 179 ----------- 180 181 function Index 182 (HT : Hash_Table_Type; 183 Key : Key_Type) return Hash_Type is 184 begin 185 return Hash (Key) mod HT.Buckets'Length; 186 end Index; 187 188 ----------------------------- 189 -- Generic_Replace_Element -- 190 ----------------------------- 191 192 procedure Generic_Replace_Element 193 (HT : in out Hash_Table_Type; 194 Node : Node_Access; 195 Key : Key_Type) 196 is 197 pragma Assert (HT.Length > 0); 198 pragma Assert (Node /= null); 199 200 Old_Hash : constant Hash_Type := Hash (Node); 201 Old_Indx : constant Hash_Type := Old_Hash mod HT.Buckets'Length; 202 203 New_Hash : constant Hash_Type := Hash (Key); 204 New_Indx : constant Hash_Type := New_Hash mod HT.Buckets'Length; 205 206 New_Bucket : Node_Access renames HT.Buckets (New_Indx); 207 N, M : Node_Access; 208 209 begin 210 if Equivalent_Keys (Key, Node) then 211 pragma Assert (New_Hash = Old_Hash); 212 213 if HT.Lock > 0 then 214 raise Program_Error with 215 "attempt to tamper with elements (container is locked)"; 216 end if; 217 218 -- We can change a node's key to Key (that's what Assign is for), but 219 -- only if Key is not already in the hash table. (In a unique-key 220 -- hash table as this one a key is mapped to exactly one node only.) 221 -- The exception is when Key is mapped to Node, in which case the 222 -- change is allowed. 223 224 Assign (Node, Key); 225 pragma Assert (Hash (Node) = New_Hash); 226 pragma Assert (Equivalent_Keys (Key, Node)); 227 return; 228 end if; 229 230 -- Key is not equivalent to Node, so we now have to determine if it's 231 -- equivalent to some other node in the hash table. This is the case 232 -- irrespective of whether Key is in the same or a different bucket from 233 -- Node. 234 235 N := New_Bucket; 236 while N /= null loop 237 if Equivalent_Keys (Key, N) then 238 pragma Assert (N /= Node); 239 raise Program_Error with 240 "attempt to replace existing element"; 241 end if; 242 243 N := Next (N); 244 end loop; 245 246 -- We have determined that Key is not already in the hash table, so 247 -- the change is tentatively allowed. We now perform the standard 248 -- checks to determine whether the hash table is locked (because you 249 -- cannot change an element while it's in use by Query_Element or 250 -- Update_Element), or if the container is busy (because moving a 251 -- node to a different bucket would interfere with iteration). 252 253 if Old_Indx = New_Indx then 254 -- The node is already in the bucket implied by Key. In this case 255 -- we merely change its value without moving it. 256 257 if HT.Lock > 0 then 258 raise Program_Error with 259 "attempt to tamper with elements (container is locked)"; 260 end if; 261 262 Assign (Node, Key); 263 pragma Assert (Hash (Node) = New_Hash); 264 pragma Assert (Equivalent_Keys (Key, Node)); 265 return; 266 end if; 267 268 -- The node is a bucket different from the bucket implied by Key 269 270 if HT.Busy > 0 then 271 raise Program_Error with 272 "attempt to tamper with cursors (container is busy)"; 273 end if; 274 275 -- Do the assignment first, before moving the node, so that if Assign 276 -- propagates an exception, then the hash table will not have been 277 -- modified (except for any possible side-effect Assign had on Node). 278 279 Assign (Node, Key); 280 pragma Assert (Hash (Node) = New_Hash); 281 pragma Assert (Equivalent_Keys (Key, Node)); 282 283 -- Now we can safely remove the node from its current bucket 284 285 N := HT.Buckets (Old_Indx); 286 pragma Assert (N /= null); 287 288 if N = Node then 289 HT.Buckets (Old_Indx) := Next (Node); 290 291 else 292 pragma Assert (HT.Length > 1); 293 294 loop 295 M := Next (N); 296 pragma Assert (M /= null); 297 298 if M = Node then 299 Set_Next (Node => N, Next => Next (Node)); 300 exit; 301 end if; 302 303 N := M; 304 end loop; 305 end if; 306 307 -- Now we link the node into its new bucket (corresponding to Key) 308 309 Set_Next (Node => Node, Next => New_Bucket); 310 New_Bucket := Node; 311 end Generic_Replace_Element; 312 313end Ada.Containers.Hash_Tables.Generic_Keys; 314