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