|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 2004-2017, 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
|
|
|
30 with Ada.Containers.Hash_Tables.Generic_Operations;
|
|
|
31 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
|
|
|
32
|
|
|
33 with Ada.Containers.Hash_Tables.Generic_Keys;
|
|
|
34 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
|
|
|
35
|
|
|
36 with Ada.Containers.Helpers; use Ada.Containers.Helpers;
|
|
|
37
|
|
|
38 with Ada.Unchecked_Deallocation;
|
|
|
39
|
|
|
40 with System; use type System.Address;
|
|
|
41
|
|
|
42 package body Ada.Containers.Indefinite_Hashed_Maps is
|
|
|
43
|
|
|
44 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
|
|
|
45 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
|
|
|
46 -- See comment in Ada.Containers.Helpers
|
|
|
47
|
|
|
48 procedure Free_Key is
|
|
|
49 new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
|
|
|
50
|
|
|
51 procedure Free_Element is
|
|
|
52 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
|
|
|
53
|
|
|
54 -----------------------
|
|
|
55 -- Local Subprograms --
|
|
|
56 -----------------------
|
|
|
57
|
|
|
58 function Copy_Node (Node : Node_Access) return Node_Access;
|
|
|
59 pragma Inline (Copy_Node);
|
|
|
60
|
|
|
61 function Equivalent_Key_Node
|
|
|
62 (Key : Key_Type;
|
|
|
63 Node : Node_Access) return Boolean;
|
|
|
64 pragma Inline (Equivalent_Key_Node);
|
|
|
65
|
|
|
66 function Find_Equal_Key
|
|
|
67 (R_HT : Hash_Table_Type;
|
|
|
68 L_Node : Node_Access) return Boolean;
|
|
|
69
|
|
|
70 procedure Free (X : in out Node_Access);
|
|
|
71 -- pragma Inline (Free);
|
|
|
72
|
|
|
73 function Hash_Node (Node : Node_Access) return Hash_Type;
|
|
|
74 pragma Inline (Hash_Node);
|
|
|
75
|
|
|
76 function Next (Node : Node_Access) return Node_Access;
|
|
|
77 pragma Inline (Next);
|
|
|
78
|
|
|
79 function Read_Node
|
|
|
80 (Stream : not null access Root_Stream_Type'Class) return Node_Access;
|
|
|
81
|
|
|
82 procedure Set_Next (Node : Node_Access; Next : Node_Access);
|
|
|
83 pragma Inline (Set_Next);
|
|
|
84
|
|
|
85 function Vet (Position : Cursor) return Boolean;
|
|
|
86
|
|
|
87 procedure Write_Node
|
|
|
88 (Stream : not null access Root_Stream_Type'Class;
|
|
|
89 Node : Node_Access);
|
|
|
90
|
|
|
91 --------------------------
|
|
|
92 -- Local Instantiations --
|
|
|
93 --------------------------
|
|
|
94
|
|
|
95 package HT_Ops is new Ada.Containers.Hash_Tables.Generic_Operations
|
|
|
96 (HT_Types => HT_Types,
|
|
|
97 Hash_Node => Hash_Node,
|
|
|
98 Next => Next,
|
|
|
99 Set_Next => Set_Next,
|
|
|
100 Copy_Node => Copy_Node,
|
|
|
101 Free => Free);
|
|
|
102
|
|
|
103 package Key_Ops is new Hash_Tables.Generic_Keys
|
|
|
104 (HT_Types => HT_Types,
|
|
|
105 Next => Next,
|
|
|
106 Set_Next => Set_Next,
|
|
|
107 Key_Type => Key_Type,
|
|
|
108 Hash => Hash,
|
|
|
109 Equivalent_Keys => Equivalent_Key_Node);
|
|
|
110
|
|
|
111 ---------
|
|
|
112 -- "=" --
|
|
|
113 ---------
|
|
|
114
|
|
|
115 function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
|
|
|
116
|
|
|
117 overriding function "=" (Left, Right : Map) return Boolean is
|
|
|
118 begin
|
|
|
119 return Is_Equal (Left.HT, Right.HT);
|
|
|
120 end "=";
|
|
|
121
|
|
|
122 ------------
|
|
|
123 -- Adjust --
|
|
|
124 ------------
|
|
|
125
|
|
|
126 procedure Adjust (Container : in out Map) is
|
|
|
127 begin
|
|
|
128 HT_Ops.Adjust (Container.HT);
|
|
|
129 end Adjust;
|
|
|
130
|
|
|
131 ------------
|
|
|
132 -- Assign --
|
|
|
133 ------------
|
|
|
134
|
|
|
135 procedure Assign (Target : in out Map; Source : Map) is
|
|
|
136 procedure Insert_Item (Node : Node_Access);
|
|
|
137 pragma Inline (Insert_Item);
|
|
|
138
|
|
|
139 procedure Insert_Items is new HT_Ops.Generic_Iteration (Insert_Item);
|
|
|
140
|
|
|
141 -----------------
|
|
|
142 -- Insert_Item --
|
|
|
143 -----------------
|
|
|
144
|
|
|
145 procedure Insert_Item (Node : Node_Access) is
|
|
|
146 begin
|
|
|
147 Target.Insert (Key => Node.Key.all, New_Item => Node.Element.all);
|
|
|
148 end Insert_Item;
|
|
|
149
|
|
|
150 -- Start of processing for Assign
|
|
|
151
|
|
|
152 begin
|
|
|
153 if Target'Address = Source'Address then
|
|
|
154 return;
|
|
|
155 end if;
|
|
|
156
|
|
|
157 Target.Clear;
|
|
|
158
|
|
|
159 if Target.Capacity < Source.Length then
|
|
|
160 Target.Reserve_Capacity (Source.Length);
|
|
|
161 end if;
|
|
|
162
|
|
|
163 Insert_Items (Source.HT);
|
|
|
164 end Assign;
|
|
|
165
|
|
|
166 --------------
|
|
|
167 -- Capacity --
|
|
|
168 --------------
|
|
|
169
|
|
|
170 function Capacity (Container : Map) return Count_Type is
|
|
|
171 begin
|
|
|
172 return HT_Ops.Capacity (Container.HT);
|
|
|
173 end Capacity;
|
|
|
174
|
|
|
175 -----------
|
|
|
176 -- Clear --
|
|
|
177 -----------
|
|
|
178
|
|
|
179 procedure Clear (Container : in out Map) is
|
|
|
180 begin
|
|
|
181 HT_Ops.Clear (Container.HT);
|
|
|
182 end Clear;
|
|
|
183
|
|
|
184 ------------------------
|
|
|
185 -- Constant_Reference --
|
|
|
186 ------------------------
|
|
|
187
|
|
|
188 function Constant_Reference
|
|
|
189 (Container : aliased Map;
|
|
|
190 Position : Cursor) return Constant_Reference_Type
|
|
|
191 is
|
|
|
192 begin
|
|
|
193 if Checks and then Position.Container = null then
|
|
|
194 raise Constraint_Error with
|
|
|
195 "Position cursor has no element";
|
|
|
196 end if;
|
|
|
197
|
|
|
198 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
199 then
|
|
|
200 raise Program_Error with
|
|
|
201 "Position cursor designates wrong map";
|
|
|
202 end if;
|
|
|
203
|
|
|
204 if Checks and then Position.Node.Element = null then
|
|
|
205 raise Program_Error with
|
|
|
206 "Position cursor has no element";
|
|
|
207 end if;
|
|
|
208
|
|
|
209 pragma Assert
|
|
|
210 (Vet (Position),
|
|
|
211 "Position cursor in Constant_Reference is bad");
|
|
|
212
|
|
|
213 declare
|
|
|
214 M : Map renames Position.Container.all;
|
|
|
215 HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
|
|
|
216 TC : constant Tamper_Counts_Access :=
|
|
|
217 HT.TC'Unrestricted_Access;
|
|
|
218 begin
|
|
|
219 return R : constant Constant_Reference_Type :=
|
|
|
220 (Element => Position.Node.Element.all'Access,
|
|
|
221 Control => (Controlled with TC))
|
|
|
222 do
|
|
|
223 Lock (TC.all);
|
|
|
224 end return;
|
|
|
225 end;
|
|
|
226 end Constant_Reference;
|
|
|
227
|
|
|
228 function Constant_Reference
|
|
|
229 (Container : aliased Map;
|
|
|
230 Key : Key_Type) return Constant_Reference_Type
|
|
|
231 is
|
|
|
232 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
|
|
|
233 Node : constant Node_Access := Key_Ops.Find (HT, Key);
|
|
|
234
|
|
|
235 begin
|
|
|
236 if Checks and then Node = null then
|
|
|
237 raise Constraint_Error with "key not in map";
|
|
|
238 end if;
|
|
|
239
|
|
|
240 if Checks and then Node.Element = null then
|
|
|
241 raise Program_Error with "key has no element";
|
|
|
242 end if;
|
|
|
243
|
|
|
244 declare
|
|
|
245 TC : constant Tamper_Counts_Access :=
|
|
|
246 HT.TC'Unrestricted_Access;
|
|
|
247 begin
|
|
|
248 return R : constant Constant_Reference_Type :=
|
|
|
249 (Element => Node.Element.all'Access,
|
|
|
250 Control => (Controlled with TC))
|
|
|
251 do
|
|
|
252 Lock (TC.all);
|
|
|
253 end return;
|
|
|
254 end;
|
|
|
255 end Constant_Reference;
|
|
|
256
|
|
|
257 --------------
|
|
|
258 -- Contains --
|
|
|
259 --------------
|
|
|
260
|
|
|
261 function Contains (Container : Map; Key : Key_Type) return Boolean is
|
|
|
262 begin
|
|
|
263 return Find (Container, Key) /= No_Element;
|
|
|
264 end Contains;
|
|
|
265
|
|
|
266 ----------
|
|
|
267 -- Copy --
|
|
|
268 ----------
|
|
|
269
|
|
|
270 function Copy
|
|
|
271 (Source : Map;
|
|
|
272 Capacity : Count_Type := 0) return Map
|
|
|
273 is
|
|
|
274 C : Count_Type;
|
|
|
275
|
|
|
276 begin
|
|
|
277 if Capacity < Source.Length then
|
|
|
278 if Checks and then Capacity /= 0 then
|
|
|
279 raise Capacity_Error
|
|
|
280 with "Requested capacity is less than Source length";
|
|
|
281 end if;
|
|
|
282
|
|
|
283 C := Source.Length;
|
|
|
284 else
|
|
|
285 C := Capacity;
|
|
|
286 end if;
|
|
|
287
|
|
|
288 return Target : Map do
|
|
|
289 Target.Reserve_Capacity (C);
|
|
|
290 Target.Assign (Source);
|
|
|
291 end return;
|
|
|
292 end Copy;
|
|
|
293
|
|
|
294 ---------------
|
|
|
295 -- Copy_Node --
|
|
|
296 ---------------
|
|
|
297
|
|
|
298 function Copy_Node (Node : Node_Access) return Node_Access is
|
|
|
299 K : Key_Access := new Key_Type'(Node.Key.all);
|
|
|
300 E : Element_Access;
|
|
|
301 begin
|
|
|
302 E := new Element_Type'(Node.Element.all);
|
|
|
303 return new Node_Type'(K, E, null);
|
|
|
304 exception
|
|
|
305 when others =>
|
|
|
306 Free_Key (K);
|
|
|
307 Free_Element (E);
|
|
|
308 raise;
|
|
|
309 end Copy_Node;
|
|
|
310
|
|
|
311 ------------
|
|
|
312 -- Delete --
|
|
|
313 ------------
|
|
|
314
|
|
|
315 procedure Delete (Container : in out Map; Key : Key_Type) is
|
|
|
316 X : Node_Access;
|
|
|
317
|
|
|
318 begin
|
|
|
319 Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
|
|
|
320
|
|
|
321 if Checks and then X = null then
|
|
|
322 raise Constraint_Error with "attempt to delete key not in map";
|
|
|
323 end if;
|
|
|
324
|
|
|
325 Free (X);
|
|
|
326 end Delete;
|
|
|
327
|
|
|
328 procedure Delete (Container : in out Map; Position : in out Cursor) is
|
|
|
329 begin
|
|
|
330 if Checks and then Position.Node = null then
|
|
|
331 raise Constraint_Error with
|
|
|
332 "Position cursor of Delete equals No_Element";
|
|
|
333 end if;
|
|
|
334
|
|
|
335 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
336 then
|
|
|
337 raise Program_Error with
|
|
|
338 "Position cursor of Delete designates wrong map";
|
|
|
339 end if;
|
|
|
340
|
|
|
341 TC_Check (Container.HT.TC);
|
|
|
342
|
|
|
343 pragma Assert (Vet (Position), "bad cursor in Delete");
|
|
|
344
|
|
|
345 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
|
|
|
346
|
|
|
347 Free (Position.Node);
|
|
|
348 Position.Container := null;
|
|
|
349 end Delete;
|
|
|
350
|
|
|
351 -------------
|
|
|
352 -- Element --
|
|
|
353 -------------
|
|
|
354
|
|
|
355 function Element (Container : Map; Key : Key_Type) return Element_Type is
|
|
|
356 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
|
|
|
357 Node : constant Node_Access := Key_Ops.Find (HT, Key);
|
|
|
358
|
|
|
359 begin
|
|
|
360 if Checks and then Node = null then
|
|
|
361 raise Constraint_Error with
|
|
|
362 "no element available because key not in map";
|
|
|
363 end if;
|
|
|
364
|
|
|
365 return Node.Element.all;
|
|
|
366 end Element;
|
|
|
367
|
|
|
368 function Element (Position : Cursor) return Element_Type is
|
|
|
369 begin
|
|
|
370 if Checks and then Position.Node = null then
|
|
|
371 raise Constraint_Error with
|
|
|
372 "Position cursor of function Element equals No_Element";
|
|
|
373 end if;
|
|
|
374
|
|
|
375 if Checks and then Position.Node.Element = null then
|
|
|
376 raise Program_Error with
|
|
|
377 "Position cursor of function Element is bad";
|
|
|
378 end if;
|
|
|
379
|
|
|
380 pragma Assert (Vet (Position), "bad cursor in function Element");
|
|
|
381
|
|
|
382 return Position.Node.Element.all;
|
|
|
383 end Element;
|
|
|
384
|
|
|
385 -------------------------
|
|
|
386 -- Equivalent_Key_Node --
|
|
|
387 -------------------------
|
|
|
388
|
|
|
389 function Equivalent_Key_Node
|
|
|
390 (Key : Key_Type;
|
|
|
391 Node : Node_Access) return Boolean
|
|
|
392 is
|
|
|
393 begin
|
|
|
394 return Equivalent_Keys (Key, Node.Key.all);
|
|
|
395 end Equivalent_Key_Node;
|
|
|
396
|
|
|
397 ---------------------
|
|
|
398 -- Equivalent_Keys --
|
|
|
399 ---------------------
|
|
|
400
|
|
|
401 function Equivalent_Keys (Left, Right : Cursor) return Boolean is
|
|
|
402 begin
|
|
|
403 if Checks and then Left.Node = null then
|
|
|
404 raise Constraint_Error with
|
|
|
405 "Left cursor of Equivalent_Keys equals No_Element";
|
|
|
406 end if;
|
|
|
407
|
|
|
408 if Checks and then Right.Node = null then
|
|
|
409 raise Constraint_Error with
|
|
|
410 "Right cursor of Equivalent_Keys equals No_Element";
|
|
|
411 end if;
|
|
|
412
|
|
|
413 if Checks and then Left.Node.Key = null then
|
|
|
414 raise Program_Error with
|
|
|
415 "Left cursor of Equivalent_Keys is bad";
|
|
|
416 end if;
|
|
|
417
|
|
|
418 if Checks and then Right.Node.Key = null then
|
|
|
419 raise Program_Error with
|
|
|
420 "Right cursor of Equivalent_Keys is bad";
|
|
|
421 end if;
|
|
|
422
|
|
|
423 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
|
|
|
424 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
|
|
|
425
|
|
|
426 return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
|
|
|
427 end Equivalent_Keys;
|
|
|
428
|
|
|
429 function Equivalent_Keys
|
|
|
430 (Left : Cursor;
|
|
|
431 Right : Key_Type) return Boolean
|
|
|
432 is
|
|
|
433 begin
|
|
|
434 if Checks and then Left.Node = null then
|
|
|
435 raise Constraint_Error with
|
|
|
436 "Left cursor of Equivalent_Keys equals No_Element";
|
|
|
437 end if;
|
|
|
438
|
|
|
439 if Checks and then Left.Node.Key = null then
|
|
|
440 raise Program_Error with
|
|
|
441 "Left cursor of Equivalent_Keys is bad";
|
|
|
442 end if;
|
|
|
443
|
|
|
444 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
|
|
|
445
|
|
|
446 return Equivalent_Keys (Left.Node.Key.all, Right);
|
|
|
447 end Equivalent_Keys;
|
|
|
448
|
|
|
449 function Equivalent_Keys
|
|
|
450 (Left : Key_Type;
|
|
|
451 Right : Cursor) return Boolean
|
|
|
452 is
|
|
|
453 begin
|
|
|
454 if Checks and then Right.Node = null then
|
|
|
455 raise Constraint_Error with
|
|
|
456 "Right cursor of Equivalent_Keys equals No_Element";
|
|
|
457 end if;
|
|
|
458
|
|
|
459 if Checks and then Right.Node.Key = null then
|
|
|
460 raise Program_Error with
|
|
|
461 "Right cursor of Equivalent_Keys is bad";
|
|
|
462 end if;
|
|
|
463
|
|
|
464 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
|
|
|
465
|
|
|
466 return Equivalent_Keys (Left, Right.Node.Key.all);
|
|
|
467 end Equivalent_Keys;
|
|
|
468
|
|
|
469 -------------
|
|
|
470 -- Exclude --
|
|
|
471 -------------
|
|
|
472
|
|
|
473 procedure Exclude (Container : in out Map; Key : Key_Type) is
|
|
|
474 X : Node_Access;
|
|
|
475 begin
|
|
|
476 Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
|
|
|
477 Free (X);
|
|
|
478 end Exclude;
|
|
|
479
|
|
|
480 --------------
|
|
|
481 -- Finalize --
|
|
|
482 --------------
|
|
|
483
|
|
|
484 procedure Finalize (Container : in out Map) is
|
|
|
485 begin
|
|
|
486 HT_Ops.Finalize (Container.HT);
|
|
|
487 end Finalize;
|
|
|
488
|
|
|
489 procedure Finalize (Object : in out Iterator) is
|
|
|
490 begin
|
|
|
491 if Object.Container /= null then
|
|
|
492 Unbusy (Object.Container.HT.TC);
|
|
|
493 end if;
|
|
|
494 end Finalize;
|
|
|
495
|
|
|
496 ----------
|
|
|
497 -- Find --
|
|
|
498 ----------
|
|
|
499
|
|
|
500 function Find (Container : Map; Key : Key_Type) return Cursor is
|
|
|
501 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
|
|
|
502 Node : constant Node_Access := Key_Ops.Find (HT, Key);
|
|
|
503
|
|
|
504 begin
|
|
|
505 if Node = null then
|
|
|
506 return No_Element;
|
|
|
507 end if;
|
|
|
508
|
|
|
509 return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last);
|
|
|
510 end Find;
|
|
|
511
|
|
|
512 --------------------
|
|
|
513 -- Find_Equal_Key --
|
|
|
514 --------------------
|
|
|
515
|
|
|
516 function Find_Equal_Key
|
|
|
517 (R_HT : Hash_Table_Type;
|
|
|
518 L_Node : Node_Access) return Boolean
|
|
|
519 is
|
|
|
520 R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key.all);
|
|
|
521 R_Node : Node_Access := R_HT.Buckets (R_Index);
|
|
|
522
|
|
|
523 begin
|
|
|
524 while R_Node /= null loop
|
|
|
525 if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then
|
|
|
526 return L_Node.Element.all = R_Node.Element.all;
|
|
|
527 end if;
|
|
|
528
|
|
|
529 R_Node := R_Node.Next;
|
|
|
530 end loop;
|
|
|
531
|
|
|
532 return False;
|
|
|
533 end Find_Equal_Key;
|
|
|
534
|
|
|
535 -----------
|
|
|
536 -- First --
|
|
|
537 -----------
|
|
|
538
|
|
|
539 function First (Container : Map) return Cursor is
|
|
|
540 Pos : Hash_Type;
|
|
|
541 Node : constant Node_Access := HT_Ops.First (Container.HT, Pos);
|
|
|
542 begin
|
|
|
543 if Node = null then
|
|
|
544 return No_Element;
|
|
|
545 else
|
|
|
546 return Cursor'(Container'Unrestricted_Access, Node, Pos);
|
|
|
547 end if;
|
|
|
548 end First;
|
|
|
549
|
|
|
550 function First (Object : Iterator) return Cursor is
|
|
|
551 begin
|
|
|
552 return Object.Container.First;
|
|
|
553 end First;
|
|
|
554
|
|
|
555 ----------
|
|
|
556 -- Free --
|
|
|
557 ----------
|
|
|
558
|
|
|
559 procedure Free (X : in out Node_Access) is
|
|
|
560 procedure Deallocate is
|
|
|
561 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
|
|
|
562
|
|
|
563 begin
|
|
|
564 if X = null then
|
|
|
565 return;
|
|
|
566 end if;
|
|
|
567
|
|
|
568 X.Next := X; -- detect mischief (in Vet)
|
|
|
569
|
|
|
570 begin
|
|
|
571 Free_Key (X.Key);
|
|
|
572
|
|
|
573 exception
|
|
|
574 when others =>
|
|
|
575 X.Key := null;
|
|
|
576
|
|
|
577 begin
|
|
|
578 Free_Element (X.Element);
|
|
|
579 exception
|
|
|
580 when others =>
|
|
|
581 X.Element := null;
|
|
|
582 end;
|
|
|
583
|
|
|
584 Deallocate (X);
|
|
|
585 raise;
|
|
|
586 end;
|
|
|
587
|
|
|
588 begin
|
|
|
589 Free_Element (X.Element);
|
|
|
590 exception
|
|
|
591 when others =>
|
|
|
592 X.Element := null;
|
|
|
593 Deallocate (X);
|
|
|
594 raise;
|
|
|
595 end;
|
|
|
596
|
|
|
597 Deallocate (X);
|
|
|
598 end Free;
|
|
|
599
|
|
|
600 ------------------------
|
|
|
601 -- Get_Element_Access --
|
|
|
602 ------------------------
|
|
|
603
|
|
|
604 function Get_Element_Access
|
|
|
605 (Position : Cursor) return not null Element_Access is
|
|
|
606 begin
|
|
|
607 return Position.Node.Element;
|
|
|
608 end Get_Element_Access;
|
|
|
609
|
|
|
610 -----------------
|
|
|
611 -- Has_Element --
|
|
|
612 -----------------
|
|
|
613
|
|
|
614 function Has_Element (Position : Cursor) return Boolean is
|
|
|
615 begin
|
|
|
616 pragma Assert (Vet (Position), "bad cursor in Has_Element");
|
|
|
617 return Position.Node /= null;
|
|
|
618 end Has_Element;
|
|
|
619
|
|
|
620 ---------------
|
|
|
621 -- Hash_Node --
|
|
|
622 ---------------
|
|
|
623
|
|
|
624 function Hash_Node (Node : Node_Access) return Hash_Type is
|
|
|
625 begin
|
|
|
626 return Hash (Node.Key.all);
|
|
|
627 end Hash_Node;
|
|
|
628
|
|
|
629 -------------
|
|
|
630 -- Include --
|
|
|
631 -------------
|
|
|
632
|
|
|
633 procedure Include
|
|
|
634 (Container : in out Map;
|
|
|
635 Key : Key_Type;
|
|
|
636 New_Item : Element_Type)
|
|
|
637 is
|
|
|
638 Position : Cursor;
|
|
|
639 Inserted : Boolean;
|
|
|
640
|
|
|
641 K : Key_Access;
|
|
|
642 E : Element_Access;
|
|
|
643
|
|
|
644 begin
|
|
|
645 Insert (Container, Key, New_Item, Position, Inserted);
|
|
|
646
|
|
|
647 if not Inserted then
|
|
|
648 TE_Check (Container.HT.TC);
|
|
|
649
|
|
|
650 K := Position.Node.Key;
|
|
|
651 E := Position.Node.Element;
|
|
|
652
|
|
|
653 Position.Node.Key := new Key_Type'(Key);
|
|
|
654
|
|
|
655 declare
|
|
|
656 -- The element allocator may need an accessibility check in the
|
|
|
657 -- case the actual type is class-wide or has access discriminants
|
|
|
658 -- (see RM 4.8(10.1) and AI12-0035).
|
|
|
659
|
|
|
660 pragma Unsuppress (Accessibility_Check);
|
|
|
661
|
|
|
662 begin
|
|
|
663 Position.Node.Element := new Element_Type'(New_Item);
|
|
|
664
|
|
|
665 exception
|
|
|
666 when others =>
|
|
|
667 Free_Key (K);
|
|
|
668 raise;
|
|
|
669 end;
|
|
|
670
|
|
|
671 Free_Key (K);
|
|
|
672 Free_Element (E);
|
|
|
673 end if;
|
|
|
674 end Include;
|
|
|
675
|
|
|
676 ------------
|
|
|
677 -- Insert --
|
|
|
678 ------------
|
|
|
679
|
|
|
680 procedure Insert
|
|
|
681 (Container : in out Map;
|
|
|
682 Key : Key_Type;
|
|
|
683 New_Item : Element_Type;
|
|
|
684 Position : out Cursor;
|
|
|
685 Inserted : out Boolean)
|
|
|
686 is
|
|
|
687 function New_Node (Next : Node_Access) return Node_Access;
|
|
|
688
|
|
|
689 procedure Local_Insert is
|
|
|
690 new Key_Ops.Generic_Conditional_Insert (New_Node);
|
|
|
691
|
|
|
692 --------------
|
|
|
693 -- New_Node --
|
|
|
694 --------------
|
|
|
695
|
|
|
696 function New_Node (Next : Node_Access) return Node_Access is
|
|
|
697 K : Key_Access := new Key_Type'(Key);
|
|
|
698 E : Element_Access;
|
|
|
699
|
|
|
700 -- The element allocator may need an accessibility check in the case
|
|
|
701 -- the actual type is class-wide or has access discriminants (see
|
|
|
702 -- RM 4.8(10.1) and AI12-0035).
|
|
|
703
|
|
|
704 pragma Unsuppress (Accessibility_Check);
|
|
|
705
|
|
|
706 begin
|
|
|
707 E := new Element_Type'(New_Item);
|
|
|
708 return new Node_Type'(K, E, Next);
|
|
|
709
|
|
|
710 exception
|
|
|
711 when others =>
|
|
|
712 Free_Key (K);
|
|
|
713 Free_Element (E);
|
|
|
714 raise;
|
|
|
715 end New_Node;
|
|
|
716
|
|
|
717 HT : Hash_Table_Type renames Container.HT;
|
|
|
718
|
|
|
719 -- Start of processing for Insert
|
|
|
720
|
|
|
721 begin
|
|
|
722 if HT_Ops.Capacity (HT) = 0 then
|
|
|
723 HT_Ops.Reserve_Capacity (HT, 1);
|
|
|
724 end if;
|
|
|
725
|
|
|
726 Local_Insert (HT, Key, Position.Node, Inserted);
|
|
|
727
|
|
|
728 if Inserted
|
|
|
729 and then HT.Length > HT_Ops.Capacity (HT)
|
|
|
730 then
|
|
|
731 HT_Ops.Reserve_Capacity (HT, HT.Length);
|
|
|
732 end if;
|
|
|
733
|
|
|
734 Position.Container := Container'Unchecked_Access;
|
|
|
735 end Insert;
|
|
|
736
|
|
|
737 procedure Insert
|
|
|
738 (Container : in out Map;
|
|
|
739 Key : Key_Type;
|
|
|
740 New_Item : Element_Type)
|
|
|
741 is
|
|
|
742 Position : Cursor;
|
|
|
743 pragma Unreferenced (Position);
|
|
|
744
|
|
|
745 Inserted : Boolean;
|
|
|
746
|
|
|
747 begin
|
|
|
748 Insert (Container, Key, New_Item, Position, Inserted);
|
|
|
749
|
|
|
750 if Checks and then not Inserted then
|
|
|
751 raise Constraint_Error with
|
|
|
752 "attempt to insert key already in map";
|
|
|
753 end if;
|
|
|
754 end Insert;
|
|
|
755
|
|
|
756 --------------
|
|
|
757 -- Is_Empty --
|
|
|
758 --------------
|
|
|
759
|
|
|
760 function Is_Empty (Container : Map) return Boolean is
|
|
|
761 begin
|
|
|
762 return Container.HT.Length = 0;
|
|
|
763 end Is_Empty;
|
|
|
764
|
|
|
765 -------------
|
|
|
766 -- Iterate --
|
|
|
767 -------------
|
|
|
768
|
|
|
769 procedure Iterate
|
|
|
770 (Container : Map;
|
|
|
771 Process : not null access procedure (Position : Cursor))
|
|
|
772 is
|
|
|
773 procedure Process_Node (Node : Node_Access; Position : Hash_Type);
|
|
|
774 pragma Inline (Process_Node);
|
|
|
775
|
|
|
776 procedure Local_Iterate is
|
|
|
777 new HT_Ops.Generic_Iteration_With_Position (Process_Node);
|
|
|
778
|
|
|
779 ------------------
|
|
|
780 -- Process_Node --
|
|
|
781 ------------------
|
|
|
782
|
|
|
783 procedure Process_Node (Node : Node_Access; Position : Hash_Type) is
|
|
|
784 begin
|
|
|
785 Process (Cursor'(Container'Unrestricted_Access, Node, Position));
|
|
|
786 end Process_Node;
|
|
|
787
|
|
|
788 Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
|
|
|
789
|
|
|
790 -- Start of processing for Iterate
|
|
|
791
|
|
|
792 begin
|
|
|
793 Local_Iterate (Container.HT);
|
|
|
794 end Iterate;
|
|
|
795
|
|
|
796 function Iterate
|
|
|
797 (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
|
|
|
798 is
|
|
|
799 begin
|
|
|
800 return It : constant Iterator :=
|
|
|
801 (Limited_Controlled with Container => Container'Unrestricted_Access)
|
|
|
802 do
|
|
|
803 Busy (Container.HT.TC'Unrestricted_Access.all);
|
|
|
804 end return;
|
|
|
805 end Iterate;
|
|
|
806
|
|
|
807 ---------
|
|
|
808 -- Key --
|
|
|
809 ---------
|
|
|
810
|
|
|
811 function Key (Position : Cursor) return Key_Type is
|
|
|
812 begin
|
|
|
813 if Checks and then Position.Node = null then
|
|
|
814 raise Constraint_Error with
|
|
|
815 "Position cursor of function Key equals No_Element";
|
|
|
816 end if;
|
|
|
817
|
|
|
818 if Checks and then Position.Node.Key = null then
|
|
|
819 raise Program_Error with
|
|
|
820 "Position cursor of function Key is bad";
|
|
|
821 end if;
|
|
|
822
|
|
|
823 pragma Assert (Vet (Position), "bad cursor in function Key");
|
|
|
824
|
|
|
825 return Position.Node.Key.all;
|
|
|
826 end Key;
|
|
|
827
|
|
|
828 ------------
|
|
|
829 -- Length --
|
|
|
830 ------------
|
|
|
831
|
|
|
832 function Length (Container : Map) return Count_Type is
|
|
|
833 begin
|
|
|
834 return Container.HT.Length;
|
|
|
835 end Length;
|
|
|
836
|
|
|
837 ----------
|
|
|
838 -- Move --
|
|
|
839 ----------
|
|
|
840
|
|
|
841 procedure Move
|
|
|
842 (Target : in out Map;
|
|
|
843 Source : in out Map)
|
|
|
844 is
|
|
|
845 begin
|
|
|
846 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
|
|
|
847 end Move;
|
|
|
848
|
|
|
849 ----------
|
|
|
850 -- Next --
|
|
|
851 ----------
|
|
|
852
|
|
|
853 function Next (Node : Node_Access) return Node_Access is
|
|
|
854 begin
|
|
|
855 return Node.Next;
|
|
|
856 end Next;
|
|
|
857
|
|
|
858 procedure Next (Position : in out Cursor) is
|
|
|
859 begin
|
|
|
860 Position := Next (Position);
|
|
|
861 end Next;
|
|
|
862
|
|
|
863 function Next (Position : Cursor) return Cursor is
|
|
|
864 Node : Node_Access;
|
|
|
865 Pos : Hash_Type;
|
|
|
866 begin
|
|
|
867 if Position.Node = null then
|
|
|
868 return No_Element;
|
|
|
869 end if;
|
|
|
870
|
|
|
871 if Checks and then
|
|
|
872 (Position.Node.Key = null or else Position.Node.Element = null)
|
|
|
873 then
|
|
|
874 raise Program_Error with "Position cursor of Next is bad";
|
|
|
875 end if;
|
|
|
876
|
|
|
877 pragma Assert (Vet (Position), "Position cursor of Next is bad");
|
|
|
878
|
|
|
879 Pos := Position.Position;
|
|
|
880 Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos);
|
|
|
881
|
|
|
882 if Node = null then
|
|
|
883 return No_Element;
|
|
|
884 else
|
|
|
885 return Cursor'(Position.Container, Node, Pos);
|
|
|
886 end if;
|
|
|
887 end Next;
|
|
|
888
|
|
|
889 function Next (Object : Iterator; Position : Cursor) return Cursor is
|
|
|
890 begin
|
|
|
891 if Position.Container = null then
|
|
|
892 return No_Element;
|
|
|
893 end if;
|
|
|
894
|
|
|
895 if Checks and then Position.Container /= Object.Container then
|
|
|
896 raise Program_Error with
|
|
|
897 "Position cursor of Next designates wrong map";
|
|
|
898 end if;
|
|
|
899
|
|
|
900 return Next (Position);
|
|
|
901 end Next;
|
|
|
902
|
|
|
903 ----------------------
|
|
|
904 -- Pseudo_Reference --
|
|
|
905 ----------------------
|
|
|
906
|
|
|
907 function Pseudo_Reference
|
|
|
908 (Container : aliased Map'Class) return Reference_Control_Type
|
|
|
909 is
|
|
|
910 TC : constant Tamper_Counts_Access :=
|
|
|
911 Container.HT.TC'Unrestricted_Access;
|
|
|
912 begin
|
|
|
913 return R : constant Reference_Control_Type := (Controlled with TC) do
|
|
|
914 Lock (TC.all);
|
|
|
915 end return;
|
|
|
916 end Pseudo_Reference;
|
|
|
917
|
|
|
918 -------------------
|
|
|
919 -- Query_Element --
|
|
|
920 -------------------
|
|
|
921
|
|
|
922 procedure Query_Element
|
|
|
923 (Position : Cursor;
|
|
|
924 Process : not null access procedure (Key : Key_Type;
|
|
|
925 Element : Element_Type))
|
|
|
926 is
|
|
|
927 begin
|
|
|
928 if Checks and then Position.Node = null then
|
|
|
929 raise Constraint_Error with
|
|
|
930 "Position cursor of Query_Element equals No_Element";
|
|
|
931 end if;
|
|
|
932
|
|
|
933 if Checks and then
|
|
|
934 (Position.Node.Key = null or else Position.Node.Element = null)
|
|
|
935 then
|
|
|
936 raise Program_Error with
|
|
|
937 "Position cursor of Query_Element is bad";
|
|
|
938 end if;
|
|
|
939
|
|
|
940 pragma Assert (Vet (Position), "bad cursor in Query_Element");
|
|
|
941
|
|
|
942 declare
|
|
|
943 M : Map renames Position.Container.all;
|
|
|
944 HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
|
|
|
945 Lock : With_Lock (HT.TC'Unrestricted_Access);
|
|
|
946 K : Key_Type renames Position.Node.Key.all;
|
|
|
947 E : Element_Type renames Position.Node.Element.all;
|
|
|
948 begin
|
|
|
949 Process (K, E);
|
|
|
950 end;
|
|
|
951 end Query_Element;
|
|
|
952
|
|
|
953 ----------
|
|
|
954 -- Read --
|
|
|
955 ----------
|
|
|
956
|
|
|
957 procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
|
|
|
958
|
|
|
959 procedure Read
|
|
|
960 (Stream : not null access Root_Stream_Type'Class;
|
|
|
961 Container : out Map)
|
|
|
962 is
|
|
|
963 begin
|
|
|
964 Read_Nodes (Stream, Container.HT);
|
|
|
965 end Read;
|
|
|
966
|
|
|
967 procedure Read
|
|
|
968 (Stream : not null access Root_Stream_Type'Class;
|
|
|
969 Item : out Cursor)
|
|
|
970 is
|
|
|
971 begin
|
|
|
972 raise Program_Error with "attempt to stream map cursor";
|
|
|
973 end Read;
|
|
|
974
|
|
|
975 procedure Read
|
|
|
976 (Stream : not null access Root_Stream_Type'Class;
|
|
|
977 Item : out Reference_Type)
|
|
|
978 is
|
|
|
979 begin
|
|
|
980 raise Program_Error with "attempt to stream reference";
|
|
|
981 end Read;
|
|
|
982
|
|
|
983 procedure Read
|
|
|
984 (Stream : not null access Root_Stream_Type'Class;
|
|
|
985 Item : out Constant_Reference_Type)
|
|
|
986 is
|
|
|
987 begin
|
|
|
988 raise Program_Error with "attempt to stream reference";
|
|
|
989 end Read;
|
|
|
990
|
|
|
991 ---------------
|
|
|
992 -- Read_Node --
|
|
|
993 ---------------
|
|
|
994
|
|
|
995 function Read_Node
|
|
|
996 (Stream : not null access Root_Stream_Type'Class) return Node_Access
|
|
|
997 is
|
|
|
998 Node : Node_Access := new Node_Type;
|
|
|
999
|
|
|
1000 begin
|
|
|
1001 begin
|
|
|
1002 Node.Key := new Key_Type'(Key_Type'Input (Stream));
|
|
|
1003 exception
|
|
|
1004 when others =>
|
|
|
1005 Free (Node);
|
|
|
1006 raise;
|
|
|
1007 end;
|
|
|
1008
|
|
|
1009 begin
|
|
|
1010 Node.Element := new Element_Type'(Element_Type'Input (Stream));
|
|
|
1011 exception
|
|
|
1012 when others =>
|
|
|
1013 Free_Key (Node.Key);
|
|
|
1014 Free (Node);
|
|
|
1015 raise;
|
|
|
1016 end;
|
|
|
1017
|
|
|
1018 return Node;
|
|
|
1019 end Read_Node;
|
|
|
1020
|
|
|
1021 ---------------
|
|
|
1022 -- Reference --
|
|
|
1023 ---------------
|
|
|
1024
|
|
|
1025 function Reference
|
|
|
1026 (Container : aliased in out Map;
|
|
|
1027 Position : Cursor) return Reference_Type
|
|
|
1028 is
|
|
|
1029 begin
|
|
|
1030 if Checks and then Position.Container = null then
|
|
|
1031 raise Constraint_Error with
|
|
|
1032 "Position cursor has no element";
|
|
|
1033 end if;
|
|
|
1034
|
|
|
1035 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1036 then
|
|
|
1037 raise Program_Error with
|
|
|
1038 "Position cursor designates wrong map";
|
|
|
1039 end if;
|
|
|
1040
|
|
|
1041 if Checks and then Position.Node.Element = null then
|
|
|
1042 raise Program_Error with
|
|
|
1043 "Position cursor has no element";
|
|
|
1044 end if;
|
|
|
1045
|
|
|
1046 pragma Assert
|
|
|
1047 (Vet (Position),
|
|
|
1048 "Position cursor in function Reference is bad");
|
|
|
1049
|
|
|
1050 declare
|
|
|
1051 M : Map renames Position.Container.all;
|
|
|
1052 HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
|
|
|
1053 TC : constant Tamper_Counts_Access :=
|
|
|
1054 HT.TC'Unrestricted_Access;
|
|
|
1055 begin
|
|
|
1056 return R : constant Reference_Type :=
|
|
|
1057 (Element => Position.Node.Element.all'Access,
|
|
|
1058 Control => (Controlled with TC))
|
|
|
1059 do
|
|
|
1060 Lock (TC.all);
|
|
|
1061 end return;
|
|
|
1062 end;
|
|
|
1063 end Reference;
|
|
|
1064
|
|
|
1065 function Reference
|
|
|
1066 (Container : aliased in out Map;
|
|
|
1067 Key : Key_Type) return Reference_Type
|
|
|
1068 is
|
|
|
1069 HT : Hash_Table_Type renames Container.HT;
|
|
|
1070 Node : constant Node_Access := Key_Ops.Find (HT, Key);
|
|
|
1071
|
|
|
1072 begin
|
|
|
1073 if Checks and then Node = null then
|
|
|
1074 raise Constraint_Error with "key not in map";
|
|
|
1075 end if;
|
|
|
1076
|
|
|
1077 if Checks and then Node.Element = null then
|
|
|
1078 raise Program_Error with "key has no element";
|
|
|
1079 end if;
|
|
|
1080
|
|
|
1081 declare
|
|
|
1082 TC : constant Tamper_Counts_Access :=
|
|
|
1083 HT.TC'Unrestricted_Access;
|
|
|
1084 begin
|
|
|
1085 return R : constant Reference_Type :=
|
|
|
1086 (Element => Node.Element.all'Access,
|
|
|
1087 Control => (Controlled with TC))
|
|
|
1088 do
|
|
|
1089 Lock (TC.all);
|
|
|
1090 end return;
|
|
|
1091 end;
|
|
|
1092 end Reference;
|
|
|
1093
|
|
|
1094 -------------
|
|
|
1095 -- Replace --
|
|
|
1096 -------------
|
|
|
1097
|
|
|
1098 procedure Replace
|
|
|
1099 (Container : in out Map;
|
|
|
1100 Key : Key_Type;
|
|
|
1101 New_Item : Element_Type)
|
|
|
1102 is
|
|
|
1103 Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
|
|
|
1104
|
|
|
1105 K : Key_Access;
|
|
|
1106 E : Element_Access;
|
|
|
1107
|
|
|
1108 begin
|
|
|
1109 if Checks and then Node = null then
|
|
|
1110 raise Constraint_Error with
|
|
|
1111 "attempt to replace key not in map";
|
|
|
1112 end if;
|
|
|
1113
|
|
|
1114 TE_Check (Container.HT.TC);
|
|
|
1115
|
|
|
1116 K := Node.Key;
|
|
|
1117 E := Node.Element;
|
|
|
1118
|
|
|
1119 Node.Key := new Key_Type'(Key);
|
|
|
1120
|
|
|
1121 declare
|
|
|
1122 -- The element allocator may need an accessibility check in the case
|
|
|
1123 -- the actual type is class-wide or has access discriminants (see
|
|
|
1124 -- RM 4.8(10.1) and AI12-0035).
|
|
|
1125
|
|
|
1126 pragma Unsuppress (Accessibility_Check);
|
|
|
1127
|
|
|
1128 begin
|
|
|
1129 Node.Element := new Element_Type'(New_Item);
|
|
|
1130
|
|
|
1131 exception
|
|
|
1132 when others =>
|
|
|
1133 Free_Key (K);
|
|
|
1134 raise;
|
|
|
1135 end;
|
|
|
1136
|
|
|
1137 Free_Key (K);
|
|
|
1138 Free_Element (E);
|
|
|
1139 end Replace;
|
|
|
1140
|
|
|
1141 ---------------------
|
|
|
1142 -- Replace_Element --
|
|
|
1143 ---------------------
|
|
|
1144
|
|
|
1145 procedure Replace_Element
|
|
|
1146 (Container : in out Map;
|
|
|
1147 Position : Cursor;
|
|
|
1148 New_Item : Element_Type)
|
|
|
1149 is
|
|
|
1150 begin
|
|
|
1151 if Checks and then Position.Node = null then
|
|
|
1152 raise Constraint_Error with
|
|
|
1153 "Position cursor of Replace_Element equals No_Element";
|
|
|
1154 end if;
|
|
|
1155
|
|
|
1156 if Checks and then
|
|
|
1157 (Position.Node.Key = null or else Position.Node.Element = null)
|
|
|
1158 then
|
|
|
1159 raise Program_Error with
|
|
|
1160 "Position cursor of Replace_Element is bad";
|
|
|
1161 end if;
|
|
|
1162
|
|
|
1163 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1164 then
|
|
|
1165 raise Program_Error with
|
|
|
1166 "Position cursor of Replace_Element designates wrong map";
|
|
|
1167 end if;
|
|
|
1168
|
|
|
1169 TE_Check (Position.Container.HT.TC);
|
|
|
1170
|
|
|
1171 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
|
|
|
1172
|
|
|
1173 declare
|
|
|
1174 X : Element_Access := Position.Node.Element;
|
|
|
1175
|
|
|
1176 -- The element allocator may need an accessibility check in the case
|
|
|
1177 -- the actual type is class-wide or has access discriminants (see
|
|
|
1178 -- RM 4.8(10.1) and AI12-0035).
|
|
|
1179
|
|
|
1180 pragma Unsuppress (Accessibility_Check);
|
|
|
1181
|
|
|
1182 begin
|
|
|
1183 Position.Node.Element := new Element_Type'(New_Item);
|
|
|
1184 Free_Element (X);
|
|
|
1185 end;
|
|
|
1186 end Replace_Element;
|
|
|
1187
|
|
|
1188 ----------------------
|
|
|
1189 -- Reserve_Capacity --
|
|
|
1190 ----------------------
|
|
|
1191
|
|
|
1192 procedure Reserve_Capacity
|
|
|
1193 (Container : in out Map;
|
|
|
1194 Capacity : Count_Type)
|
|
|
1195 is
|
|
|
1196 begin
|
|
|
1197 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
|
|
|
1198 end Reserve_Capacity;
|
|
|
1199
|
|
|
1200 --------------
|
|
|
1201 -- Set_Next --
|
|
|
1202 --------------
|
|
|
1203
|
|
|
1204 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
|
|
|
1205 begin
|
|
|
1206 Node.Next := Next;
|
|
|
1207 end Set_Next;
|
|
|
1208
|
|
|
1209 --------------------
|
|
|
1210 -- Update_Element --
|
|
|
1211 --------------------
|
|
|
1212
|
|
|
1213 procedure Update_Element
|
|
|
1214 (Container : in out Map;
|
|
|
1215 Position : Cursor;
|
|
|
1216 Process : not null access procedure (Key : Key_Type;
|
|
|
1217 Element : in out Element_Type))
|
|
|
1218 is
|
|
|
1219 begin
|
|
|
1220 if Checks and then Position.Node = null then
|
|
|
1221 raise Constraint_Error with
|
|
|
1222 "Position cursor of Update_Element equals No_Element";
|
|
|
1223 end if;
|
|
|
1224
|
|
|
1225 if Checks and then
|
|
|
1226 (Position.Node.Key = null or else Position.Node.Element = null)
|
|
|
1227 then
|
|
|
1228 raise Program_Error with
|
|
|
1229 "Position cursor of Update_Element is bad";
|
|
|
1230 end if;
|
|
|
1231
|
|
|
1232 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1233 then
|
|
|
1234 raise Program_Error with
|
|
|
1235 "Position cursor of Update_Element designates wrong map";
|
|
|
1236 end if;
|
|
|
1237
|
|
|
1238 pragma Assert (Vet (Position), "bad cursor in Update_Element");
|
|
|
1239
|
|
|
1240 declare
|
|
|
1241 HT : Hash_Table_Type renames Container.HT;
|
|
|
1242 Lock : With_Lock (HT.TC'Unrestricted_Access);
|
|
|
1243 K : Key_Type renames Position.Node.Key.all;
|
|
|
1244 E : Element_Type renames Position.Node.Element.all;
|
|
|
1245 begin
|
|
|
1246 Process (K, E);
|
|
|
1247 end;
|
|
|
1248 end Update_Element;
|
|
|
1249
|
|
|
1250 ---------
|
|
|
1251 -- Vet --
|
|
|
1252 ---------
|
|
|
1253
|
|
|
1254 function Vet (Position : Cursor) return Boolean is
|
|
|
1255 begin
|
|
|
1256 if Position.Node = null then
|
|
|
1257 return Position.Container = null;
|
|
|
1258 end if;
|
|
|
1259
|
|
|
1260 if Position.Container = null then
|
|
|
1261 return False;
|
|
|
1262 end if;
|
|
|
1263
|
|
|
1264 if Position.Node.Next = Position.Node then
|
|
|
1265 return False;
|
|
|
1266 end if;
|
|
|
1267
|
|
|
1268 if Position.Node.Key = null then
|
|
|
1269 return False;
|
|
|
1270 end if;
|
|
|
1271
|
|
|
1272 if Position.Node.Element = null then
|
|
|
1273 return False;
|
|
|
1274 end if;
|
|
|
1275
|
|
|
1276 declare
|
|
|
1277 HT : Hash_Table_Type renames Position.Container.HT;
|
|
|
1278 X : Node_Access;
|
|
|
1279
|
|
|
1280 begin
|
|
|
1281 if HT.Length = 0 then
|
|
|
1282 return False;
|
|
|
1283 end if;
|
|
|
1284
|
|
|
1285 if HT.Buckets = null
|
|
|
1286 or else HT.Buckets'Length = 0
|
|
|
1287 then
|
|
|
1288 return False;
|
|
|
1289 end if;
|
|
|
1290
|
|
|
1291 X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key.all));
|
|
|
1292
|
|
|
1293 for J in 1 .. HT.Length loop
|
|
|
1294 if X = Position.Node then
|
|
|
1295 return True;
|
|
|
1296 end if;
|
|
|
1297
|
|
|
1298 if X = null then
|
|
|
1299 return False;
|
|
|
1300 end if;
|
|
|
1301
|
|
|
1302 if X = X.Next then -- to prevent unnecessary looping
|
|
|
1303 return False;
|
|
|
1304 end if;
|
|
|
1305
|
|
|
1306 X := X.Next;
|
|
|
1307 end loop;
|
|
|
1308
|
|
|
1309 return False;
|
|
|
1310 end;
|
|
|
1311 end Vet;
|
|
|
1312
|
|
|
1313 -----------
|
|
|
1314 -- Write --
|
|
|
1315 -----------
|
|
|
1316
|
|
|
1317 procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
|
|
|
1318
|
|
|
1319 procedure Write
|
|
|
1320 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1321 Container : Map)
|
|
|
1322 is
|
|
|
1323 begin
|
|
|
1324 Write_Nodes (Stream, Container.HT);
|
|
|
1325 end Write;
|
|
|
1326
|
|
|
1327 procedure Write
|
|
|
1328 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1329 Item : Cursor)
|
|
|
1330 is
|
|
|
1331 begin
|
|
|
1332 raise Program_Error with "attempt to stream map cursor";
|
|
|
1333 end Write;
|
|
|
1334
|
|
|
1335 procedure Write
|
|
|
1336 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1337 Item : Reference_Type)
|
|
|
1338 is
|
|
|
1339 begin
|
|
|
1340 raise Program_Error with "attempt to stream reference";
|
|
|
1341 end Write;
|
|
|
1342
|
|
|
1343 procedure Write
|
|
|
1344 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1345 Item : Constant_Reference_Type)
|
|
|
1346 is
|
|
|
1347 begin
|
|
|
1348 raise Program_Error with "attempt to stream reference";
|
|
|
1349 end Write;
|
|
|
1350
|
|
|
1351 ----------------
|
|
|
1352 -- Write_Node --
|
|
|
1353 ----------------
|
|
|
1354
|
|
|
1355 procedure Write_Node
|
|
|
1356 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1357 Node : Node_Access)
|
|
|
1358 is
|
|
|
1359 begin
|
|
|
1360 Key_Type'Output (Stream, Node.Key.all);
|
|
|
1361 Element_Type'Output (Stream, Node.Element.all);
|
|
|
1362 end Write_Node;
|
|
|
1363
|
|
|
1364 end Ada.Containers.Indefinite_Hashed_Maps;
|
