annotate gcc/ada/libgnat/a-cihase.adb @ 131:84e7813d76e9

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