111
|
1 ------------------------------------------------------------------------------
|
|
2 -- --
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
4 -- --
|
|
5 -- ADA.CONTAINERS.INDEFINITE_HASHED_SETS --
|
|
6 -- --
|
|
7 -- B o d y --
|
|
8 -- --
|
131
|
9 -- Copyright (C) 2004-2018, Free Software Foundation, Inc. --
|
111
|
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.Unchecked_Deallocation;
|
|
31
|
|
32 with Ada.Containers.Hash_Tables.Generic_Operations;
|
|
33 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
|
|
34
|
|
35 with Ada.Containers.Hash_Tables.Generic_Keys;
|
|
36 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
|
|
37
|
|
38 with Ada.Containers.Helpers; use Ada.Containers.Helpers;
|
|
39
|
|
40 with Ada.Containers.Prime_Numbers;
|
|
41
|
|
42 with System; use type System.Address;
|
|
43
|
|
44 package body Ada.Containers.Indefinite_Hashed_Sets is
|
|
45
|
|
46 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
|
|
47 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
|
|
48 -- See comment in Ada.Containers.Helpers
|
|
49
|
|
50 -----------------------
|
|
51 -- Local Subprograms --
|
|
52 -----------------------
|
|
53
|
|
54 procedure Assign (Node : Node_Access; Item : Element_Type);
|
|
55 pragma Inline (Assign);
|
|
56
|
|
57 function Copy_Node (Source : Node_Access) return Node_Access;
|
|
58 pragma Inline (Copy_Node);
|
|
59
|
|
60 function Equivalent_Keys
|
|
61 (Key : Element_Type;
|
|
62 Node : Node_Access) return Boolean;
|
|
63 pragma Inline (Equivalent_Keys);
|
|
64
|
|
65 function Find_Equal_Key
|
|
66 (R_HT : Hash_Table_Type;
|
|
67 L_Node : Node_Access) return Boolean;
|
|
68
|
|
69 function Find_Equivalent_Key
|
|
70 (R_HT : Hash_Table_Type;
|
|
71 L_Node : Node_Access) return Boolean;
|
|
72
|
|
73 procedure Free (X : in out Node_Access);
|
|
74
|
|
75 function Hash_Node (Node : Node_Access) return Hash_Type;
|
|
76 pragma Inline (Hash_Node);
|
|
77
|
|
78 procedure Insert
|
|
79 (HT : in out Hash_Table_Type;
|
|
80 New_Item : Element_Type;
|
|
81 Node : out Node_Access;
|
|
82 Inserted : out Boolean);
|
|
83
|
|
84 function Is_In
|
|
85 (HT : aliased in out Hash_Table_Type;
|
|
86 Key : Node_Access) return Boolean;
|
|
87 pragma Inline (Is_In);
|
|
88
|
|
89 function Next (Node : Node_Access) return Node_Access;
|
|
90 pragma Inline (Next);
|
|
91
|
|
92 function Read_Node (Stream : not null access Root_Stream_Type'Class)
|
|
93 return Node_Access;
|
|
94 pragma Inline (Read_Node);
|
|
95
|
|
96 procedure Set_Next (Node : Node_Access; Next : Node_Access);
|
|
97 pragma Inline (Set_Next);
|
|
98
|
|
99 function Vet (Position : Cursor) return Boolean;
|
|
100
|
|
101 procedure Write_Node
|
|
102 (Stream : not null access Root_Stream_Type'Class;
|
|
103 Node : Node_Access);
|
|
104 pragma Inline (Write_Node);
|
|
105
|
|
106 --------------------------
|
|
107 -- Local Instantiations --
|
|
108 --------------------------
|
|
109
|
|
110 procedure Free_Element is
|
|
111 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
|
|
112
|
|
113 package HT_Ops is new Hash_Tables.Generic_Operations
|
|
114 (HT_Types => HT_Types,
|
|
115 Hash_Node => Hash_Node,
|
|
116 Next => Next,
|
|
117 Set_Next => Set_Next,
|
|
118 Copy_Node => Copy_Node,
|
|
119 Free => Free);
|
|
120
|
|
121 package Element_Keys is new Hash_Tables.Generic_Keys
|
|
122 (HT_Types => HT_Types,
|
|
123 Next => Next,
|
|
124 Set_Next => Set_Next,
|
|
125 Key_Type => Element_Type,
|
|
126 Hash => Hash,
|
|
127 Equivalent_Keys => Equivalent_Keys);
|
|
128
|
|
129 function Is_Equal is
|
|
130 new HT_Ops.Generic_Equal (Find_Equal_Key);
|
|
131
|
|
132 function Is_Equivalent is
|
|
133 new HT_Ops.Generic_Equal (Find_Equivalent_Key);
|
|
134
|
|
135 procedure Read_Nodes is
|
|
136 new HT_Ops.Generic_Read (Read_Node);
|
|
137
|
|
138 procedure Replace_Element is
|
|
139 new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
|
|
140
|
|
141 procedure Write_Nodes is
|
|
142 new HT_Ops.Generic_Write (Write_Node);
|
|
143
|
|
144 ---------
|
|
145 -- "=" --
|
|
146 ---------
|
|
147
|
|
148 function "=" (Left, Right : Set) return Boolean is
|
|
149 begin
|
|
150 return Is_Equal (Left.HT, Right.HT);
|
|
151 end "=";
|
|
152
|
|
153 ------------
|
|
154 -- Adjust --
|
|
155 ------------
|
|
156
|
|
157 procedure Adjust (Container : in out Set) is
|
|
158 begin
|
|
159 HT_Ops.Adjust (Container.HT);
|
|
160 end Adjust;
|
|
161
|
|
162 ------------
|
|
163 -- Assign --
|
|
164 ------------
|
|
165
|
|
166 procedure Assign (Node : Node_Access; Item : Element_Type) is
|
|
167 X : Element_Access := Node.Element;
|
|
168
|
|
169 -- The element allocator may need an accessibility check in the case the
|
|
170 -- actual type is class-wide or has access discriminants (RM 4.8(10.1)
|
|
171 -- and AI12-0035).
|
|
172
|
|
173 pragma Unsuppress (Accessibility_Check);
|
|
174
|
|
175 begin
|
|
176 Node.Element := new Element_Type'(Item);
|
|
177 Free_Element (X);
|
|
178 end Assign;
|
|
179
|
|
180 procedure Assign (Target : in out Set; Source : Set) is
|
|
181 begin
|
|
182 if Target'Address = Source'Address then
|
|
183 return;
|
|
184 else
|
|
185 Target.Clear;
|
|
186 Target.Union (Source);
|
|
187 end if;
|
|
188 end Assign;
|
|
189
|
|
190 --------------
|
|
191 -- Capacity --
|
|
192 --------------
|
|
193
|
|
194 function Capacity (Container : Set) return Count_Type is
|
|
195 begin
|
|
196 return HT_Ops.Capacity (Container.HT);
|
|
197 end Capacity;
|
|
198
|
|
199 -----------
|
|
200 -- Clear --
|
|
201 -----------
|
|
202
|
|
203 procedure Clear (Container : in out Set) is
|
|
204 begin
|
|
205 HT_Ops.Clear (Container.HT);
|
|
206 end Clear;
|
|
207
|
|
208 ------------------------
|
|
209 -- Constant_Reference --
|
|
210 ------------------------
|
|
211
|
|
212 function Constant_Reference
|
|
213 (Container : aliased Set;
|
|
214 Position : Cursor) return Constant_Reference_Type
|
|
215 is
|
|
216 begin
|
|
217 if Checks and then Position.Container = null then
|
|
218 raise Constraint_Error with "Position cursor has no element";
|
|
219 end if;
|
|
220
|
|
221 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
222 then
|
|
223 raise Program_Error with
|
|
224 "Position cursor designates wrong container";
|
|
225 end if;
|
|
226
|
|
227 if Checks and then Position.Node.Element = null then
|
|
228 raise Program_Error with "Node has no element";
|
|
229 end if;
|
|
230
|
|
231 pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
|
|
232
|
|
233 declare
|
|
234 HT : Hash_Table_Type renames Position.Container.all.HT;
|
|
235 TC : constant Tamper_Counts_Access :=
|
|
236 HT.TC'Unrestricted_Access;
|
|
237 begin
|
|
238 return R : constant Constant_Reference_Type :=
|
|
239 (Element => Position.Node.Element.all'Access,
|
|
240 Control => (Controlled with TC))
|
|
241 do
|
|
242 Lock (TC.all);
|
|
243 end return;
|
|
244 end;
|
|
245 end Constant_Reference;
|
|
246
|
|
247 --------------
|
|
248 -- Contains --
|
|
249 --------------
|
|
250
|
|
251 function Contains (Container : Set; Item : Element_Type) return Boolean is
|
|
252 begin
|
|
253 return Find (Container, Item) /= No_Element;
|
|
254 end Contains;
|
|
255
|
|
256 ----------
|
|
257 -- Copy --
|
|
258 ----------
|
|
259
|
|
260 function Copy
|
|
261 (Source : Set;
|
|
262 Capacity : Count_Type := 0) return Set
|
|
263 is
|
|
264 C : Count_Type;
|
|
265
|
|
266 begin
|
|
267 if Capacity < Source.Length then
|
|
268 if Checks and then Capacity /= 0 then
|
|
269 raise Capacity_Error
|
|
270 with "Requested capacity is less than Source length";
|
|
271 end if;
|
|
272
|
|
273 C := Source.Length;
|
|
274 else
|
|
275 C := Capacity;
|
|
276 end if;
|
|
277
|
|
278 return Target : Set do
|
|
279 Target.Reserve_Capacity (C);
|
|
280 Target.Assign (Source);
|
|
281 end return;
|
|
282 end Copy;
|
|
283
|
|
284 ---------------
|
|
285 -- Copy_Node --
|
|
286 ---------------
|
|
287
|
|
288 function Copy_Node (Source : Node_Access) return Node_Access is
|
|
289 E : Element_Access := new Element_Type'(Source.Element.all);
|
|
290 begin
|
|
291 return new Node_Type'(Element => E, Next => null);
|
|
292 exception
|
|
293 when others =>
|
|
294 Free_Element (E);
|
|
295 raise;
|
|
296 end Copy_Node;
|
|
297
|
|
298 ------------
|
|
299 -- Delete --
|
|
300 ------------
|
|
301
|
|
302 procedure Delete
|
|
303 (Container : in out Set;
|
|
304 Item : Element_Type)
|
|
305 is
|
|
306 X : Node_Access;
|
|
307
|
|
308 begin
|
|
309 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
|
|
310
|
|
311 if Checks and then X = null then
|
|
312 raise Constraint_Error with "attempt to delete element not in set";
|
|
313 end if;
|
|
314
|
|
315 Free (X);
|
|
316 end Delete;
|
|
317
|
|
318 procedure Delete
|
|
319 (Container : in out Set;
|
|
320 Position : in out Cursor)
|
|
321 is
|
|
322 begin
|
|
323 if Checks and then Position.Node = null then
|
|
324 raise Constraint_Error with "Position cursor equals No_Element";
|
|
325 end if;
|
|
326
|
|
327 if Checks and then Position.Node.Element = null then
|
|
328 raise Program_Error with "Position cursor is bad";
|
|
329 end if;
|
|
330
|
|
331 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
332 then
|
|
333 raise Program_Error with "Position cursor designates wrong set";
|
|
334 end if;
|
|
335
|
|
336 TC_Check (Container.HT.TC);
|
|
337
|
|
338 pragma Assert (Vet (Position), "Position cursor is bad");
|
|
339
|
|
340 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
|
|
341
|
|
342 Free (Position.Node);
|
|
343 Position.Container := null;
|
|
344 end Delete;
|
|
345
|
|
346 ----------------
|
|
347 -- Difference --
|
|
348 ----------------
|
|
349
|
|
350 procedure Difference
|
|
351 (Target : in out Set;
|
|
352 Source : Set)
|
|
353 is
|
|
354 Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT;
|
|
355 Tgt_Node : Node_Access;
|
|
356
|
|
357 begin
|
|
358 if Target'Address = Source'Address then
|
|
359 Clear (Target);
|
|
360 return;
|
|
361 end if;
|
|
362
|
|
363 if Src_HT.Length = 0 then
|
|
364 return;
|
|
365 end if;
|
|
366
|
|
367 TC_Check (Target.HT.TC);
|
|
368
|
|
369 if Src_HT.Length < Target.HT.Length then
|
|
370 declare
|
|
371 Src_Node : Node_Access;
|
|
372
|
|
373 begin
|
|
374 Src_Node := HT_Ops.First (Src_HT);
|
|
375 while Src_Node /= null loop
|
|
376 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
|
|
377
|
|
378 if Tgt_Node /= null then
|
|
379 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
|
|
380 Free (Tgt_Node);
|
|
381 end if;
|
|
382
|
|
383 Src_Node := HT_Ops.Next (Src_HT, Src_Node);
|
|
384 end loop;
|
|
385 end;
|
|
386
|
|
387 else
|
|
388 Tgt_Node := HT_Ops.First (Target.HT);
|
|
389 while Tgt_Node /= null loop
|
|
390 if Is_In (Src_HT, Tgt_Node) then
|
|
391 declare
|
|
392 X : Node_Access := Tgt_Node;
|
|
393 begin
|
|
394 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
|
|
395 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
|
|
396 Free (X);
|
|
397 end;
|
|
398
|
|
399 else
|
|
400 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
|
|
401 end if;
|
|
402 end loop;
|
|
403 end if;
|
|
404 end Difference;
|
|
405
|
|
406 function Difference (Left, Right : Set) return Set is
|
|
407 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
|
|
408 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
|
|
409 Buckets : HT_Types.Buckets_Access;
|
|
410 Length : Count_Type;
|
|
411
|
|
412 begin
|
|
413 if Left'Address = Right'Address then
|
|
414 return Empty_Set;
|
|
415 end if;
|
|
416
|
|
417 if Left.Length = 0 then
|
|
418 return Empty_Set;
|
|
419 end if;
|
|
420
|
|
421 if Right.Length = 0 then
|
|
422 return Left;
|
|
423 end if;
|
|
424
|
|
425 declare
|
|
426 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
|
|
427 begin
|
|
428 Buckets := HT_Ops.New_Buckets (Length => Size);
|
|
429 end;
|
|
430
|
|
431 Length := 0;
|
|
432
|
|
433 Iterate_Left : declare
|
|
434 procedure Process (L_Node : Node_Access);
|
|
435
|
|
436 procedure Iterate is
|
|
437 new HT_Ops.Generic_Iteration (Process);
|
|
438
|
|
439 -------------
|
|
440 -- Process --
|
|
441 -------------
|
|
442
|
|
443 procedure Process (L_Node : Node_Access) is
|
|
444 begin
|
|
445 if not Is_In (Right_HT, L_Node) then
|
|
446 declare
|
|
447 -- Per AI05-0022, the container implementation is required
|
|
448 -- to detect element tampering by a generic actual
|
|
449 -- subprogram, hence the use of Checked_Index instead of a
|
|
450 -- simple invocation of generic formal Hash.
|
|
451
|
|
452 Indx : constant Hash_Type :=
|
|
453 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
|
|
454
|
|
455 Bucket : Node_Access renames Buckets (Indx);
|
|
456 Src : Element_Type renames L_Node.Element.all;
|
|
457 Tgt : Element_Access := new Element_Type'(Src);
|
|
458
|
|
459 begin
|
|
460 Bucket := new Node_Type'(Tgt, Bucket);
|
|
461
|
|
462 exception
|
|
463 when others =>
|
|
464 Free_Element (Tgt);
|
|
465 raise;
|
|
466 end;
|
|
467
|
|
468 Length := Length + 1;
|
|
469 end if;
|
|
470 end Process;
|
|
471
|
|
472 -- Start of processing for Iterate_Left
|
|
473
|
|
474 begin
|
|
475 Iterate (Left.HT);
|
|
476
|
|
477 exception
|
|
478 when others =>
|
|
479 HT_Ops.Free_Hash_Table (Buckets);
|
|
480 raise;
|
|
481 end Iterate_Left;
|
|
482
|
|
483 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
|
|
484 end Difference;
|
|
485
|
|
486 -------------
|
|
487 -- Element --
|
|
488 -------------
|
|
489
|
|
490 function Element (Position : Cursor) return Element_Type is
|
|
491 begin
|
|
492 if Checks and then Position.Node = null then
|
|
493 raise Constraint_Error with "Position cursor of equals No_Element";
|
|
494 end if;
|
|
495
|
|
496 if Checks and then Position.Node.Element = null then
|
|
497 -- handle dangling reference
|
|
498 raise Program_Error with "Position cursor is bad";
|
|
499 end if;
|
|
500
|
|
501 pragma Assert (Vet (Position), "bad cursor in function Element");
|
|
502
|
|
503 return Position.Node.Element.all;
|
|
504 end Element;
|
|
505
|
|
506 ---------------------
|
|
507 -- Equivalent_Sets --
|
|
508 ---------------------
|
|
509
|
|
510 function Equivalent_Sets (Left, Right : Set) return Boolean is
|
|
511 begin
|
|
512 return Is_Equivalent (Left.HT, Right.HT);
|
|
513 end Equivalent_Sets;
|
|
514
|
|
515 -------------------------
|
|
516 -- Equivalent_Elements --
|
|
517 -------------------------
|
|
518
|
|
519 function Equivalent_Elements (Left, Right : Cursor) return Boolean is
|
|
520 begin
|
|
521 if Checks and then Left.Node = null then
|
|
522 raise Constraint_Error with
|
|
523 "Left cursor of Equivalent_Elements equals No_Element";
|
|
524 end if;
|
|
525
|
|
526 if Checks and then Right.Node = null then
|
|
527 raise Constraint_Error with
|
|
528 "Right cursor of Equivalent_Elements equals No_Element";
|
|
529 end if;
|
|
530
|
|
531 if Checks and then Left.Node.Element = null then
|
|
532 raise Program_Error with
|
|
533 "Left cursor of Equivalent_Elements is bad";
|
|
534 end if;
|
|
535
|
|
536 if Checks and then Right.Node.Element = null then
|
|
537 raise Program_Error with
|
|
538 "Right cursor of Equivalent_Elements is bad";
|
|
539 end if;
|
|
540
|
|
541 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
|
|
542 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
|
|
543
|
|
544 -- AI05-0022 requires that a container implementation detect element
|
|
545 -- tampering by a generic actual subprogram. However, the following case
|
|
546 -- falls outside the scope of that AI. Randy Brukardt explained on the
|
|
547 -- ARG list on 2013/02/07 that:
|
|
548
|
|
549 -- (Begin Quote):
|
|
550 -- But for an operation like "<" [the ordered set analog of
|
|
551 -- Equivalent_Elements], there is no need to "dereference" a cursor
|
|
552 -- after the call to the generic formal parameter function, so nothing
|
|
553 -- bad could happen if tampering is undetected. And the operation can
|
|
554 -- safely return a result without a problem even if an element is
|
|
555 -- deleted from the container.
|
|
556 -- (End Quote).
|
|
557
|
|
558 return Equivalent_Elements
|
|
559 (Left.Node.Element.all,
|
|
560 Right.Node.Element.all);
|
|
561 end Equivalent_Elements;
|
|
562
|
|
563 function Equivalent_Elements
|
|
564 (Left : Cursor;
|
|
565 Right : Element_Type) return Boolean
|
|
566 is
|
|
567 begin
|
|
568 if Checks and then Left.Node = null then
|
|
569 raise Constraint_Error with
|
|
570 "Left cursor of Equivalent_Elements equals No_Element";
|
|
571 end if;
|
|
572
|
|
573 if Checks and then Left.Node.Element = null then
|
|
574 raise Program_Error with
|
|
575 "Left cursor of Equivalent_Elements is bad";
|
|
576 end if;
|
|
577
|
|
578 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
|
|
579
|
|
580 return Equivalent_Elements (Left.Node.Element.all, Right);
|
|
581 end Equivalent_Elements;
|
|
582
|
|
583 function Equivalent_Elements
|
|
584 (Left : Element_Type;
|
|
585 Right : Cursor) return Boolean
|
|
586 is
|
|
587 begin
|
|
588 if Checks and then Right.Node = null then
|
|
589 raise Constraint_Error with
|
|
590 "Right cursor of Equivalent_Elements equals No_Element";
|
|
591 end if;
|
|
592
|
|
593 if Checks and then Right.Node.Element = null then
|
|
594 raise Program_Error with
|
|
595 "Right cursor of Equivalent_Elements is bad";
|
|
596 end if;
|
|
597
|
|
598 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
|
|
599
|
|
600 return Equivalent_Elements (Left, Right.Node.Element.all);
|
|
601 end Equivalent_Elements;
|
|
602
|
|
603 ---------------------
|
|
604 -- Equivalent_Keys --
|
|
605 ---------------------
|
|
606
|
|
607 function Equivalent_Keys
|
|
608 (Key : Element_Type;
|
|
609 Node : Node_Access) return Boolean
|
|
610 is
|
|
611 begin
|
|
612 return Equivalent_Elements (Key, Node.Element.all);
|
|
613 end Equivalent_Keys;
|
|
614
|
|
615 -------------
|
|
616 -- Exclude --
|
|
617 -------------
|
|
618
|
|
619 procedure Exclude
|
|
620 (Container : in out Set;
|
|
621 Item : Element_Type)
|
|
622 is
|
|
623 X : Node_Access;
|
|
624 begin
|
|
625 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
|
|
626 Free (X);
|
|
627 end Exclude;
|
|
628
|
|
629 --------------
|
|
630 -- Finalize --
|
|
631 --------------
|
|
632
|
|
633 procedure Finalize (Container : in out Set) is
|
|
634 begin
|
|
635 HT_Ops.Finalize (Container.HT);
|
|
636 end Finalize;
|
|
637
|
|
638 procedure Finalize (Object : in out Iterator) is
|
|
639 begin
|
|
640 if Object.Container /= null then
|
|
641 Unbusy (Object.Container.HT.TC);
|
|
642 end if;
|
|
643 end Finalize;
|
|
644
|
|
645 ----------
|
|
646 -- Find --
|
|
647 ----------
|
|
648
|
|
649 function Find
|
|
650 (Container : Set;
|
|
651 Item : Element_Type) return Cursor
|
|
652 is
|
|
653 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
|
|
654 Node : constant Node_Access := Element_Keys.Find (HT, Item);
|
|
655 begin
|
|
656 return (if Node = null then No_Element
|
|
657 else Cursor'(Container'Unrestricted_Access, Node));
|
|
658 end Find;
|
|
659
|
|
660 --------------------
|
|
661 -- Find_Equal_Key --
|
|
662 --------------------
|
|
663
|
|
664 function Find_Equal_Key
|
|
665 (R_HT : Hash_Table_Type;
|
|
666 L_Node : Node_Access) return Boolean
|
|
667 is
|
|
668 R_Index : constant Hash_Type :=
|
|
669 Element_Keys.Index (R_HT, L_Node.Element.all);
|
|
670
|
|
671 R_Node : Node_Access := R_HT.Buckets (R_Index);
|
|
672
|
|
673 begin
|
|
674 loop
|
|
675 if R_Node = null then
|
|
676 return False;
|
|
677 end if;
|
|
678
|
|
679 if L_Node.Element.all = R_Node.Element.all then
|
|
680 return True;
|
|
681 end if;
|
|
682
|
|
683 R_Node := Next (R_Node);
|
|
684 end loop;
|
|
685 end Find_Equal_Key;
|
|
686
|
|
687 -------------------------
|
|
688 -- Find_Equivalent_Key --
|
|
689 -------------------------
|
|
690
|
|
691 function Find_Equivalent_Key
|
|
692 (R_HT : Hash_Table_Type;
|
|
693 L_Node : Node_Access) return Boolean
|
|
694 is
|
|
695 R_Index : constant Hash_Type :=
|
|
696 Element_Keys.Index (R_HT, L_Node.Element.all);
|
|
697
|
|
698 R_Node : Node_Access := R_HT.Buckets (R_Index);
|
|
699
|
|
700 begin
|
|
701 loop
|
|
702 if R_Node = null then
|
|
703 return False;
|
|
704 end if;
|
|
705
|
|
706 if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
|
|
707 return True;
|
|
708 end if;
|
|
709
|
|
710 R_Node := Next (R_Node);
|
|
711 end loop;
|
|
712 end Find_Equivalent_Key;
|
|
713
|
|
714 -----------
|
|
715 -- First --
|
|
716 -----------
|
|
717
|
|
718 function First (Container : Set) return Cursor is
|
|
719 Node : constant Node_Access := HT_Ops.First (Container.HT);
|
|
720 begin
|
|
721 return (if Node = null then No_Element
|
|
722 else Cursor'(Container'Unrestricted_Access, Node));
|
|
723 end First;
|
|
724
|
|
725 function First (Object : Iterator) return Cursor is
|
|
726 begin
|
|
727 return Object.Container.First;
|
|
728 end First;
|
|
729
|
|
730 ----------
|
|
731 -- Free --
|
|
732 ----------
|
|
733
|
|
734 procedure Free (X : in out Node_Access) is
|
|
735 procedure Deallocate is
|
|
736 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
|
|
737
|
|
738 begin
|
|
739 if X = null then
|
|
740 return;
|
|
741 end if;
|
|
742
|
|
743 X.Next := X; -- detect mischief (in Vet)
|
|
744
|
|
745 begin
|
|
746 Free_Element (X.Element);
|
|
747
|
|
748 exception
|
|
749 when others =>
|
|
750 X.Element := null;
|
|
751 Deallocate (X);
|
|
752 raise;
|
|
753 end;
|
|
754
|
|
755 Deallocate (X);
|
|
756 end Free;
|
|
757
|
|
758 ------------------------
|
|
759 -- Get_Element_Access --
|
|
760 ------------------------
|
|
761
|
|
762 function Get_Element_Access
|
|
763 (Position : Cursor) return not null Element_Access is
|
|
764 begin
|
|
765 return Position.Node.Element;
|
|
766 end Get_Element_Access;
|
|
767
|
|
768 -----------------
|
|
769 -- Has_Element --
|
|
770 -----------------
|
|
771
|
|
772 function Has_Element (Position : Cursor) return Boolean is
|
|
773 begin
|
|
774 pragma Assert (Vet (Position), "bad cursor in Has_Element");
|
|
775 return Position.Node /= null;
|
|
776 end Has_Element;
|
|
777
|
|
778 ---------------
|
|
779 -- Hash_Node --
|
|
780 ---------------
|
|
781
|
|
782 function Hash_Node (Node : Node_Access) return Hash_Type is
|
|
783 begin
|
|
784 return Hash (Node.Element.all);
|
|
785 end Hash_Node;
|
|
786
|
|
787 -------------
|
|
788 -- Include --
|
|
789 -------------
|
|
790
|
|
791 procedure Include
|
|
792 (Container : in out Set;
|
|
793 New_Item : Element_Type)
|
|
794 is
|
|
795 Position : Cursor;
|
|
796 Inserted : Boolean;
|
|
797
|
|
798 X : Element_Access;
|
|
799
|
|
800 begin
|
|
801 Insert (Container, New_Item, Position, Inserted);
|
|
802
|
|
803 if not Inserted then
|
|
804 TE_Check (Container.HT.TC);
|
|
805
|
|
806 X := Position.Node.Element;
|
|
807
|
|
808 declare
|
|
809 -- The element allocator may need an accessibility check in the
|
|
810 -- case the actual type is class-wide or has access discriminants
|
|
811 -- (see RM 4.8(10.1) and AI12-0035).
|
|
812
|
|
813 pragma Unsuppress (Accessibility_Check);
|
|
814
|
|
815 begin
|
|
816 Position.Node.Element := new Element_Type'(New_Item);
|
|
817 end;
|
|
818
|
|
819 Free_Element (X);
|
|
820 end if;
|
|
821 end Include;
|
|
822
|
|
823 ------------
|
|
824 -- Insert --
|
|
825 ------------
|
|
826
|
|
827 procedure Insert
|
|
828 (Container : in out Set;
|
|
829 New_Item : Element_Type;
|
|
830 Position : out Cursor;
|
|
831 Inserted : out Boolean)
|
|
832 is
|
|
833 begin
|
|
834 Insert (Container.HT, New_Item, Position.Node, Inserted);
|
|
835 Position.Container := Container'Unchecked_Access;
|
|
836 end Insert;
|
|
837
|
|
838 procedure Insert
|
|
839 (Container : in out Set;
|
|
840 New_Item : Element_Type)
|
|
841 is
|
|
842 Position : Cursor;
|
|
843 pragma Unreferenced (Position);
|
|
844
|
|
845 Inserted : Boolean;
|
|
846
|
|
847 begin
|
|
848 Insert (Container, New_Item, Position, Inserted);
|
|
849
|
|
850 if Checks and then not Inserted then
|
|
851 raise Constraint_Error with
|
|
852 "attempt to insert element already in set";
|
|
853 end if;
|
|
854 end Insert;
|
|
855
|
|
856 procedure Insert
|
|
857 (HT : in out Hash_Table_Type;
|
|
858 New_Item : Element_Type;
|
|
859 Node : out Node_Access;
|
|
860 Inserted : out Boolean)
|
|
861 is
|
|
862 function New_Node (Next : Node_Access) return Node_Access;
|
|
863 pragma Inline (New_Node);
|
|
864
|
|
865 procedure Local_Insert is
|
|
866 new Element_Keys.Generic_Conditional_Insert (New_Node);
|
|
867
|
|
868 --------------
|
|
869 -- New_Node --
|
|
870 --------------
|
|
871
|
|
872 function New_Node (Next : Node_Access) return Node_Access is
|
|
873
|
|
874 -- The element allocator may need an accessibility check in the case
|
|
875 -- the actual type is class-wide or has access discriminants (see
|
|
876 -- RM 4.8(10.1) and AI12-0035).
|
|
877
|
|
878 pragma Unsuppress (Accessibility_Check);
|
|
879
|
|
880 Element : Element_Access := new Element_Type'(New_Item);
|
|
881
|
|
882 begin
|
|
883 return new Node_Type'(Element, Next);
|
|
884
|
|
885 exception
|
|
886 when others =>
|
|
887 Free_Element (Element);
|
|
888 raise;
|
|
889 end New_Node;
|
|
890
|
|
891 -- Start of processing for Insert
|
|
892
|
|
893 begin
|
|
894 if HT_Ops.Capacity (HT) = 0 then
|
|
895 HT_Ops.Reserve_Capacity (HT, 1);
|
|
896 end if;
|
|
897
|
|
898 Local_Insert (HT, New_Item, Node, Inserted);
|
|
899
|
|
900 if Inserted and then HT.Length > HT_Ops.Capacity (HT) then
|
|
901 HT_Ops.Reserve_Capacity (HT, HT.Length);
|
|
902 end if;
|
|
903 end Insert;
|
|
904
|
|
905 ------------------
|
|
906 -- Intersection --
|
|
907 ------------------
|
|
908
|
|
909 procedure Intersection
|
|
910 (Target : in out Set;
|
|
911 Source : Set)
|
|
912 is
|
|
913 Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT;
|
|
914 Tgt_Node : Node_Access;
|
|
915
|
|
916 begin
|
|
917 if Target'Address = Source'Address then
|
|
918 return;
|
|
919 end if;
|
|
920
|
|
921 if Source.Length = 0 then
|
|
922 Clear (Target);
|
|
923 return;
|
|
924 end if;
|
|
925
|
|
926 TC_Check (Target.HT.TC);
|
|
927
|
|
928 Tgt_Node := HT_Ops.First (Target.HT);
|
|
929 while Tgt_Node /= null loop
|
|
930 if Is_In (Src_HT, Tgt_Node) then
|
|
931 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
|
|
932
|
|
933 else
|
|
934 declare
|
|
935 X : Node_Access := Tgt_Node;
|
|
936 begin
|
|
937 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
|
|
938 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
|
|
939 Free (X);
|
|
940 end;
|
|
941 end if;
|
|
942 end loop;
|
|
943 end Intersection;
|
|
944
|
|
945 function Intersection (Left, Right : Set) return Set is
|
|
946 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
|
|
947 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
|
|
948 Buckets : HT_Types.Buckets_Access;
|
|
949 Length : Count_Type;
|
|
950
|
|
951 begin
|
|
952 if Left'Address = Right'Address then
|
|
953 return Left;
|
|
954 end if;
|
|
955
|
|
956 Length := Count_Type'Min (Left.Length, Right.Length);
|
|
957
|
|
958 if Length = 0 then
|
|
959 return Empty_Set;
|
|
960 end if;
|
|
961
|
|
962 declare
|
|
963 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
|
|
964 begin
|
|
965 Buckets := HT_Ops.New_Buckets (Length => Size);
|
|
966 end;
|
|
967
|
|
968 Length := 0;
|
|
969
|
|
970 Iterate_Left : declare
|
|
971 procedure Process (L_Node : Node_Access);
|
|
972
|
|
973 procedure Iterate is
|
|
974 new HT_Ops.Generic_Iteration (Process);
|
|
975
|
|
976 -------------
|
|
977 -- Process --
|
|
978 -------------
|
|
979
|
|
980 procedure Process (L_Node : Node_Access) is
|
|
981 begin
|
|
982 if Is_In (Right_HT, L_Node) then
|
|
983 declare
|
|
984 -- Per AI05-0022, the container implementation is required
|
|
985 -- to detect element tampering by a generic actual
|
|
986 -- subprogram, hence the use of Checked_Index instead of a
|
|
987 -- simple invocation of generic formal Hash.
|
|
988
|
|
989 Indx : constant Hash_Type :=
|
|
990 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
|
|
991
|
|
992 Bucket : Node_Access renames Buckets (Indx);
|
|
993
|
|
994 Src : Element_Type renames L_Node.Element.all;
|
|
995 Tgt : Element_Access := new Element_Type'(Src);
|
|
996
|
|
997 begin
|
|
998 Bucket := new Node_Type'(Tgt, Bucket);
|
|
999
|
|
1000 exception
|
|
1001 when others =>
|
|
1002 Free_Element (Tgt);
|
|
1003 raise;
|
|
1004 end;
|
|
1005
|
|
1006 Length := Length + 1;
|
|
1007 end if;
|
|
1008 end Process;
|
|
1009
|
|
1010 -- Start of processing for Iterate_Left
|
|
1011
|
|
1012 begin
|
|
1013 Iterate (Left.HT);
|
|
1014
|
|
1015 exception
|
|
1016 when others =>
|
|
1017 HT_Ops.Free_Hash_Table (Buckets);
|
|
1018 raise;
|
|
1019 end Iterate_Left;
|
|
1020
|
|
1021 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
|
|
1022 end Intersection;
|
|
1023
|
|
1024 --------------
|
|
1025 -- Is_Empty --
|
|
1026 --------------
|
|
1027
|
|
1028 function Is_Empty (Container : Set) return Boolean is
|
|
1029 begin
|
|
1030 return Container.HT.Length = 0;
|
|
1031 end Is_Empty;
|
|
1032
|
|
1033 -----------
|
|
1034 -- Is_In --
|
|
1035 -----------
|
|
1036
|
|
1037 function Is_In
|
|
1038 (HT : aliased in out Hash_Table_Type;
|
|
1039 Key : Node_Access) return Boolean
|
|
1040 is
|
|
1041 begin
|
|
1042 return Element_Keys.Find (HT, Key.Element.all) /= null;
|
|
1043 end Is_In;
|
|
1044
|
|
1045 ---------------
|
|
1046 -- Is_Subset --
|
|
1047 ---------------
|
|
1048
|
|
1049 function Is_Subset
|
|
1050 (Subset : Set;
|
|
1051 Of_Set : Set) return Boolean
|
|
1052 is
|
|
1053 Subset_HT : Hash_Table_Type renames Subset'Unrestricted_Access.HT;
|
|
1054 Of_Set_HT : Hash_Table_Type renames Of_Set'Unrestricted_Access.HT;
|
|
1055 Subset_Node : Node_Access;
|
|
1056
|
|
1057 begin
|
|
1058 if Subset'Address = Of_Set'Address then
|
|
1059 return True;
|
|
1060 end if;
|
|
1061
|
|
1062 if Subset.Length > Of_Set.Length then
|
|
1063 return False;
|
|
1064 end if;
|
|
1065
|
|
1066 Subset_Node := HT_Ops.First (Subset_HT);
|
|
1067 while Subset_Node /= null loop
|
|
1068 if not Is_In (Of_Set_HT, Subset_Node) then
|
|
1069 return False;
|
|
1070 end if;
|
|
1071
|
|
1072 Subset_Node := HT_Ops.Next (Subset_HT, Subset_Node);
|
|
1073 end loop;
|
|
1074
|
|
1075 return True;
|
|
1076 end Is_Subset;
|
|
1077
|
|
1078 -------------
|
|
1079 -- Iterate --
|
|
1080 -------------
|
|
1081
|
|
1082 procedure Iterate
|
|
1083 (Container : Set;
|
|
1084 Process : not null access procedure (Position : Cursor))
|
|
1085 is
|
|
1086 procedure Process_Node (Node : Node_Access);
|
|
1087 pragma Inline (Process_Node);
|
|
1088
|
|
1089 procedure Iterate is
|
|
1090 new HT_Ops.Generic_Iteration (Process_Node);
|
|
1091
|
|
1092 ------------------
|
|
1093 -- Process_Node --
|
|
1094 ------------------
|
|
1095
|
|
1096 procedure Process_Node (Node : Node_Access) is
|
|
1097 begin
|
|
1098 Process (Cursor'(Container'Unrestricted_Access, Node));
|
|
1099 end Process_Node;
|
|
1100
|
|
1101 Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
|
|
1102
|
|
1103 -- Start of processing for Iterate
|
|
1104
|
|
1105 begin
|
|
1106 Iterate (Container.HT);
|
|
1107 end Iterate;
|
|
1108
|
|
1109 function Iterate (Container : Set)
|
|
1110 return Set_Iterator_Interfaces.Forward_Iterator'Class
|
|
1111 is
|
|
1112 begin
|
|
1113 return It : constant Iterator :=
|
|
1114 Iterator'(Limited_Controlled with
|
|
1115 Container => Container'Unrestricted_Access)
|
|
1116 do
|
|
1117 Busy (Container.HT.TC'Unrestricted_Access.all);
|
|
1118 end return;
|
|
1119 end Iterate;
|
|
1120
|
|
1121 ------------
|
|
1122 -- Length --
|
|
1123 ------------
|
|
1124
|
|
1125 function Length (Container : Set) return Count_Type is
|
|
1126 begin
|
|
1127 return Container.HT.Length;
|
|
1128 end Length;
|
|
1129
|
|
1130 ----------
|
|
1131 -- Move --
|
|
1132 ----------
|
|
1133
|
|
1134 procedure Move (Target : in out Set; Source : in out Set) is
|
|
1135 begin
|
|
1136 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
|
|
1137 end Move;
|
|
1138
|
|
1139 ----------
|
|
1140 -- Next --
|
|
1141 ----------
|
|
1142
|
|
1143 function Next (Node : Node_Access) return Node_Access is
|
|
1144 begin
|
|
1145 return Node.Next;
|
|
1146 end Next;
|
|
1147
|
|
1148 function Next (Position : Cursor) return Cursor is
|
|
1149 begin
|
|
1150 if Position.Node = null then
|
|
1151 return No_Element;
|
|
1152 end if;
|
|
1153
|
|
1154 if Checks and then Position.Node.Element = null then
|
|
1155 raise Program_Error with "bad cursor in Next";
|
|
1156 end if;
|
|
1157
|
|
1158 pragma Assert (Vet (Position), "bad cursor in Next");
|
|
1159
|
|
1160 declare
|
|
1161 HT : Hash_Table_Type renames Position.Container.HT;
|
|
1162 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
|
|
1163 begin
|
|
1164 return (if Node = null then No_Element
|
|
1165 else Cursor'(Position.Container, Node));
|
|
1166 end;
|
|
1167 end Next;
|
|
1168
|
|
1169 procedure Next (Position : in out Cursor) is
|
|
1170 begin
|
|
1171 Position := Next (Position);
|
|
1172 end Next;
|
|
1173
|
|
1174 function Next
|
|
1175 (Object : Iterator;
|
|
1176 Position : Cursor) return Cursor
|
|
1177 is
|
|
1178 begin
|
|
1179 if Position.Container = null then
|
|
1180 return No_Element;
|
|
1181 end if;
|
|
1182
|
|
1183 if Checks and then Position.Container /= Object.Container then
|
|
1184 raise Program_Error with
|
|
1185 "Position cursor of Next designates wrong set";
|
|
1186 end if;
|
|
1187
|
|
1188 return Next (Position);
|
|
1189 end Next;
|
|
1190
|
|
1191 -------------
|
|
1192 -- Overlap --
|
|
1193 -------------
|
|
1194
|
|
1195 function Overlap (Left, Right : Set) return Boolean is
|
|
1196 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
|
|
1197 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
|
|
1198 Left_Node : Node_Access;
|
|
1199
|
|
1200 begin
|
|
1201 if Right.Length = 0 then
|
|
1202 return False;
|
|
1203 end if;
|
|
1204
|
|
1205 if Left'Address = Right'Address then
|
|
1206 return True;
|
|
1207 end if;
|
|
1208
|
|
1209 Left_Node := HT_Ops.First (Left_HT);
|
|
1210 while Left_Node /= null loop
|
|
1211 if Is_In (Right_HT, Left_Node) then
|
|
1212 return True;
|
|
1213 end if;
|
|
1214
|
|
1215 Left_Node := HT_Ops.Next (Left_HT, Left_Node);
|
|
1216 end loop;
|
|
1217
|
|
1218 return False;
|
|
1219 end Overlap;
|
|
1220
|
|
1221 ----------------------
|
|
1222 -- Pseudo_Reference --
|
|
1223 ----------------------
|
|
1224
|
|
1225 function Pseudo_Reference
|
|
1226 (Container : aliased Set'Class) return Reference_Control_Type
|
|
1227 is
|
|
1228 TC : constant Tamper_Counts_Access :=
|
|
1229 Container.HT.TC'Unrestricted_Access;
|
|
1230 begin
|
|
1231 return R : constant Reference_Control_Type := (Controlled with TC) do
|
|
1232 Lock (TC.all);
|
|
1233 end return;
|
|
1234 end Pseudo_Reference;
|
|
1235
|
|
1236 -------------------
|
|
1237 -- Query_Element --
|
|
1238 -------------------
|
|
1239
|
|
1240 procedure Query_Element
|
|
1241 (Position : Cursor;
|
|
1242 Process : not null access procedure (Element : Element_Type))
|
|
1243 is
|
|
1244 begin
|
|
1245 if Checks and then Position.Node = null then
|
|
1246 raise Constraint_Error with
|
|
1247 "Position cursor of Query_Element equals No_Element";
|
|
1248 end if;
|
|
1249
|
|
1250 if Checks and then Position.Node.Element = null then
|
|
1251 raise Program_Error with "bad cursor in Query_Element";
|
|
1252 end if;
|
|
1253
|
|
1254 pragma Assert (Vet (Position), "bad cursor in Query_Element");
|
|
1255
|
|
1256 declare
|
|
1257 HT : Hash_Table_Type renames
|
|
1258 Position.Container'Unrestricted_Access.all.HT;
|
|
1259 Lock : With_Lock (HT.TC'Unrestricted_Access);
|
|
1260 begin
|
|
1261 Process (Position.Node.Element.all);
|
|
1262 end;
|
|
1263 end Query_Element;
|
|
1264
|
|
1265 ----------
|
|
1266 -- Read --
|
|
1267 ----------
|
|
1268
|
|
1269 procedure Read
|
|
1270 (Stream : not null access Root_Stream_Type'Class;
|
|
1271 Container : out Set)
|
|
1272 is
|
|
1273 begin
|
|
1274 Read_Nodes (Stream, Container.HT);
|
|
1275 end Read;
|
|
1276
|
|
1277 procedure Read
|
|
1278 (Stream : not null access Root_Stream_Type'Class;
|
|
1279 Item : out Cursor)
|
|
1280 is
|
|
1281 begin
|
|
1282 raise Program_Error with "attempt to stream set cursor";
|
|
1283 end Read;
|
|
1284
|
|
1285 procedure Read
|
|
1286 (Stream : not null access Root_Stream_Type'Class;
|
|
1287 Item : out Constant_Reference_Type)
|
|
1288 is
|
|
1289 begin
|
|
1290 raise Program_Error with "attempt to stream reference";
|
|
1291 end Read;
|
|
1292
|
|
1293 ---------------
|
|
1294 -- Read_Node --
|
|
1295 ---------------
|
|
1296
|
|
1297 function Read_Node
|
|
1298 (Stream : not null access Root_Stream_Type'Class) return Node_Access
|
|
1299 is
|
|
1300 X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
|
|
1301 begin
|
|
1302 return new Node_Type'(X, null);
|
|
1303 exception
|
|
1304 when others =>
|
|
1305 Free_Element (X);
|
|
1306 raise;
|
|
1307 end Read_Node;
|
|
1308
|
|
1309 -------------
|
|
1310 -- Replace --
|
|
1311 -------------
|
|
1312
|
|
1313 procedure Replace
|
|
1314 (Container : in out Set;
|
|
1315 New_Item : Element_Type)
|
|
1316 is
|
|
1317 Node : constant Node_Access :=
|
|
1318 Element_Keys.Find (Container.HT, New_Item);
|
|
1319
|
|
1320 X : Element_Access;
|
|
1321 pragma Warnings (Off, X);
|
|
1322
|
|
1323 begin
|
|
1324 if Checks and then Node = null then
|
|
1325 raise Constraint_Error with
|
|
1326 "attempt to replace element not in set";
|
|
1327 end if;
|
|
1328
|
|
1329 TE_Check (Container.HT.TC);
|
|
1330
|
|
1331 X := Node.Element;
|
|
1332
|
|
1333 declare
|
|
1334 -- The element allocator may need an accessibility check in the case
|
|
1335 -- the actual type is class-wide or has access discriminants (see
|
|
1336 -- RM 4.8(10.1) and AI12-0035).
|
|
1337
|
|
1338 pragma Unsuppress (Accessibility_Check);
|
|
1339
|
|
1340 begin
|
|
1341 Node.Element := new Element_Type'(New_Item);
|
|
1342 end;
|
|
1343
|
|
1344 Free_Element (X);
|
|
1345 end Replace;
|
|
1346
|
|
1347 ---------------------
|
|
1348 -- Replace_Element --
|
|
1349 ---------------------
|
|
1350
|
|
1351 procedure Replace_Element
|
|
1352 (Container : in out Set;
|
|
1353 Position : Cursor;
|
|
1354 New_Item : Element_Type)
|
|
1355 is
|
|
1356 begin
|
|
1357 if Checks and then Position.Node = null then
|
|
1358 raise Constraint_Error with "Position cursor equals No_Element";
|
|
1359 end if;
|
|
1360
|
|
1361 if Checks and then Position.Node.Element = null then
|
|
1362 raise Program_Error with "bad cursor in Replace_Element";
|
|
1363 end if;
|
|
1364
|
|
1365 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
1366 then
|
|
1367 raise Program_Error with
|
|
1368 "Position cursor designates wrong set";
|
|
1369 end if;
|
|
1370
|
|
1371 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
|
|
1372
|
|
1373 Replace_Element (Container.HT, Position.Node, New_Item);
|
|
1374 end Replace_Element;
|
|
1375
|
|
1376 ----------------------
|
|
1377 -- Reserve_Capacity --
|
|
1378 ----------------------
|
|
1379
|
|
1380 procedure Reserve_Capacity
|
|
1381 (Container : in out Set;
|
|
1382 Capacity : Count_Type)
|
|
1383 is
|
|
1384 begin
|
|
1385 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
|
|
1386 end Reserve_Capacity;
|
|
1387
|
|
1388 --------------
|
|
1389 -- Set_Next --
|
|
1390 --------------
|
|
1391
|
|
1392 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
|
|
1393 begin
|
|
1394 Node.Next := Next;
|
|
1395 end Set_Next;
|
|
1396
|
|
1397 --------------------------
|
|
1398 -- Symmetric_Difference --
|
|
1399 --------------------------
|
|
1400
|
|
1401 procedure Symmetric_Difference
|
|
1402 (Target : in out Set;
|
|
1403 Source : Set)
|
|
1404 is
|
|
1405 Tgt_HT : Hash_Table_Type renames Target.HT;
|
|
1406 Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all;
|
|
1407 begin
|
|
1408 if Target'Address = Source'Address then
|
|
1409 Clear (Target);
|
|
1410 return;
|
|
1411 end if;
|
|
1412
|
|
1413 TC_Check (Tgt_HT.TC);
|
|
1414
|
|
1415 declare
|
|
1416 N : constant Count_Type := Target.Length + Source.Length;
|
|
1417 begin
|
|
1418 if N > HT_Ops.Capacity (Tgt_HT) then
|
|
1419 HT_Ops.Reserve_Capacity (Tgt_HT, N);
|
|
1420 end if;
|
|
1421 end;
|
|
1422
|
|
1423 if Target.Length = 0 then
|
|
1424 Iterate_Source_When_Empty_Target : declare
|
|
1425 procedure Process (Src_Node : Node_Access);
|
|
1426
|
|
1427 procedure Iterate is new HT_Ops.Generic_Iteration (Process);
|
|
1428
|
|
1429 -------------
|
|
1430 -- Process --
|
|
1431 -------------
|
|
1432
|
|
1433 procedure Process (Src_Node : Node_Access) is
|
|
1434 E : Element_Type renames Src_Node.Element.all;
|
|
1435 B : Buckets_Type renames Tgt_HT.Buckets.all;
|
|
1436 J : constant Hash_Type := Hash (E) mod B'Length;
|
|
1437 N : Count_Type renames Tgt_HT.Length;
|
|
1438
|
|
1439 begin
|
|
1440 declare
|
|
1441 X : Element_Access := new Element_Type'(E);
|
|
1442 begin
|
|
1443 B (J) := new Node_Type'(X, B (J));
|
|
1444 exception
|
|
1445 when others =>
|
|
1446 Free_Element (X);
|
|
1447 raise;
|
|
1448 end;
|
|
1449
|
|
1450 N := N + 1;
|
|
1451 end Process;
|
|
1452
|
|
1453 -- Per AI05-0022, the container implementation is required to
|
|
1454 -- detect element tampering by a generic actual subprogram.
|
|
1455
|
|
1456 Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access);
|
|
1457 Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access);
|
|
1458
|
|
1459 -- Start of processing for Iterate_Source_When_Empty_Target
|
|
1460
|
|
1461 begin
|
|
1462 Iterate (Src_HT);
|
|
1463 end Iterate_Source_When_Empty_Target;
|
|
1464
|
|
1465 else
|
|
1466 Iterate_Source : declare
|
|
1467 procedure Process (Src_Node : Node_Access);
|
|
1468
|
|
1469 procedure Iterate is
|
|
1470 new HT_Ops.Generic_Iteration (Process);
|
|
1471
|
|
1472 -------------
|
|
1473 -- Process --
|
|
1474 -------------
|
|
1475
|
|
1476 procedure Process (Src_Node : Node_Access) is
|
|
1477 E : Element_Type renames Src_Node.Element.all;
|
|
1478 B : Buckets_Type renames Tgt_HT.Buckets.all;
|
|
1479 J : constant Hash_Type := Hash (E) mod B'Length;
|
|
1480 N : Count_Type renames Tgt_HT.Length;
|
|
1481
|
|
1482 begin
|
|
1483 if B (J) = null then
|
|
1484 declare
|
|
1485 X : Element_Access := new Element_Type'(E);
|
|
1486 begin
|
|
1487 B (J) := new Node_Type'(X, null);
|
|
1488 exception
|
|
1489 when others =>
|
|
1490 Free_Element (X);
|
|
1491 raise;
|
|
1492 end;
|
|
1493
|
|
1494 N := N + 1;
|
|
1495
|
|
1496 elsif Equivalent_Elements (E, B (J).Element.all) then
|
|
1497 declare
|
|
1498 X : Node_Access := B (J);
|
|
1499 begin
|
|
1500 B (J) := B (J).Next;
|
|
1501 N := N - 1;
|
|
1502 Free (X);
|
|
1503 end;
|
|
1504
|
|
1505 else
|
|
1506 declare
|
|
1507 Prev : Node_Access := B (J);
|
|
1508 Curr : Node_Access := Prev.Next;
|
|
1509
|
|
1510 begin
|
|
1511 while Curr /= null loop
|
|
1512 if Equivalent_Elements (E, Curr.Element.all) then
|
|
1513 Prev.Next := Curr.Next;
|
|
1514 N := N - 1;
|
|
1515 Free (Curr);
|
|
1516 return;
|
|
1517 end if;
|
|
1518
|
|
1519 Prev := Curr;
|
|
1520 Curr := Prev.Next;
|
|
1521 end loop;
|
|
1522
|
|
1523 declare
|
|
1524 X : Element_Access := new Element_Type'(E);
|
|
1525 begin
|
|
1526 B (J) := new Node_Type'(X, B (J));
|
|
1527 exception
|
|
1528 when others =>
|
|
1529 Free_Element (X);
|
|
1530 raise;
|
|
1531 end;
|
|
1532
|
|
1533 N := N + 1;
|
|
1534 end;
|
|
1535 end if;
|
|
1536 end Process;
|
|
1537
|
|
1538 -- Per AI05-0022, the container implementation is required to
|
|
1539 -- detect element tampering by a generic actual subprogram.
|
|
1540
|
|
1541 Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access);
|
|
1542 Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access);
|
|
1543
|
|
1544 -- Start of processing for Iterate_Source
|
|
1545
|
|
1546 begin
|
|
1547 Iterate (Src_HT);
|
|
1548 end Iterate_Source;
|
|
1549 end if;
|
|
1550 end Symmetric_Difference;
|
|
1551
|
|
1552 function Symmetric_Difference (Left, Right : Set) return Set is
|
|
1553 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
|
|
1554 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
|
|
1555 Buckets : HT_Types.Buckets_Access;
|
|
1556 Length : Count_Type;
|
|
1557
|
|
1558 begin
|
|
1559 if Left'Address = Right'Address then
|
|
1560 return Empty_Set;
|
|
1561 end if;
|
|
1562
|
|
1563 if Right.Length = 0 then
|
|
1564 return Left;
|
|
1565 end if;
|
|
1566
|
|
1567 if Left.Length = 0 then
|
|
1568 return Right;
|
|
1569 end if;
|
|
1570
|
|
1571 declare
|
|
1572 Size : constant Hash_Type :=
|
|
1573 Prime_Numbers.To_Prime (Left.Length + Right.Length);
|
|
1574 begin
|
|
1575 Buckets := HT_Ops.New_Buckets (Length => Size);
|
|
1576 end;
|
|
1577
|
|
1578 Length := 0;
|
|
1579
|
|
1580 Iterate_Left : declare
|
|
1581 procedure Process (L_Node : Node_Access);
|
|
1582
|
|
1583 procedure Iterate is
|
|
1584 new HT_Ops.Generic_Iteration (Process);
|
|
1585
|
|
1586 -------------
|
|
1587 -- Process --
|
|
1588 -------------
|
|
1589
|
|
1590 procedure Process (L_Node : Node_Access) is
|
|
1591 begin
|
|
1592 if not Is_In (Right_HT, L_Node) then
|
|
1593 declare
|
|
1594 E : Element_Type renames L_Node.Element.all;
|
|
1595
|
|
1596 -- Per AI05-0022, the container implementation is required
|
|
1597 -- to detect element tampering by a generic actual
|
|
1598 -- subprogram, hence the use of Checked_Index instead of a
|
|
1599 -- simple invocation of generic formal Hash.
|
|
1600
|
|
1601 J : constant Hash_Type :=
|
|
1602 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
|
|
1603
|
|
1604 begin
|
|
1605 declare
|
|
1606 X : Element_Access := new Element_Type'(E);
|
|
1607 begin
|
|
1608 Buckets (J) := new Node_Type'(X, Buckets (J));
|
|
1609 exception
|
|
1610 when others =>
|
|
1611 Free_Element (X);
|
|
1612 raise;
|
|
1613 end;
|
|
1614
|
|
1615 Length := Length + 1;
|
|
1616 end;
|
|
1617 end if;
|
|
1618 end Process;
|
|
1619
|
|
1620 -- Start of processing for Iterate_Left
|
|
1621
|
|
1622 begin
|
|
1623 Iterate (Left_HT);
|
|
1624 exception
|
|
1625 when others =>
|
|
1626 HT_Ops.Free_Hash_Table (Buckets);
|
|
1627 raise;
|
|
1628 end Iterate_Left;
|
|
1629
|
|
1630 Iterate_Right : declare
|
|
1631 procedure Process (R_Node : Node_Access);
|
|
1632
|
|
1633 procedure Iterate is
|
|
1634 new HT_Ops.Generic_Iteration (Process);
|
|
1635
|
|
1636 -------------
|
|
1637 -- Process --
|
|
1638 -------------
|
|
1639
|
|
1640 procedure Process (R_Node : Node_Access) is
|
|
1641 begin
|
|
1642 if not Is_In (Left_HT, R_Node) then
|
|
1643 declare
|
|
1644 E : Element_Type renames R_Node.Element.all;
|
|
1645
|
|
1646 -- Per AI05-0022, the container implementation is required
|
|
1647 -- to detect element tampering by a generic actual
|
|
1648 -- subprogram, hence the use of Checked_Index instead of a
|
|
1649 -- simple invocation of generic formal Hash.
|
|
1650
|
|
1651 J : constant Hash_Type :=
|
|
1652 HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node);
|
|
1653
|
|
1654 begin
|
|
1655 declare
|
|
1656 X : Element_Access := new Element_Type'(E);
|
|
1657 begin
|
|
1658 Buckets (J) := new Node_Type'(X, Buckets (J));
|
|
1659 exception
|
|
1660 when others =>
|
|
1661 Free_Element (X);
|
|
1662 raise;
|
|
1663 end;
|
|
1664
|
|
1665 Length := Length + 1;
|
|
1666 end;
|
|
1667 end if;
|
|
1668 end Process;
|
|
1669
|
|
1670 -- Start of processing for Iterate_Right
|
|
1671
|
|
1672 begin
|
|
1673 Iterate (Right_HT);
|
|
1674
|
|
1675 exception
|
|
1676 when others =>
|
|
1677 HT_Ops.Free_Hash_Table (Buckets);
|
|
1678 raise;
|
|
1679 end Iterate_Right;
|
|
1680
|
|
1681 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
|
|
1682 end Symmetric_Difference;
|
|
1683
|
|
1684 ------------
|
|
1685 -- To_Set --
|
|
1686 ------------
|
|
1687
|
|
1688 function To_Set (New_Item : Element_Type) return Set is
|
|
1689 HT : Hash_Table_Type;
|
|
1690 Node : Node_Access;
|
|
1691 Inserted : Boolean;
|
|
1692 pragma Unreferenced (Node, Inserted);
|
|
1693 begin
|
|
1694 Insert (HT, New_Item, Node, Inserted);
|
|
1695 return Set'(Controlled with HT);
|
|
1696 end To_Set;
|
|
1697
|
|
1698 -----------
|
|
1699 -- Union --
|
|
1700 -----------
|
|
1701
|
|
1702 procedure Union
|
|
1703 (Target : in out Set;
|
|
1704 Source : Set)
|
|
1705 is
|
|
1706 procedure Process (Src_Node : Node_Access);
|
|
1707
|
|
1708 procedure Iterate is
|
|
1709 new HT_Ops.Generic_Iteration (Process);
|
|
1710
|
|
1711 -------------
|
|
1712 -- Process --
|
|
1713 -------------
|
|
1714
|
|
1715 procedure Process (Src_Node : Node_Access) is
|
|
1716 Src : Element_Type renames Src_Node.Element.all;
|
|
1717
|
|
1718 function New_Node (Next : Node_Access) return Node_Access;
|
|
1719 pragma Inline (New_Node);
|
|
1720
|
|
1721 procedure Insert is
|
|
1722 new Element_Keys.Generic_Conditional_Insert (New_Node);
|
|
1723
|
|
1724 --------------
|
|
1725 -- New_Node --
|
|
1726 --------------
|
|
1727
|
|
1728 function New_Node (Next : Node_Access) return Node_Access is
|
|
1729 Tgt : Element_Access := new Element_Type'(Src);
|
|
1730 begin
|
|
1731 return new Node_Type'(Tgt, Next);
|
|
1732 exception
|
|
1733 when others =>
|
|
1734 Free_Element (Tgt);
|
|
1735 raise;
|
|
1736 end New_Node;
|
|
1737
|
|
1738 Tgt_Node : Node_Access;
|
|
1739 Success : Boolean;
|
|
1740 pragma Unreferenced (Tgt_Node, Success);
|
|
1741
|
|
1742 -- Start of processing for Process
|
|
1743
|
|
1744 begin
|
|
1745 Insert (Target.HT, Src, Tgt_Node, Success);
|
|
1746 end Process;
|
|
1747
|
|
1748 -- Start of processing for Union
|
|
1749
|
|
1750 begin
|
|
1751 if Target'Address = Source'Address then
|
|
1752 return;
|
|
1753 end if;
|
|
1754
|
|
1755 TC_Check (Target.HT.TC);
|
|
1756
|
|
1757 declare
|
|
1758 N : constant Count_Type := Target.Length + Source.Length;
|
|
1759 begin
|
|
1760 if N > HT_Ops.Capacity (Target.HT) then
|
|
1761 HT_Ops.Reserve_Capacity (Target.HT, N);
|
|
1762 end if;
|
|
1763 end;
|
|
1764
|
|
1765 Iterate (Source.HT);
|
|
1766 end Union;
|
|
1767
|
|
1768 function Union (Left, Right : Set) return Set is
|
|
1769 Left_HT : Hash_Table_Type renames Left.HT'Unrestricted_Access.all;
|
|
1770 Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all;
|
|
1771 Buckets : HT_Types.Buckets_Access;
|
|
1772 Length : Count_Type;
|
|
1773
|
|
1774 begin
|
|
1775 if Left'Address = Right'Address then
|
|
1776 return Left;
|
|
1777 end if;
|
|
1778
|
|
1779 if Right.Length = 0 then
|
|
1780 return Left;
|
|
1781 end if;
|
|
1782
|
|
1783 if Left.Length = 0 then
|
|
1784 return Right;
|
|
1785 end if;
|
|
1786
|
|
1787 declare
|
|
1788 Size : constant Hash_Type :=
|
|
1789 Prime_Numbers.To_Prime (Left.Length + Right.Length);
|
|
1790 begin
|
|
1791 Buckets := HT_Ops.New_Buckets (Length => Size);
|
|
1792 end;
|
|
1793
|
|
1794 Iterate_Left : declare
|
|
1795 procedure Process (L_Node : Node_Access);
|
|
1796
|
|
1797 procedure Iterate is
|
|
1798 new HT_Ops.Generic_Iteration (Process);
|
|
1799
|
|
1800 -------------
|
|
1801 -- Process --
|
|
1802 -------------
|
|
1803
|
|
1804 procedure Process (L_Node : Node_Access) is
|
|
1805 Src : Element_Type renames L_Node.Element.all;
|
|
1806 J : constant Hash_Type := Hash (Src) mod Buckets'Length;
|
|
1807 Bucket : Node_Access renames Buckets (J);
|
|
1808 Tgt : Element_Access := new Element_Type'(Src);
|
|
1809 begin
|
|
1810 Bucket := new Node_Type'(Tgt, Bucket);
|
|
1811 exception
|
|
1812 when others =>
|
|
1813 Free_Element (Tgt);
|
|
1814 raise;
|
|
1815 end Process;
|
|
1816
|
|
1817 -- Per AI05-0022, the container implementation is required to detect
|
|
1818 -- element tampering by a generic actual subprogram, hence the use of
|
|
1819 -- Checked_Index instead of a simple invocation of generic formal
|
|
1820 -- Hash.
|
|
1821
|
|
1822 Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access);
|
|
1823
|
|
1824 -- Start of processing for Iterate_Left
|
|
1825
|
|
1826 begin
|
|
1827 Iterate (Left_HT);
|
|
1828 exception
|
|
1829 when others =>
|
|
1830 HT_Ops.Free_Hash_Table (Buckets);
|
|
1831 raise;
|
|
1832 end Iterate_Left;
|
|
1833
|
|
1834 Length := Left.Length;
|
|
1835
|
|
1836 Iterate_Right : declare
|
|
1837 procedure Process (Src_Node : Node_Access);
|
|
1838
|
|
1839 procedure Iterate is
|
|
1840 new HT_Ops.Generic_Iteration (Process);
|
|
1841
|
|
1842 -------------
|
|
1843 -- Process --
|
|
1844 -------------
|
|
1845
|
|
1846 procedure Process (Src_Node : Node_Access) is
|
|
1847 Src : Element_Type renames Src_Node.Element.all;
|
|
1848 Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
|
|
1849
|
|
1850 Tgt_Node : Node_Access := Buckets (Idx);
|
|
1851
|
|
1852 begin
|
|
1853 while Tgt_Node /= null loop
|
|
1854 if Equivalent_Elements (Src, Tgt_Node.Element.all) then
|
|
1855 return;
|
|
1856 end if;
|
|
1857 Tgt_Node := Next (Tgt_Node);
|
|
1858 end loop;
|
|
1859
|
|
1860 declare
|
|
1861 Tgt : Element_Access := new Element_Type'(Src);
|
|
1862 begin
|
|
1863 Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx));
|
|
1864 exception
|
|
1865 when others =>
|
|
1866 Free_Element (Tgt);
|
|
1867 raise;
|
|
1868 end;
|
|
1869
|
|
1870 Length := Length + 1;
|
|
1871 end Process;
|
|
1872
|
|
1873 -- Per AI05-0022, the container implementation is required to detect
|
|
1874 -- element tampering by a generic actual subprogram, hence the use of
|
|
1875 -- Checked_Index instead of a simple invocation of generic formal
|
|
1876 -- Hash.
|
|
1877
|
|
1878 Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access);
|
|
1879 Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access);
|
|
1880
|
|
1881 -- Start of processing for Iterate_Right
|
|
1882
|
|
1883 begin
|
|
1884 Iterate (Right.HT);
|
|
1885 exception
|
|
1886 when others =>
|
|
1887 HT_Ops.Free_Hash_Table (Buckets);
|
|
1888 raise;
|
|
1889 end Iterate_Right;
|
|
1890
|
|
1891 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
|
|
1892 end Union;
|
|
1893
|
|
1894 ---------
|
|
1895 -- Vet --
|
|
1896 ---------
|
|
1897
|
|
1898 function Vet (Position : Cursor) return Boolean is
|
|
1899 begin
|
|
1900 if Position.Node = null then
|
|
1901 return Position.Container = null;
|
|
1902 end if;
|
|
1903
|
|
1904 if Position.Container = null then
|
|
1905 return False;
|
|
1906 end if;
|
|
1907
|
|
1908 if Position.Node.Next = Position.Node then
|
|
1909 return False;
|
|
1910 end if;
|
|
1911
|
|
1912 if Position.Node.Element = null then
|
|
1913 return False;
|
|
1914 end if;
|
|
1915
|
|
1916 declare
|
|
1917 HT : Hash_Table_Type renames Position.Container.HT;
|
|
1918 X : Node_Access;
|
|
1919
|
|
1920 begin
|
|
1921 if HT.Length = 0 then
|
|
1922 return False;
|
|
1923 end if;
|
|
1924
|
|
1925 if HT.Buckets = null
|
|
1926 or else HT.Buckets'Length = 0
|
|
1927 then
|
|
1928 return False;
|
|
1929 end if;
|
|
1930
|
|
1931 X := HT.Buckets (Element_Keys.Checked_Index
|
|
1932 (HT,
|
|
1933 Position.Node.Element.all));
|
|
1934
|
|
1935 for J in 1 .. HT.Length loop
|
|
1936 if X = Position.Node then
|
|
1937 return True;
|
|
1938 end if;
|
|
1939
|
|
1940 if X = null then
|
|
1941 return False;
|
|
1942 end if;
|
|
1943
|
|
1944 if X = X.Next then -- to prevent unnecessary looping
|
|
1945 return False;
|
|
1946 end if;
|
|
1947
|
|
1948 X := X.Next;
|
|
1949 end loop;
|
|
1950
|
|
1951 return False;
|
|
1952 end;
|
|
1953 end Vet;
|
|
1954
|
|
1955 -----------
|
|
1956 -- Write --
|
|
1957 -----------
|
|
1958
|
|
1959 procedure Write
|
|
1960 (Stream : not null access Root_Stream_Type'Class;
|
|
1961 Container : Set)
|
|
1962 is
|
|
1963 begin
|
|
1964 Write_Nodes (Stream, Container.HT);
|
|
1965 end Write;
|
|
1966
|
|
1967 procedure Write
|
|
1968 (Stream : not null access Root_Stream_Type'Class;
|
|
1969 Item : Cursor)
|
|
1970 is
|
|
1971 begin
|
|
1972 raise Program_Error with "attempt to stream set cursor";
|
|
1973 end Write;
|
|
1974
|
|
1975 procedure Write
|
|
1976 (Stream : not null access Root_Stream_Type'Class;
|
|
1977 Item : Constant_Reference_Type)
|
|
1978 is
|
|
1979 begin
|
|
1980 raise Program_Error with "attempt to stream reference";
|
|
1981 end Write;
|
|
1982
|
|
1983 ----------------
|
|
1984 -- Write_Node --
|
|
1985 ----------------
|
|
1986
|
|
1987 procedure Write_Node
|
|
1988 (Stream : not null access Root_Stream_Type'Class;
|
|
1989 Node : Node_Access)
|
|
1990 is
|
|
1991 begin
|
|
1992 Element_Type'Output (Stream, Node.Element.all);
|
|
1993 end Write_Node;
|
|
1994
|
|
1995 package body Generic_Keys is
|
|
1996
|
|
1997 -----------------------
|
|
1998 -- Local Subprograms --
|
|
1999 -----------------------
|
|
2000
|
|
2001 function Equivalent_Key_Node
|
|
2002 (Key : Key_Type;
|
|
2003 Node : Node_Access) return Boolean;
|
|
2004 pragma Inline (Equivalent_Key_Node);
|
|
2005
|
|
2006 --------------------------
|
|
2007 -- Local Instantiations --
|
|
2008 --------------------------
|
|
2009
|
|
2010 package Key_Keys is
|
|
2011 new Hash_Tables.Generic_Keys
|
|
2012 (HT_Types => HT_Types,
|
|
2013 Next => Next,
|
|
2014 Set_Next => Set_Next,
|
|
2015 Key_Type => Key_Type,
|
|
2016 Hash => Hash,
|
|
2017 Equivalent_Keys => Equivalent_Key_Node);
|
|
2018
|
|
2019 ------------------------
|
|
2020 -- Constant_Reference --
|
|
2021 ------------------------
|
|
2022
|
|
2023 function Constant_Reference
|
|
2024 (Container : aliased Set;
|
|
2025 Key : Key_Type) return Constant_Reference_Type
|
|
2026 is
|
|
2027 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
|
|
2028 Node : constant Node_Access := Key_Keys.Find (HT, Key);
|
|
2029
|
|
2030 begin
|
|
2031 if Checks and then Node = null then
|
|
2032 raise Constraint_Error with "Key not in set";
|
|
2033 end if;
|
|
2034
|
|
2035 if Checks and then Node.Element = null then
|
|
2036 raise Program_Error with "Node has no element";
|
|
2037 end if;
|
|
2038
|
|
2039 declare
|
|
2040 TC : constant Tamper_Counts_Access :=
|
|
2041 HT.TC'Unrestricted_Access;
|
|
2042 begin
|
|
2043 return R : constant Constant_Reference_Type :=
|
|
2044 (Element => Node.Element.all'Access,
|
|
2045 Control => (Controlled with TC))
|
|
2046 do
|
|
2047 Lock (TC.all);
|
|
2048 end return;
|
|
2049 end;
|
|
2050 end Constant_Reference;
|
|
2051
|
|
2052 --------------
|
|
2053 -- Contains --
|
|
2054 --------------
|
|
2055
|
|
2056 function Contains
|
|
2057 (Container : Set;
|
|
2058 Key : Key_Type) return Boolean
|
|
2059 is
|
|
2060 begin
|
|
2061 return Find (Container, Key) /= No_Element;
|
|
2062 end Contains;
|
|
2063
|
|
2064 ------------
|
|
2065 -- Delete --
|
|
2066 ------------
|
|
2067
|
|
2068 procedure Delete
|
|
2069 (Container : in out Set;
|
|
2070 Key : Key_Type)
|
|
2071 is
|
|
2072 X : Node_Access;
|
|
2073
|
|
2074 begin
|
|
2075 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
|
|
2076
|
|
2077 if Checks and then X = null then
|
|
2078 raise Constraint_Error with "key not in set";
|
|
2079 end if;
|
|
2080
|
|
2081 Free (X);
|
|
2082 end Delete;
|
|
2083
|
|
2084 -------------
|
|
2085 -- Element --
|
|
2086 -------------
|
|
2087
|
|
2088 function Element
|
|
2089 (Container : Set;
|
|
2090 Key : Key_Type) return Element_Type
|
|
2091 is
|
|
2092 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
|
|
2093 Node : constant Node_Access := Key_Keys.Find (HT, Key);
|
|
2094
|
|
2095 begin
|
|
2096 if Checks and then Node = null then
|
|
2097 raise Constraint_Error with "key not in set";
|
|
2098 end if;
|
|
2099
|
|
2100 return Node.Element.all;
|
|
2101 end Element;
|
|
2102
|
|
2103 -------------------------
|
|
2104 -- Equivalent_Key_Node --
|
|
2105 -------------------------
|
|
2106
|
|
2107 function Equivalent_Key_Node
|
|
2108 (Key : Key_Type;
|
|
2109 Node : Node_Access) return Boolean is
|
|
2110 begin
|
|
2111 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
|
|
2112 end Equivalent_Key_Node;
|
|
2113
|
|
2114 -------------
|
|
2115 -- Exclude --
|
|
2116 -------------
|
|
2117
|
|
2118 procedure Exclude
|
|
2119 (Container : in out Set;
|
|
2120 Key : Key_Type)
|
|
2121 is
|
|
2122 X : Node_Access;
|
|
2123 begin
|
|
2124 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
|
|
2125 Free (X);
|
|
2126 end Exclude;
|
|
2127
|
|
2128 --------------
|
|
2129 -- Finalize --
|
|
2130 --------------
|
|
2131
|
|
2132 procedure Finalize (Control : in out Reference_Control_Type) is
|
|
2133 begin
|
|
2134 if Control.Container /= null then
|
|
2135 Impl.Reference_Control_Type (Control).Finalize;
|
|
2136
|
|
2137 if Checks and then Hash (Key (Control.Old_Pos)) /= Control.Old_Hash
|
|
2138 then
|
|
2139 HT_Ops.Delete_Node_At_Index
|
|
2140 (Control.Container.HT, Control.Index, Control.Old_Pos.Node);
|
|
2141 raise Program_Error;
|
|
2142 end if;
|
|
2143
|
|
2144 Control.Container := null;
|
|
2145 end if;
|
|
2146 end Finalize;
|
|
2147
|
|
2148 ----------
|
|
2149 -- Find --
|
|
2150 ----------
|
|
2151
|
|
2152 function Find
|
|
2153 (Container : Set;
|
|
2154 Key : Key_Type) return Cursor
|
|
2155 is
|
|
2156 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
|
|
2157 Node : constant Node_Access := Key_Keys.Find (HT, Key);
|
|
2158 begin
|
|
2159 return (if Node = null then No_Element
|
|
2160 else Cursor'(Container'Unrestricted_Access, Node));
|
|
2161 end Find;
|
|
2162
|
|
2163 ---------
|
|
2164 -- Key --
|
|
2165 ---------
|
|
2166
|
|
2167 function Key (Position : Cursor) return Key_Type is
|
|
2168 begin
|
|
2169 if Checks and then Position.Node = null then
|
|
2170 raise Constraint_Error with
|
|
2171 "Position cursor equals No_Element";
|
|
2172 end if;
|
|
2173
|
|
2174 if Checks and then Position.Node.Element = null then
|
|
2175 raise Program_Error with "Position cursor is bad";
|
|
2176 end if;
|
|
2177
|
|
2178 pragma Assert (Vet (Position), "bad cursor in function Key");
|
|
2179
|
|
2180 return Key (Position.Node.Element.all);
|
|
2181 end Key;
|
|
2182
|
|
2183 ----------
|
|
2184 -- Read --
|
|
2185 ----------
|
|
2186
|
|
2187 procedure Read
|
|
2188 (Stream : not null access Root_Stream_Type'Class;
|
|
2189 Item : out Reference_Type)
|
|
2190 is
|
|
2191 begin
|
|
2192 raise Program_Error with "attempt to stream reference";
|
|
2193 end Read;
|
|
2194
|
|
2195 ------------------------------
|
|
2196 -- Reference_Preserving_Key --
|
|
2197 ------------------------------
|
|
2198
|
|
2199 function Reference_Preserving_Key
|
|
2200 (Container : aliased in out Set;
|
|
2201 Position : Cursor) return Reference_Type
|
|
2202 is
|
|
2203 begin
|
|
2204 if Checks and then Position.Container = null then
|
|
2205 raise Constraint_Error with "Position cursor has no element";
|
|
2206 end if;
|
|
2207
|
|
2208 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
2209 then
|
|
2210 raise Program_Error with
|
|
2211 "Position cursor designates wrong container";
|
|
2212 end if;
|
|
2213
|
|
2214 if Checks and then Position.Node.Element = null then
|
|
2215 raise Program_Error with "Node has no element";
|
|
2216 end if;
|
|
2217
|
|
2218 pragma Assert
|
|
2219 (Vet (Position),
|
|
2220 "bad cursor in function Reference_Preserving_Key");
|
|
2221
|
|
2222 declare
|
|
2223 HT : Hash_Table_Type renames Container.HT;
|
|
2224 begin
|
|
2225 return R : constant Reference_Type :=
|
|
2226 (Element => Position.Node.Element.all'Access,
|
|
2227 Control =>
|
|
2228 (Controlled with
|
|
2229 HT.TC'Unrestricted_Access,
|
|
2230 Container => Container'Access,
|
|
2231 Index => HT_Ops.Index (HT, Position.Node),
|
|
2232 Old_Pos => Position,
|
|
2233 Old_Hash => Hash (Key (Position))))
|
|
2234 do
|
|
2235 Lock (HT.TC);
|
|
2236 end return;
|
|
2237 end;
|
|
2238 end Reference_Preserving_Key;
|
|
2239
|
|
2240 function Reference_Preserving_Key
|
|
2241 (Container : aliased in out Set;
|
|
2242 Key : Key_Type) return Reference_Type
|
|
2243 is
|
|
2244 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
|
|
2245
|
|
2246 begin
|
|
2247 if Checks and then Node = null then
|
|
2248 raise Constraint_Error with "Key not in set";
|
|
2249 end if;
|
|
2250
|
|
2251 if Checks and then Node.Element = null then
|
|
2252 raise Program_Error with "Node has no element";
|
|
2253 end if;
|
|
2254
|
|
2255 declare
|
|
2256 HT : Hash_Table_Type renames Container.HT;
|
|
2257 P : constant Cursor := Find (Container, Key);
|
|
2258 begin
|
|
2259 return R : constant Reference_Type :=
|
|
2260 (Element => Node.Element.all'Access,
|
|
2261 Control =>
|
|
2262 (Controlled with
|
|
2263 HT.TC'Unrestricted_Access,
|
|
2264 Container => Container'Access,
|
|
2265 Index => HT_Ops.Index (HT, P.Node),
|
|
2266 Old_Pos => P,
|
|
2267 Old_Hash => Hash (Key)))
|
|
2268 do
|
|
2269 Lock (HT.TC);
|
|
2270 end return;
|
|
2271 end;
|
|
2272 end Reference_Preserving_Key;
|
|
2273
|
|
2274 -------------
|
|
2275 -- Replace --
|
|
2276 -------------
|
|
2277
|
|
2278 procedure Replace
|
|
2279 (Container : in out Set;
|
|
2280 Key : Key_Type;
|
|
2281 New_Item : Element_Type)
|
|
2282 is
|
|
2283 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
|
|
2284
|
|
2285 begin
|
|
2286 if Checks and then Node = null then
|
|
2287 raise Constraint_Error with
|
|
2288 "attempt to replace key not in set";
|
|
2289 end if;
|
|
2290
|
|
2291 Replace_Element (Container.HT, Node, New_Item);
|
|
2292 end Replace;
|
|
2293
|
|
2294 -----------------------------------
|
|
2295 -- Update_Element_Preserving_Key --
|
|
2296 -----------------------------------
|
|
2297
|
|
2298 procedure Update_Element_Preserving_Key
|
|
2299 (Container : in out Set;
|
|
2300 Position : Cursor;
|
|
2301 Process : not null access
|
|
2302 procedure (Element : in out Element_Type))
|
|
2303 is
|
|
2304 HT : Hash_Table_Type renames Container.HT;
|
|
2305 Indx : Hash_Type;
|
|
2306
|
|
2307 begin
|
|
2308 if Checks and then Position.Node = null then
|
|
2309 raise Constraint_Error with
|
|
2310 "Position cursor equals No_Element";
|
|
2311 end if;
|
|
2312
|
|
2313 if Checks and then
|
|
2314 (Position.Node.Element = null
|
|
2315 or else Position.Node.Next = Position.Node)
|
|
2316 then
|
|
2317 raise Program_Error with "Position cursor is bad";
|
|
2318 end if;
|
|
2319
|
|
2320 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
2321 then
|
|
2322 raise Program_Error with
|
|
2323 "Position cursor designates wrong set";
|
|
2324 end if;
|
|
2325
|
|
2326 if Checks and then
|
|
2327 (HT.Buckets = null
|
|
2328 or else HT.Buckets'Length = 0
|
|
2329 or else HT.Length = 0)
|
|
2330 then
|
|
2331 raise Program_Error with "Position cursor is bad (set is empty)";
|
|
2332 end if;
|
|
2333
|
|
2334 pragma Assert
|
|
2335 (Vet (Position),
|
|
2336 "bad cursor in Update_Element_Preserving_Key");
|
|
2337
|
|
2338 -- Per AI05-0022, the container implementation is required to detect
|
|
2339 -- element tampering by a generic actual subprogram.
|
|
2340
|
|
2341 declare
|
|
2342 E : Element_Type renames Position.Node.Element.all;
|
|
2343 K : constant Key_Type := Key (E);
|
|
2344 Lock : With_Lock (HT.TC'Unrestricted_Access);
|
|
2345 begin
|
|
2346 Indx := HT_Ops.Index (HT, Position.Node);
|
|
2347 Process (E);
|
|
2348
|
|
2349 if Equivalent_Keys (K, Key (E)) then
|
|
2350 return;
|
|
2351 end if;
|
|
2352 end;
|
|
2353
|
|
2354 if HT.Buckets (Indx) = Position.Node then
|
|
2355 HT.Buckets (Indx) := Position.Node.Next;
|
|
2356
|
|
2357 else
|
|
2358 declare
|
|
2359 Prev : Node_Access := HT.Buckets (Indx);
|
|
2360
|
|
2361 begin
|
|
2362 while Prev.Next /= Position.Node loop
|
|
2363 Prev := Prev.Next;
|
|
2364
|
|
2365 if Checks and then Prev = null then
|
|
2366 raise Program_Error with
|
|
2367 "Position cursor is bad (node not found)";
|
|
2368 end if;
|
|
2369 end loop;
|
|
2370
|
|
2371 Prev.Next := Position.Node.Next;
|
|
2372 end;
|
|
2373 end if;
|
|
2374
|
|
2375 HT.Length := HT.Length - 1;
|
|
2376
|
|
2377 declare
|
|
2378 X : Node_Access := Position.Node;
|
|
2379
|
|
2380 begin
|
|
2381 Free (X);
|
|
2382 end;
|
|
2383
|
|
2384 raise Program_Error with "key was modified";
|
|
2385 end Update_Element_Preserving_Key;
|
|
2386
|
|
2387 -----------
|
|
2388 -- Write --
|
|
2389 -----------
|
|
2390
|
|
2391 procedure Write
|
|
2392 (Stream : not null access Root_Stream_Type'Class;
|
|
2393 Item : Reference_Type)
|
|
2394 is
|
|
2395 begin
|
|
2396 raise Program_Error with "attempt to stream reference";
|
|
2397 end Write;
|
|
2398
|
|
2399 end Generic_Keys;
|
|
2400
|
|
2401 end Ada.Containers.Indefinite_Hashed_Sets;
|