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