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