|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ S E T S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2004-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
|
17 -- --
|
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
21 -- --
|
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
|
26 -- --
|
|
|
27 -- This unit was originally developed by Matthew J Heaney. --
|
|
|
28 ------------------------------------------------------------------------------
|
|
|
29
|
|
|
30 with Ada.Containers.Helpers; use Ada.Containers.Helpers;
|
|
|
31
|
|
|
32 with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
|
|
|
33 pragma Elaborate_All
|
|
|
34 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations);
|
|
|
35
|
|
|
36 with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
|
|
|
37 pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys);
|
|
|
38
|
|
|
39 with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
|
|
|
40 pragma Elaborate_All
|
|
|
41 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations);
|
|
|
42
|
|
|
43 with System; use type System.Address;
|
|
|
44
|
|
|
45 package body Ada.Containers.Bounded_Ordered_Sets is
|
|
|
46
|
|
|
47 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
|
|
|
48 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
|
|
|
49 -- See comment in Ada.Containers.Helpers
|
|
|
50
|
|
|
51 ------------------------------
|
|
|
52 -- Access to Fields of Node --
|
|
|
53 ------------------------------
|
|
|
54
|
|
|
55 -- These subprograms provide functional notation for access to fields
|
|
|
56 -- of a node, and procedural notation for modifying these fields.
|
|
|
57
|
|
|
58 function Color (Node : Node_Type) return Red_Black_Trees.Color_Type;
|
|
|
59 pragma Inline (Color);
|
|
|
60
|
|
|
61 function Left (Node : Node_Type) return Count_Type;
|
|
|
62 pragma Inline (Left);
|
|
|
63
|
|
|
64 function Parent (Node : Node_Type) return Count_Type;
|
|
|
65 pragma Inline (Parent);
|
|
|
66
|
|
|
67 function Right (Node : Node_Type) return Count_Type;
|
|
|
68 pragma Inline (Right);
|
|
|
69
|
|
|
70 procedure Set_Color
|
|
|
71 (Node : in out Node_Type;
|
|
|
72 Color : Red_Black_Trees.Color_Type);
|
|
|
73 pragma Inline (Set_Color);
|
|
|
74
|
|
|
75 procedure Set_Left (Node : in out Node_Type; Left : Count_Type);
|
|
|
76 pragma Inline (Set_Left);
|
|
|
77
|
|
|
78 procedure Set_Right (Node : in out Node_Type; Right : Count_Type);
|
|
|
79 pragma Inline (Set_Right);
|
|
|
80
|
|
|
81 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type);
|
|
|
82 pragma Inline (Set_Parent);
|
|
|
83
|
|
|
84 -----------------------
|
|
|
85 -- Local Subprograms --
|
|
|
86 -----------------------
|
|
|
87
|
|
|
88 procedure Insert_Sans_Hint
|
|
|
89 (Container : in out Set;
|
|
|
90 New_Item : Element_Type;
|
|
|
91 Node : out Count_Type;
|
|
|
92 Inserted : out Boolean);
|
|
|
93
|
|
|
94 procedure Insert_With_Hint
|
|
|
95 (Dst_Set : in out Set;
|
|
|
96 Dst_Hint : Count_Type;
|
|
|
97 Src_Node : Node_Type;
|
|
|
98 Dst_Node : out Count_Type);
|
|
|
99
|
|
|
100 function Is_Greater_Element_Node
|
|
|
101 (Left : Element_Type;
|
|
|
102 Right : Node_Type) return Boolean;
|
|
|
103 pragma Inline (Is_Greater_Element_Node);
|
|
|
104
|
|
|
105 function Is_Less_Element_Node
|
|
|
106 (Left : Element_Type;
|
|
|
107 Right : Node_Type) return Boolean;
|
|
|
108 pragma Inline (Is_Less_Element_Node);
|
|
|
109
|
|
|
110 function Is_Less_Node_Node (L, R : Node_Type) return Boolean;
|
|
|
111 pragma Inline (Is_Less_Node_Node);
|
|
|
112
|
|
|
113 procedure Replace_Element
|
|
|
114 (Container : in out Set;
|
|
|
115 Index : Count_Type;
|
|
|
116 Item : Element_Type);
|
|
|
117
|
|
|
118 --------------------------
|
|
|
119 -- Local Instantiations --
|
|
|
120 --------------------------
|
|
|
121
|
|
|
122 package Tree_Operations is
|
|
|
123 new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types);
|
|
|
124
|
|
|
125 use Tree_Operations;
|
|
|
126
|
|
|
127 package Element_Keys is
|
|
|
128 new Red_Black_Trees.Generic_Bounded_Keys
|
|
|
129 (Tree_Operations => Tree_Operations,
|
|
|
130 Key_Type => Element_Type,
|
|
|
131 Is_Less_Key_Node => Is_Less_Element_Node,
|
|
|
132 Is_Greater_Key_Node => Is_Greater_Element_Node);
|
|
|
133
|
|
|
134 package Set_Ops is
|
|
|
135 new Red_Black_Trees.Generic_Bounded_Set_Operations
|
|
|
136 (Tree_Operations => Tree_Operations,
|
|
|
137 Set_Type => Set,
|
|
|
138 Assign => Assign,
|
|
|
139 Insert_With_Hint => Insert_With_Hint,
|
|
|
140 Is_Less => Is_Less_Node_Node);
|
|
|
141
|
|
|
142 ---------
|
|
|
143 -- "<" --
|
|
|
144 ---------
|
|
|
145
|
|
|
146 function "<" (Left, Right : Cursor) return Boolean is
|
|
|
147 begin
|
|
|
148 if Checks and then Left.Node = 0 then
|
|
|
149 raise Constraint_Error with "Left cursor equals No_Element";
|
|
|
150 end if;
|
|
|
151
|
|
|
152 if Checks and then Right.Node = 0 then
|
|
|
153 raise Constraint_Error with "Right cursor equals No_Element";
|
|
|
154 end if;
|
|
|
155
|
|
|
156 pragma Assert (Vet (Left.Container.all, Left.Node),
|
|
|
157 "bad Left cursor in ""<""");
|
|
|
158
|
|
|
159 pragma Assert (Vet (Right.Container.all, Right.Node),
|
|
|
160 "bad Right cursor in ""<""");
|
|
|
161
|
|
|
162 declare
|
|
|
163 LN : Nodes_Type renames Left.Container.Nodes;
|
|
|
164 RN : Nodes_Type renames Right.Container.Nodes;
|
|
|
165 begin
|
|
|
166 return LN (Left.Node).Element < RN (Right.Node).Element;
|
|
|
167 end;
|
|
|
168 end "<";
|
|
|
169
|
|
|
170 function "<" (Left : Cursor; Right : Element_Type) return Boolean is
|
|
|
171 begin
|
|
|
172 if Checks and then Left.Node = 0 then
|
|
|
173 raise Constraint_Error with "Left cursor equals No_Element";
|
|
|
174 end if;
|
|
|
175
|
|
|
176 pragma Assert (Vet (Left.Container.all, Left.Node),
|
|
|
177 "bad Left cursor in ""<""");
|
|
|
178
|
|
|
179 return Left.Container.Nodes (Left.Node).Element < Right;
|
|
|
180 end "<";
|
|
|
181
|
|
|
182 function "<" (Left : Element_Type; Right : Cursor) return Boolean is
|
|
|
183 begin
|
|
|
184 if Checks and then Right.Node = 0 then
|
|
|
185 raise Constraint_Error with "Right cursor equals No_Element";
|
|
|
186 end if;
|
|
|
187
|
|
|
188 pragma Assert (Vet (Right.Container.all, Right.Node),
|
|
|
189 "bad Right cursor in ""<""");
|
|
|
190
|
|
|
191 return Left < Right.Container.Nodes (Right.Node).Element;
|
|
|
192 end "<";
|
|
|
193
|
|
|
194 ---------
|
|
|
195 -- "=" --
|
|
|
196 ---------
|
|
|
197
|
|
|
198 function "=" (Left, Right : Set) return Boolean is
|
|
|
199 function Is_Equal_Node_Node (L, R : Node_Type) return Boolean;
|
|
|
200 pragma Inline (Is_Equal_Node_Node);
|
|
|
201
|
|
|
202 function Is_Equal is
|
|
|
203 new Tree_Operations.Generic_Equal (Is_Equal_Node_Node);
|
|
|
204
|
|
|
205 ------------------------
|
|
|
206 -- Is_Equal_Node_Node --
|
|
|
207 ------------------------
|
|
|
208
|
|
|
209 function Is_Equal_Node_Node (L, R : Node_Type) return Boolean is
|
|
|
210 begin
|
|
|
211 return L.Element = R.Element;
|
|
|
212 end Is_Equal_Node_Node;
|
|
|
213
|
|
|
214 -- Start of processing for Is_Equal
|
|
|
215
|
|
|
216 begin
|
|
|
217 return Is_Equal (Left, Right);
|
|
|
218 end "=";
|
|
|
219
|
|
|
220 ---------
|
|
|
221 -- ">" --
|
|
|
222 ---------
|
|
|
223
|
|
|
224 function ">" (Left, Right : Cursor) return Boolean is
|
|
|
225 begin
|
|
|
226 if Checks and then Left.Node = 0 then
|
|
|
227 raise Constraint_Error with "Left cursor equals No_Element";
|
|
|
228 end if;
|
|
|
229
|
|
|
230 if Checks and then Right.Node = 0 then
|
|
|
231 raise Constraint_Error with "Right cursor equals No_Element";
|
|
|
232 end if;
|
|
|
233
|
|
|
234 pragma Assert (Vet (Left.Container.all, Left.Node),
|
|
|
235 "bad Left cursor in "">""");
|
|
|
236
|
|
|
237 pragma Assert (Vet (Right.Container.all, Right.Node),
|
|
|
238 "bad Right cursor in "">""");
|
|
|
239
|
|
|
240 -- L > R same as R < L
|
|
|
241
|
|
|
242 declare
|
|
|
243 LN : Nodes_Type renames Left.Container.Nodes;
|
|
|
244 RN : Nodes_Type renames Right.Container.Nodes;
|
|
|
245 begin
|
|
|
246 return RN (Right.Node).Element < LN (Left.Node).Element;
|
|
|
247 end;
|
|
|
248 end ">";
|
|
|
249
|
|
|
250 function ">" (Left : Element_Type; Right : Cursor) return Boolean is
|
|
|
251 begin
|
|
|
252 if Checks and then Right.Node = 0 then
|
|
|
253 raise Constraint_Error with "Right cursor equals No_Element";
|
|
|
254 end if;
|
|
|
255
|
|
|
256 pragma Assert (Vet (Right.Container.all, Right.Node),
|
|
|
257 "bad Right cursor in "">""");
|
|
|
258
|
|
|
259 return Right.Container.Nodes (Right.Node).Element < Left;
|
|
|
260 end ">";
|
|
|
261
|
|
|
262 function ">" (Left : Cursor; Right : Element_Type) return Boolean is
|
|
|
263 begin
|
|
|
264 if Checks and then Left.Node = 0 then
|
|
|
265 raise Constraint_Error with "Left cursor equals No_Element";
|
|
|
266 end if;
|
|
|
267
|
|
|
268 pragma Assert (Vet (Left.Container.all, Left.Node),
|
|
|
269 "bad Left cursor in "">""");
|
|
|
270
|
|
|
271 return Right < Left.Container.Nodes (Left.Node).Element;
|
|
|
272 end ">";
|
|
|
273
|
|
|
274 ------------
|
|
|
275 -- Assign --
|
|
|
276 ------------
|
|
|
277
|
|
|
278 procedure Assign (Target : in out Set; Source : Set) is
|
|
|
279 procedure Append_Element (Source_Node : Count_Type);
|
|
|
280
|
|
|
281 procedure Append_Elements is
|
|
|
282 new Tree_Operations.Generic_Iteration (Append_Element);
|
|
|
283
|
|
|
284 --------------------
|
|
|
285 -- Append_Element --
|
|
|
286 --------------------
|
|
|
287
|
|
|
288 procedure Append_Element (Source_Node : Count_Type) is
|
|
|
289 SN : Node_Type renames Source.Nodes (Source_Node);
|
|
|
290
|
|
|
291 procedure Set_Element (Node : in out Node_Type);
|
|
|
292 pragma Inline (Set_Element);
|
|
|
293
|
|
|
294 function New_Node return Count_Type;
|
|
|
295 pragma Inline (New_Node);
|
|
|
296
|
|
|
297 procedure Insert_Post is
|
|
|
298 new Element_Keys.Generic_Insert_Post (New_Node);
|
|
|
299
|
|
|
300 procedure Unconditional_Insert_Sans_Hint is
|
|
|
301 new Element_Keys.Generic_Unconditional_Insert (Insert_Post);
|
|
|
302
|
|
|
303 procedure Unconditional_Insert_Avec_Hint is
|
|
|
304 new Element_Keys.Generic_Unconditional_Insert_With_Hint
|
|
|
305 (Insert_Post,
|
|
|
306 Unconditional_Insert_Sans_Hint);
|
|
|
307
|
|
|
308 procedure Allocate is
|
|
|
309 new Tree_Operations.Generic_Allocate (Set_Element);
|
|
|
310
|
|
|
311 --------------
|
|
|
312 -- New_Node --
|
|
|
313 --------------
|
|
|
314
|
|
|
315 function New_Node return Count_Type is
|
|
|
316 Result : Count_Type;
|
|
|
317 begin
|
|
|
318 Allocate (Target, Result);
|
|
|
319 return Result;
|
|
|
320 end New_Node;
|
|
|
321
|
|
|
322 -----------------
|
|
|
323 -- Set_Element --
|
|
|
324 -----------------
|
|
|
325
|
|
|
326 procedure Set_Element (Node : in out Node_Type) is
|
|
|
327 begin
|
|
|
328 Node.Element := SN.Element;
|
|
|
329 end Set_Element;
|
|
|
330
|
|
|
331 Target_Node : Count_Type;
|
|
|
332
|
|
|
333 -- Start of processing for Append_Element
|
|
|
334
|
|
|
335 begin
|
|
|
336 Unconditional_Insert_Avec_Hint
|
|
|
337 (Tree => Target,
|
|
|
338 Hint => 0,
|
|
|
339 Key => SN.Element,
|
|
|
340 Node => Target_Node);
|
|
|
341 end Append_Element;
|
|
|
342
|
|
|
343 -- Start of processing for Assign
|
|
|
344
|
|
|
345 begin
|
|
|
346 if Target'Address = Source'Address then
|
|
|
347 return;
|
|
|
348 end if;
|
|
|
349
|
|
|
350 if Checks and then Target.Capacity < Source.Length then
|
|
|
351 raise Capacity_Error
|
|
|
352 with "Target capacity is less than Source length";
|
|
|
353 end if;
|
|
|
354
|
|
|
355 Target.Clear;
|
|
|
356 Append_Elements (Source);
|
|
|
357 end Assign;
|
|
|
358
|
|
|
359 -------------
|
|
|
360 -- Ceiling --
|
|
|
361 -------------
|
|
|
362
|
|
|
363 function Ceiling (Container : Set; Item : Element_Type) return Cursor is
|
|
|
364 Node : constant Count_Type :=
|
|
|
365 Element_Keys.Ceiling (Container, Item);
|
|
|
366 begin
|
|
|
367 return (if Node = 0 then No_Element
|
|
|
368 else Cursor'(Container'Unrestricted_Access, Node));
|
|
|
369 end Ceiling;
|
|
|
370
|
|
|
371 -----------
|
|
|
372 -- Clear --
|
|
|
373 -----------
|
|
|
374
|
|
|
375 procedure Clear (Container : in out Set) is
|
|
|
376 begin
|
|
|
377 Tree_Operations.Clear_Tree (Container);
|
|
|
378 end Clear;
|
|
|
379
|
|
|
380 -----------
|
|
|
381 -- Color --
|
|
|
382 -----------
|
|
|
383
|
|
|
384 function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is
|
|
|
385 begin
|
|
|
386 return Node.Color;
|
|
|
387 end Color;
|
|
|
388
|
|
|
389 ------------------------
|
|
|
390 -- Constant_Reference --
|
|
|
391 ------------------------
|
|
|
392
|
|
|
393 function Constant_Reference
|
|
|
394 (Container : aliased Set;
|
|
|
395 Position : Cursor) return Constant_Reference_Type
|
|
|
396 is
|
|
|
397 begin
|
|
|
398 if Checks and then Position.Container = null then
|
|
|
399 raise Constraint_Error with "Position cursor has no element";
|
|
|
400 end if;
|
|
|
401
|
|
|
402 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
403 then
|
|
|
404 raise Program_Error with
|
|
|
405 "Position cursor designates wrong container";
|
|
|
406 end if;
|
|
|
407
|
|
|
408 pragma Assert
|
|
|
409 (Vet (Container, Position.Node),
|
|
|
410 "bad cursor in Constant_Reference");
|
|
|
411
|
|
|
412 declare
|
|
|
413 N : Node_Type renames Container.Nodes (Position.Node);
|
|
|
414 TC : constant Tamper_Counts_Access :=
|
|
|
415 Container.TC'Unrestricted_Access;
|
|
|
416 begin
|
|
|
417 return R : constant Constant_Reference_Type :=
|
|
|
418 (Element => N.Element'Access,
|
|
|
419 Control => (Controlled with TC))
|
|
|
420 do
|
|
|
421 Lock (TC.all);
|
|
|
422 end return;
|
|
|
423 end;
|
|
|
424 end Constant_Reference;
|
|
|
425
|
|
|
426 --------------
|
|
|
427 -- Contains --
|
|
|
428 --------------
|
|
|
429
|
|
|
430 function Contains
|
|
|
431 (Container : Set;
|
|
|
432 Item : Element_Type) return Boolean
|
|
|
433 is
|
|
|
434 begin
|
|
|
435 return Find (Container, Item) /= No_Element;
|
|
|
436 end Contains;
|
|
|
437
|
|
|
438 ----------
|
|
|
439 -- Copy --
|
|
|
440 ----------
|
|
|
441
|
|
|
442 function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
|
|
|
443 C : Count_Type;
|
|
|
444
|
|
|
445 begin
|
|
|
446 if Capacity = 0 then
|
|
|
447 C := Source.Length;
|
|
|
448 elsif Capacity >= Source.Length then
|
|
|
449 C := Capacity;
|
|
|
450 elsif Checks then
|
|
|
451 raise Capacity_Error with "Capacity value too small";
|
|
|
452 end if;
|
|
|
453
|
|
|
454 return Target : Set (Capacity => C) do
|
|
|
455 Assign (Target => Target, Source => Source);
|
|
|
456 end return;
|
|
|
457 end Copy;
|
|
|
458
|
|
|
459 ------------
|
|
|
460 -- Delete --
|
|
|
461 ------------
|
|
|
462
|
|
|
463 procedure Delete (Container : in out Set; Position : in out Cursor) is
|
|
|
464 begin
|
|
|
465 if Checks and then Position.Node = 0 then
|
|
|
466 raise Constraint_Error with "Position cursor equals No_Element";
|
|
|
467 end if;
|
|
|
468
|
|
|
469 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
470 then
|
|
|
471 raise Program_Error with "Position cursor designates wrong set";
|
|
|
472 end if;
|
|
|
473
|
|
|
474 TC_Check (Container.TC);
|
|
|
475
|
|
|
476 pragma Assert (Vet (Container, Position.Node),
|
|
|
477 "bad cursor in Delete");
|
|
|
478
|
|
|
479 Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
|
|
|
480 Tree_Operations.Free (Container, Position.Node);
|
|
|
481
|
|
|
482 Position := No_Element;
|
|
|
483 end Delete;
|
|
|
484
|
|
|
485 procedure Delete (Container : in out Set; Item : Element_Type) is
|
|
|
486 X : constant Count_Type := Element_Keys.Find (Container, Item);
|
|
|
487
|
|
|
488 begin
|
|
|
489 Tree_Operations.Delete_Node_Sans_Free (Container, X);
|
|
|
490
|
|
|
491 if Checks and then X = 0 then
|
|
|
492 raise Constraint_Error with "attempt to delete element not in set";
|
|
|
493 end if;
|
|
|
494
|
|
|
495 Tree_Operations.Free (Container, X);
|
|
|
496 end Delete;
|
|
|
497
|
|
|
498 ------------------
|
|
|
499 -- Delete_First --
|
|
|
500 ------------------
|
|
|
501
|
|
|
502 procedure Delete_First (Container : in out Set) is
|
|
|
503 X : constant Count_Type := Container.First;
|
|
|
504 begin
|
|
|
505 if X /= 0 then
|
|
|
506 Tree_Operations.Delete_Node_Sans_Free (Container, X);
|
|
|
507 Tree_Operations.Free (Container, X);
|
|
|
508 end if;
|
|
|
509 end Delete_First;
|
|
|
510
|
|
|
511 -----------------
|
|
|
512 -- Delete_Last --
|
|
|
513 -----------------
|
|
|
514
|
|
|
515 procedure Delete_Last (Container : in out Set) is
|
|
|
516 X : constant Count_Type := Container.Last;
|
|
|
517 begin
|
|
|
518 if X /= 0 then
|
|
|
519 Tree_Operations.Delete_Node_Sans_Free (Container, X);
|
|
|
520 Tree_Operations.Free (Container, X);
|
|
|
521 end if;
|
|
|
522 end Delete_Last;
|
|
|
523
|
|
|
524 ----------------
|
|
|
525 -- Difference --
|
|
|
526 ----------------
|
|
|
527
|
|
|
528 procedure Difference (Target : in out Set; Source : Set)
|
|
|
529 renames Set_Ops.Set_Difference;
|
|
|
530
|
|
|
531 function Difference (Left, Right : Set) return Set
|
|
|
532 renames Set_Ops.Set_Difference;
|
|
|
533
|
|
|
534 -------------
|
|
|
535 -- Element --
|
|
|
536 -------------
|
|
|
537
|
|
|
538 function Element (Position : Cursor) return Element_Type is
|
|
|
539 begin
|
|
|
540 if Checks and then Position.Node = 0 then
|
|
|
541 raise Constraint_Error with "Position cursor equals No_Element";
|
|
|
542 end if;
|
|
|
543
|
|
|
544 pragma Assert (Vet (Position.Container.all, Position.Node),
|
|
|
545 "bad cursor in Element");
|
|
|
546
|
|
|
547 return Position.Container.Nodes (Position.Node).Element;
|
|
|
548 end Element;
|
|
|
549
|
|
|
550 -------------------------
|
|
|
551 -- Equivalent_Elements --
|
|
|
552 -------------------------
|
|
|
553
|
|
|
554 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
|
|
|
555 begin
|
|
|
556 return (if Left < Right or else Right < Left then False else True);
|
|
|
557 end Equivalent_Elements;
|
|
|
558
|
|
|
559 ---------------------
|
|
|
560 -- Equivalent_Sets --
|
|
|
561 ---------------------
|
|
|
562
|
|
|
563 function Equivalent_Sets (Left, Right : Set) return Boolean is
|
|
|
564 function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean;
|
|
|
565 pragma Inline (Is_Equivalent_Node_Node);
|
|
|
566
|
|
|
567 function Is_Equivalent is
|
|
|
568 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node);
|
|
|
569
|
|
|
570 -----------------------------
|
|
|
571 -- Is_Equivalent_Node_Node --
|
|
|
572 -----------------------------
|
|
|
573
|
|
|
574 function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is
|
|
|
575 begin
|
|
|
576 return (if L.Element < R.Element then False
|
|
|
577 elsif R.Element < L.Element then False
|
|
|
578 else True);
|
|
|
579 end Is_Equivalent_Node_Node;
|
|
|
580
|
|
|
581 -- Start of processing for Equivalent_Sets
|
|
|
582
|
|
|
583 begin
|
|
|
584 return Is_Equivalent (Left, Right);
|
|
|
585 end Equivalent_Sets;
|
|
|
586
|
|
|
587 -------------
|
|
|
588 -- Exclude --
|
|
|
589 -------------
|
|
|
590
|
|
|
591 procedure Exclude (Container : in out Set; Item : Element_Type) is
|
|
|
592 X : constant Count_Type := Element_Keys.Find (Container, Item);
|
|
|
593 begin
|
|
|
594 if X /= 0 then
|
|
|
595 Tree_Operations.Delete_Node_Sans_Free (Container, X);
|
|
|
596 Tree_Operations.Free (Container, X);
|
|
|
597 end if;
|
|
|
598 end Exclude;
|
|
|
599
|
|
|
600 --------------
|
|
|
601 -- Finalize --
|
|
|
602 --------------
|
|
|
603
|
|
|
604 procedure Finalize (Object : in out Iterator) is
|
|
|
605 begin
|
|
|
606 if Object.Container /= null then
|
|
|
607 Unbusy (Object.Container.TC);
|
|
|
608 end if;
|
|
|
609 end Finalize;
|
|
|
610
|
|
|
611 ----------
|
|
|
612 -- Find --
|
|
|
613 ----------
|
|
|
614
|
|
|
615 function Find (Container : Set; Item : Element_Type) return Cursor is
|
|
|
616 Node : constant Count_Type := Element_Keys.Find (Container, Item);
|
|
|
617 begin
|
|
|
618 return (if Node = 0 then No_Element
|
|
|
619 else Cursor'(Container'Unrestricted_Access, Node));
|
|
|
620 end Find;
|
|
|
621
|
|
|
622 -----------
|
|
|
623 -- First --
|
|
|
624 -----------
|
|
|
625
|
|
|
626 function First (Container : Set) return Cursor is
|
|
|
627 begin
|
|
|
628 return (if Container.First = 0 then No_Element
|
|
|
629 else Cursor'(Container'Unrestricted_Access, Container.First));
|
|
|
630 end First;
|
|
|
631
|
|
|
632 function First (Object : Iterator) return Cursor is
|
|
|
633 begin
|
|
|
634 -- The value of the iterator object's Node component influences the
|
|
|
635 -- behavior of the First (and Last) selector function.
|
|
|
636
|
|
|
637 -- When the Node component is 0, this means the iterator object was
|
|
|
638 -- constructed without a start expression, in which case the (forward)
|
|
|
639 -- iteration starts from the (logical) beginning of the entire sequence
|
|
|
640 -- of items (corresponding to Container.First, for a forward iterator).
|
|
|
641
|
|
|
642 -- Otherwise, this is iteration over a partial sequence of items. When
|
|
|
643 -- the Node component is positive, the iterator object was constructed
|
|
|
644 -- with a start expression, that specifies the position from which the
|
|
|
645 -- (forward) partial iteration begins.
|
|
|
646
|
|
|
647 if Object.Node = 0 then
|
|
|
648 return Bounded_Ordered_Sets.First (Object.Container.all);
|
|
|
649 else
|
|
|
650 return Cursor'(Object.Container, Object.Node);
|
|
|
651 end if;
|
|
|
652 end First;
|
|
|
653
|
|
|
654 -------------------
|
|
|
655 -- First_Element --
|
|
|
656 -------------------
|
|
|
657
|
|
|
658 function First_Element (Container : Set) return Element_Type is
|
|
|
659 begin
|
|
|
660 if Checks and then Container.First = 0 then
|
|
|
661 raise Constraint_Error with "set is empty";
|
|
|
662 end if;
|
|
|
663
|
|
|
664 return Container.Nodes (Container.First).Element;
|
|
|
665 end First_Element;
|
|
|
666
|
|
|
667 -----------
|
|
|
668 -- Floor --
|
|
|
669 -----------
|
|
|
670
|
|
|
671 function Floor (Container : Set; Item : Element_Type) return Cursor is
|
|
|
672 Node : constant Count_Type := Element_Keys.Floor (Container, Item);
|
|
|
673 begin
|
|
|
674 return (if Node = 0 then No_Element
|
|
|
675 else Cursor'(Container'Unrestricted_Access, Node));
|
|
|
676 end Floor;
|
|
|
677
|
|
|
678 ------------------
|
|
|
679 -- Generic_Keys --
|
|
|
680 ------------------
|
|
|
681
|
|
|
682 package body Generic_Keys is
|
|
|
683
|
|
|
684 -----------------------
|
|
|
685 -- Local Subprograms --
|
|
|
686 -----------------------
|
|
|
687
|
|
|
688 function Is_Greater_Key_Node
|
|
|
689 (Left : Key_Type;
|
|
|
690 Right : Node_Type) return Boolean;
|
|
|
691 pragma Inline (Is_Greater_Key_Node);
|
|
|
692
|
|
|
693 function Is_Less_Key_Node
|
|
|
694 (Left : Key_Type;
|
|
|
695 Right : Node_Type) return Boolean;
|
|
|
696 pragma Inline (Is_Less_Key_Node);
|
|
|
697
|
|
|
698 --------------------------
|
|
|
699 -- Local Instantiations --
|
|
|
700 --------------------------
|
|
|
701
|
|
|
702 package Key_Keys is
|
|
|
703 new Red_Black_Trees.Generic_Bounded_Keys
|
|
|
704 (Tree_Operations => Tree_Operations,
|
|
|
705 Key_Type => Key_Type,
|
|
|
706 Is_Less_Key_Node => Is_Less_Key_Node,
|
|
|
707 Is_Greater_Key_Node => Is_Greater_Key_Node);
|
|
|
708
|
|
|
709 -------------
|
|
|
710 -- Ceiling --
|
|
|
711 -------------
|
|
|
712
|
|
|
713 function Ceiling (Container : Set; Key : Key_Type) return Cursor is
|
|
|
714 Node : constant Count_Type :=
|
|
|
715 Key_Keys.Ceiling (Container, Key);
|
|
|
716 begin
|
|
|
717 return (if Node = 0 then No_Element
|
|
|
718 else Cursor'(Container'Unrestricted_Access, Node));
|
|
|
719 end Ceiling;
|
|
|
720
|
|
|
721 ------------------------
|
|
|
722 -- Constant_Reference --
|
|
|
723 ------------------------
|
|
|
724
|
|
|
725 function Constant_Reference
|
|
|
726 (Container : aliased Set;
|
|
|
727 Key : Key_Type) return Constant_Reference_Type
|
|
|
728 is
|
|
|
729 Node : constant Count_Type := Key_Keys.Find (Container, Key);
|
|
|
730
|
|
|
731 begin
|
|
|
732 if Checks and then Node = 0 then
|
|
|
733 raise Constraint_Error with "key not in set";
|
|
|
734 end if;
|
|
|
735
|
|
|
736 declare
|
|
|
737 N : Node_Type renames Container.Nodes (Node);
|
|
|
738 TC : constant Tamper_Counts_Access :=
|
|
|
739 Container.TC'Unrestricted_Access;
|
|
|
740 begin
|
|
|
741 return R : constant Constant_Reference_Type :=
|
|
|
742 (Element => N.Element'Access,
|
|
|
743 Control => (Controlled with TC))
|
|
|
744 do
|
|
|
745 Lock (TC.all);
|
|
|
746 end return;
|
|
|
747 end;
|
|
|
748 end Constant_Reference;
|
|
|
749
|
|
|
750 --------------
|
|
|
751 -- Contains --
|
|
|
752 --------------
|
|
|
753
|
|
|
754 function Contains (Container : Set; Key : Key_Type) return Boolean is
|
|
|
755 begin
|
|
|
756 return Find (Container, Key) /= No_Element;
|
|
|
757 end Contains;
|
|
|
758
|
|
|
759 ------------
|
|
|
760 -- Delete --
|
|
|
761 ------------
|
|
|
762
|
|
|
763 procedure Delete (Container : in out Set; Key : Key_Type) is
|
|
|
764 X : constant Count_Type := Key_Keys.Find (Container, Key);
|
|
|
765
|
|
|
766 begin
|
|
|
767 if Checks and then X = 0 then
|
|
|
768 raise Constraint_Error with "attempt to delete key not in set";
|
|
|
769 end if;
|
|
|
770
|
|
|
771 Tree_Operations.Delete_Node_Sans_Free (Container, X);
|
|
|
772 Tree_Operations.Free (Container, X);
|
|
|
773 end Delete;
|
|
|
774
|
|
|
775 -------------
|
|
|
776 -- Element --
|
|
|
777 -------------
|
|
|
778
|
|
|
779 function Element (Container : Set; Key : Key_Type) return Element_Type is
|
|
|
780 Node : constant Count_Type := Key_Keys.Find (Container, Key);
|
|
|
781
|
|
|
782 begin
|
|
|
783 if Checks and then Node = 0 then
|
|
|
784 raise Constraint_Error with "key not in set";
|
|
|
785 end if;
|
|
|
786
|
|
|
787 return Container.Nodes (Node).Element;
|
|
|
788 end Element;
|
|
|
789
|
|
|
790 ---------------------
|
|
|
791 -- Equivalent_Keys --
|
|
|
792 ---------------------
|
|
|
793
|
|
|
794 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
|
|
|
795 begin
|
|
|
796 return (if Left < Right or else Right < Left then False else True);
|
|
|
797 end Equivalent_Keys;
|
|
|
798
|
|
|
799 -------------
|
|
|
800 -- Exclude --
|
|
|
801 -------------
|
|
|
802
|
|
|
803 procedure Exclude (Container : in out Set; Key : Key_Type) is
|
|
|
804 X : constant Count_Type := Key_Keys.Find (Container, Key);
|
|
|
805 begin
|
|
|
806 if X /= 0 then
|
|
|
807 Tree_Operations.Delete_Node_Sans_Free (Container, X);
|
|
|
808 Tree_Operations.Free (Container, X);
|
|
|
809 end if;
|
|
|
810 end Exclude;
|
|
|
811
|
|
|
812 --------------
|
|
|
813 -- Finalize --
|
|
|
814 --------------
|
|
|
815
|
|
|
816 procedure Finalize (Control : in out Reference_Control_Type) is
|
|
|
817 begin
|
|
|
818 if Control.Container /= null then
|
|
|
819 Impl.Reference_Control_Type (Control).Finalize;
|
|
|
820
|
|
|
821 if Checks and then not (Key (Control.Pos) = Control.Old_Key.all)
|
|
|
822 then
|
|
|
823 Delete (Control.Container.all, Key (Control.Pos));
|
|
|
824 raise Program_Error;
|
|
|
825 end if;
|
|
|
826
|
|
|
827 Control.Container := null;
|
|
|
828 end if;
|
|
|
829 end Finalize;
|
|
|
830
|
|
|
831 ----------
|
|
|
832 -- Find --
|
|
|
833 ----------
|
|
|
834
|
|
|
835 function Find (Container : Set; Key : Key_Type) return Cursor is
|
|
|
836 Node : constant Count_Type := Key_Keys.Find (Container, Key);
|
|
|
837 begin
|
|
|
838 return (if Node = 0 then No_Element
|
|
|
839 else Cursor'(Container'Unrestricted_Access, Node));
|
|
|
840 end Find;
|
|
|
841
|
|
|
842 -----------
|
|
|
843 -- Floor --
|
|
|
844 -----------
|
|
|
845
|
|
|
846 function Floor (Container : Set; Key : Key_Type) return Cursor is
|
|
|
847 Node : constant Count_Type := Key_Keys.Floor (Container, Key);
|
|
|
848 begin
|
|
|
849 return (if Node = 0 then No_Element
|
|
|
850 else Cursor'(Container'Unrestricted_Access, Node));
|
|
|
851 end Floor;
|
|
|
852
|
|
|
853 -------------------------
|
|
|
854 -- Is_Greater_Key_Node --
|
|
|
855 -------------------------
|
|
|
856
|
|
|
857 function Is_Greater_Key_Node
|
|
|
858 (Left : Key_Type;
|
|
|
859 Right : Node_Type) return Boolean
|
|
|
860 is
|
|
|
861 begin
|
|
|
862 return Key (Right.Element) < Left;
|
|
|
863 end Is_Greater_Key_Node;
|
|
|
864
|
|
|
865 ----------------------
|
|
|
866 -- Is_Less_Key_Node --
|
|
|
867 ----------------------
|
|
|
868
|
|
|
869 function Is_Less_Key_Node
|
|
|
870 (Left : Key_Type;
|
|
|
871 Right : Node_Type) return Boolean
|
|
|
872 is
|
|
|
873 begin
|
|
|
874 return Left < Key (Right.Element);
|
|
|
875 end Is_Less_Key_Node;
|
|
|
876
|
|
|
877 ---------
|
|
|
878 -- Key --
|
|
|
879 ---------
|
|
|
880
|
|
|
881 function Key (Position : Cursor) return Key_Type is
|
|
|
882 begin
|
|
|
883 if Checks and then Position.Node = 0 then
|
|
|
884 raise Constraint_Error with
|
|
|
885 "Position cursor equals No_Element";
|
|
|
886 end if;
|
|
|
887
|
|
|
888 pragma Assert (Vet (Position.Container.all, Position.Node),
|
|
|
889 "bad cursor in Key");
|
|
|
890
|
|
|
891 return Key (Position.Container.Nodes (Position.Node).Element);
|
|
|
892 end Key;
|
|
|
893
|
|
|
894 ----------
|
|
|
895 -- Read --
|
|
|
896 ----------
|
|
|
897
|
|
|
898 procedure Read
|
|
|
899 (Stream : not null access Root_Stream_Type'Class;
|
|
|
900 Item : out Reference_Type)
|
|
|
901 is
|
|
|
902 begin
|
|
|
903 raise Program_Error with "attempt to stream reference";
|
|
|
904 end Read;
|
|
|
905
|
|
|
906 ------------------------------
|
|
|
907 -- Reference_Preserving_Key --
|
|
|
908 ------------------------------
|
|
|
909
|
|
|
910 function Reference_Preserving_Key
|
|
|
911 (Container : aliased in out Set;
|
|
|
912 Position : Cursor) return Reference_Type
|
|
|
913 is
|
|
|
914 begin
|
|
|
915 if Checks and then Position.Container = null then
|
|
|
916 raise Constraint_Error with "Position cursor has no element";
|
|
|
917 end if;
|
|
|
918
|
|
|
919 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
920 then
|
|
|
921 raise Program_Error with
|
|
|
922 "Position cursor designates wrong container";
|
|
|
923 end if;
|
|
|
924
|
|
|
925 pragma Assert
|
|
|
926 (Vet (Container, Position.Node),
|
|
|
927 "bad cursor in function Reference_Preserving_Key");
|
|
|
928
|
|
|
929 declare
|
|
|
930 N : Node_Type renames Container.Nodes (Position.Node);
|
|
|
931 begin
|
|
|
932 return R : constant Reference_Type :=
|
|
|
933 (Element => N.Element'Access,
|
|
|
934 Control =>
|
|
|
935 (Controlled with
|
|
|
936 Container.TC'Unrestricted_Access,
|
|
|
937 Container => Container'Access,
|
|
|
938 Pos => Position,
|
|
|
939 Old_Key => new Key_Type'(Key (Position))))
|
|
|
940 do
|
|
|
941 Lock (Container.TC);
|
|
|
942 end return;
|
|
|
943 end;
|
|
|
944 end Reference_Preserving_Key;
|
|
|
945
|
|
|
946 function Reference_Preserving_Key
|
|
|
947 (Container : aliased in out Set;
|
|
|
948 Key : Key_Type) return Reference_Type
|
|
|
949 is
|
|
|
950 Node : constant Count_Type := Key_Keys.Find (Container, Key);
|
|
|
951
|
|
|
952 begin
|
|
|
953 if Checks and then Node = 0 then
|
|
|
954 raise Constraint_Error with "key not in set";
|
|
|
955 end if;
|
|
|
956
|
|
|
957 declare
|
|
|
958 N : Node_Type renames Container.Nodes (Node);
|
|
|
959 begin
|
|
|
960 return R : constant Reference_Type :=
|
|
|
961 (Element => N.Element'Access,
|
|
|
962 Control =>
|
|
|
963 (Controlled with
|
|
|
964 Container.TC'Unrestricted_Access,
|
|
|
965 Container => Container'Access,
|
|
|
966 Pos => Find (Container, Key),
|
|
|
967 Old_Key => new Key_Type'(Key)))
|
|
|
968 do
|
|
|
969 Lock (Container.TC);
|
|
|
970 end return;
|
|
|
971 end;
|
|
|
972 end Reference_Preserving_Key;
|
|
|
973
|
|
|
974 -------------
|
|
|
975 -- Replace --
|
|
|
976 -------------
|
|
|
977
|
|
|
978 procedure Replace
|
|
|
979 (Container : in out Set;
|
|
|
980 Key : Key_Type;
|
|
|
981 New_Item : Element_Type)
|
|
|
982 is
|
|
|
983 Node : constant Count_Type := Key_Keys.Find (Container, Key);
|
|
|
984
|
|
|
985 begin
|
|
|
986 if Checks and then Node = 0 then
|
|
|
987 raise Constraint_Error with
|
|
|
988 "attempt to replace key not in set";
|
|
|
989 end if;
|
|
|
990
|
|
|
991 Replace_Element (Container, Node, New_Item);
|
|
|
992 end Replace;
|
|
|
993
|
|
|
994 -----------------------------------
|
|
|
995 -- Update_Element_Preserving_Key --
|
|
|
996 -----------------------------------
|
|
|
997
|
|
|
998 procedure Update_Element_Preserving_Key
|
|
|
999 (Container : in out Set;
|
|
|
1000 Position : Cursor;
|
|
|
1001 Process : not null access procedure (Element : in out Element_Type))
|
|
|
1002 is
|
|
|
1003 begin
|
|
|
1004 if Checks and then Position.Node = 0 then
|
|
|
1005 raise Constraint_Error with
|
|
|
1006 "Position cursor equals No_Element";
|
|
|
1007 end if;
|
|
|
1008
|
|
|
1009 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1010 then
|
|
|
1011 raise Program_Error with
|
|
|
1012 "Position cursor designates wrong set";
|
|
|
1013 end if;
|
|
|
1014
|
|
|
1015 pragma Assert (Vet (Container, Position.Node),
|
|
|
1016 "bad cursor in Update_Element_Preserving_Key");
|
|
|
1017
|
|
|
1018 -- Per AI05-0022, the container implementation is required to detect
|
|
|
1019 -- element tampering by a generic actual subprogram.
|
|
|
1020
|
|
|
1021 declare
|
|
|
1022 N : Node_Type renames Container.Nodes (Position.Node);
|
|
|
1023 E : Element_Type renames N.Element;
|
|
|
1024 K : constant Key_Type := Key (E);
|
|
|
1025 Lock : With_Lock (Container.TC'Unrestricted_Access);
|
|
|
1026 begin
|
|
|
1027 Process (E);
|
|
|
1028 if Equivalent_Keys (K, Key (E)) then
|
|
|
1029 return;
|
|
|
1030 end if;
|
|
|
1031 end;
|
|
|
1032
|
|
|
1033 Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node);
|
|
|
1034 Tree_Operations.Free (Container, Position.Node);
|
|
|
1035
|
|
|
1036 raise Program_Error with "key was modified";
|
|
|
1037 end Update_Element_Preserving_Key;
|
|
|
1038
|
|
|
1039 -----------
|
|
|
1040 -- Write --
|
|
|
1041 -----------
|
|
|
1042
|
|
|
1043 procedure Write
|
|
|
1044 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1045 Item : Reference_Type)
|
|
|
1046 is
|
|
|
1047 begin
|
|
|
1048 raise Program_Error with "attempt to stream reference";
|
|
|
1049 end Write;
|
|
|
1050 end Generic_Keys;
|
|
|
1051
|
|
|
1052 ------------------------
|
|
|
1053 -- Get_Element_Access --
|
|
|
1054 ------------------------
|
|
|
1055
|
|
|
1056 function Get_Element_Access
|
|
|
1057 (Position : Cursor) return not null Element_Access is
|
|
|
1058 begin
|
|
|
1059 return Position.Container.Nodes (Position.Node).Element'Access;
|
|
|
1060 end Get_Element_Access;
|
|
|
1061
|
|
|
1062 -----------------
|
|
|
1063 -- Has_Element --
|
|
|
1064 -----------------
|
|
|
1065
|
|
|
1066 function Has_Element (Position : Cursor) return Boolean is
|
|
|
1067 begin
|
|
|
1068 return Position /= No_Element;
|
|
|
1069 end Has_Element;
|
|
|
1070
|
|
|
1071 -------------
|
|
|
1072 -- Include --
|
|
|
1073 -------------
|
|
|
1074
|
|
|
1075 procedure Include (Container : in out Set; New_Item : Element_Type) is
|
|
|
1076 Position : Cursor;
|
|
|
1077 Inserted : Boolean;
|
|
|
1078
|
|
|
1079 begin
|
|
|
1080 Insert (Container, New_Item, Position, Inserted);
|
|
|
1081
|
|
|
1082 if not Inserted then
|
|
|
1083 TE_Check (Container.TC);
|
|
|
1084
|
|
|
1085 Container.Nodes (Position.Node).Element := New_Item;
|
|
|
1086 end if;
|
|
|
1087 end Include;
|
|
|
1088
|
|
|
1089 ------------
|
|
|
1090 -- Insert --
|
|
|
1091 ------------
|
|
|
1092
|
|
|
1093 procedure Insert
|
|
|
1094 (Container : in out Set;
|
|
|
1095 New_Item : Element_Type;
|
|
|
1096 Position : out Cursor;
|
|
|
1097 Inserted : out Boolean)
|
|
|
1098 is
|
|
|
1099 begin
|
|
|
1100 Insert_Sans_Hint
|
|
|
1101 (Container,
|
|
|
1102 New_Item,
|
|
|
1103 Position.Node,
|
|
|
1104 Inserted);
|
|
|
1105
|
|
|
1106 Position.Container := Container'Unrestricted_Access;
|
|
|
1107 end Insert;
|
|
|
1108
|
|
|
1109 procedure Insert
|
|
|
1110 (Container : in out Set;
|
|
|
1111 New_Item : Element_Type)
|
|
|
1112 is
|
|
|
1113 Position : Cursor;
|
|
|
1114 pragma Unreferenced (Position);
|
|
|
1115
|
|
|
1116 Inserted : Boolean;
|
|
|
1117
|
|
|
1118 begin
|
|
|
1119 Insert (Container, New_Item, Position, Inserted);
|
|
|
1120
|
|
|
1121 if Checks and then not Inserted then
|
|
|
1122 raise Constraint_Error with
|
|
|
1123 "attempt to insert element already in set";
|
|
|
1124 end if;
|
|
|
1125 end Insert;
|
|
|
1126
|
|
|
1127 ----------------------
|
|
|
1128 -- Insert_Sans_Hint --
|
|
|
1129 ----------------------
|
|
|
1130
|
|
|
1131 procedure Insert_Sans_Hint
|
|
|
1132 (Container : in out Set;
|
|
|
1133 New_Item : Element_Type;
|
|
|
1134 Node : out Count_Type;
|
|
|
1135 Inserted : out Boolean)
|
|
|
1136 is
|
|
|
1137 procedure Set_Element (Node : in out Node_Type);
|
|
|
1138 pragma Inline (Set_Element);
|
|
|
1139
|
|
|
1140 function New_Node return Count_Type;
|
|
|
1141 pragma Inline (New_Node);
|
|
|
1142
|
|
|
1143 procedure Insert_Post is
|
|
|
1144 new Element_Keys.Generic_Insert_Post (New_Node);
|
|
|
1145
|
|
|
1146 procedure Conditional_Insert_Sans_Hint is
|
|
|
1147 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
|
|
|
1148
|
|
|
1149 procedure Allocate is
|
|
|
1150 new Tree_Operations.Generic_Allocate (Set_Element);
|
|
|
1151
|
|
|
1152 --------------
|
|
|
1153 -- New_Node --
|
|
|
1154 --------------
|
|
|
1155
|
|
|
1156 function New_Node return Count_Type is
|
|
|
1157 Result : Count_Type;
|
|
|
1158 begin
|
|
|
1159 Allocate (Container, Result);
|
|
|
1160 return Result;
|
|
|
1161 end New_Node;
|
|
|
1162
|
|
|
1163 -----------------
|
|
|
1164 -- Set_Element --
|
|
|
1165 -----------------
|
|
|
1166
|
|
|
1167 procedure Set_Element (Node : in out Node_Type) is
|
|
|
1168 begin
|
|
|
1169 Node.Element := New_Item;
|
|
|
1170 end Set_Element;
|
|
|
1171
|
|
|
1172 -- Start of processing for Insert_Sans_Hint
|
|
|
1173
|
|
|
1174 begin
|
|
|
1175 TC_Check (Container.TC);
|
|
|
1176
|
|
|
1177 Conditional_Insert_Sans_Hint
|
|
|
1178 (Container,
|
|
|
1179 New_Item,
|
|
|
1180 Node,
|
|
|
1181 Inserted);
|
|
|
1182 end Insert_Sans_Hint;
|
|
|
1183
|
|
|
1184 ----------------------
|
|
|
1185 -- Insert_With_Hint --
|
|
|
1186 ----------------------
|
|
|
1187
|
|
|
1188 procedure Insert_With_Hint
|
|
|
1189 (Dst_Set : in out Set;
|
|
|
1190 Dst_Hint : Count_Type;
|
|
|
1191 Src_Node : Node_Type;
|
|
|
1192 Dst_Node : out Count_Type)
|
|
|
1193 is
|
|
|
1194 Success : Boolean;
|
|
|
1195 pragma Unreferenced (Success);
|
|
|
1196
|
|
|
1197 procedure Set_Element (Node : in out Node_Type);
|
|
|
1198 pragma Inline (Set_Element);
|
|
|
1199
|
|
|
1200 function New_Node return Count_Type;
|
|
|
1201 pragma Inline (New_Node);
|
|
|
1202
|
|
|
1203 procedure Insert_Post is
|
|
|
1204 new Element_Keys.Generic_Insert_Post (New_Node);
|
|
|
1205
|
|
|
1206 procedure Insert_Sans_Hint is
|
|
|
1207 new Element_Keys.Generic_Conditional_Insert (Insert_Post);
|
|
|
1208
|
|
|
1209 procedure Local_Insert_With_Hint is
|
|
|
1210 new Element_Keys.Generic_Conditional_Insert_With_Hint
|
|
|
1211 (Insert_Post,
|
|
|
1212 Insert_Sans_Hint);
|
|
|
1213
|
|
|
1214 procedure Allocate is
|
|
|
1215 new Tree_Operations.Generic_Allocate (Set_Element);
|
|
|
1216
|
|
|
1217 --------------
|
|
|
1218 -- New_Node --
|
|
|
1219 --------------
|
|
|
1220
|
|
|
1221 function New_Node return Count_Type is
|
|
|
1222 Result : Count_Type;
|
|
|
1223 begin
|
|
|
1224 Allocate (Dst_Set, Result);
|
|
|
1225 return Result;
|
|
|
1226 end New_Node;
|
|
|
1227
|
|
|
1228 -----------------
|
|
|
1229 -- Set_Element --
|
|
|
1230 -----------------
|
|
|
1231
|
|
|
1232 procedure Set_Element (Node : in out Node_Type) is
|
|
|
1233 begin
|
|
|
1234 Node.Element := Src_Node.Element;
|
|
|
1235 end Set_Element;
|
|
|
1236
|
|
|
1237 -- Start of processing for Insert_With_Hint
|
|
|
1238
|
|
|
1239 begin
|
|
|
1240 Local_Insert_With_Hint
|
|
|
1241 (Dst_Set,
|
|
|
1242 Dst_Hint,
|
|
|
1243 Src_Node.Element,
|
|
|
1244 Dst_Node,
|
|
|
1245 Success);
|
|
|
1246 end Insert_With_Hint;
|
|
|
1247
|
|
|
1248 ------------------
|
|
|
1249 -- Intersection --
|
|
|
1250 ------------------
|
|
|
1251
|
|
|
1252 procedure Intersection (Target : in out Set; Source : Set)
|
|
|
1253 renames Set_Ops.Set_Intersection;
|
|
|
1254
|
|
|
1255 function Intersection (Left, Right : Set) return Set
|
|
|
1256 renames Set_Ops.Set_Intersection;
|
|
|
1257
|
|
|
1258 --------------
|
|
|
1259 -- Is_Empty --
|
|
|
1260 --------------
|
|
|
1261
|
|
|
1262 function Is_Empty (Container : Set) return Boolean is
|
|
|
1263 begin
|
|
|
1264 return Container.Length = 0;
|
|
|
1265 end Is_Empty;
|
|
|
1266
|
|
|
1267 -----------------------------
|
|
|
1268 -- Is_Greater_Element_Node --
|
|
|
1269 -----------------------------
|
|
|
1270
|
|
|
1271 function Is_Greater_Element_Node
|
|
|
1272 (Left : Element_Type;
|
|
|
1273 Right : Node_Type) return Boolean
|
|
|
1274 is
|
|
|
1275 begin
|
|
|
1276 -- Compute e > node same as node < e
|
|
|
1277
|
|
|
1278 return Right.Element < Left;
|
|
|
1279 end Is_Greater_Element_Node;
|
|
|
1280
|
|
|
1281 --------------------------
|
|
|
1282 -- Is_Less_Element_Node --
|
|
|
1283 --------------------------
|
|
|
1284
|
|
|
1285 function Is_Less_Element_Node
|
|
|
1286 (Left : Element_Type;
|
|
|
1287 Right : Node_Type) return Boolean
|
|
|
1288 is
|
|
|
1289 begin
|
|
|
1290 return Left < Right.Element;
|
|
|
1291 end Is_Less_Element_Node;
|
|
|
1292
|
|
|
1293 -----------------------
|
|
|
1294 -- Is_Less_Node_Node --
|
|
|
1295 -----------------------
|
|
|
1296
|
|
|
1297 function Is_Less_Node_Node (L, R : Node_Type) return Boolean is
|
|
|
1298 begin
|
|
|
1299 return L.Element < R.Element;
|
|
|
1300 end Is_Less_Node_Node;
|
|
|
1301
|
|
|
1302 ---------------
|
|
|
1303 -- Is_Subset --
|
|
|
1304 ---------------
|
|
|
1305
|
|
|
1306 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean
|
|
|
1307 renames Set_Ops.Set_Subset;
|
|
|
1308
|
|
|
1309 -------------
|
|
|
1310 -- Iterate --
|
|
|
1311 -------------
|
|
|
1312
|
|
|
1313 procedure Iterate
|
|
|
1314 (Container : Set;
|
|
|
1315 Process : not null access procedure (Position : Cursor))
|
|
|
1316 is
|
|
|
1317 procedure Process_Node (Node : Count_Type);
|
|
|
1318 pragma Inline (Process_Node);
|
|
|
1319
|
|
|
1320 procedure Local_Iterate is
|
|
|
1321 new Tree_Operations.Generic_Iteration (Process_Node);
|
|
|
1322
|
|
|
1323 ------------------
|
|
|
1324 -- Process_Node --
|
|
|
1325 ------------------
|
|
|
1326
|
|
|
1327 procedure Process_Node (Node : Count_Type) is
|
|
|
1328 begin
|
|
|
1329 Process (Cursor'(Container'Unrestricted_Access, Node));
|
|
|
1330 end Process_Node;
|
|
|
1331
|
|
|
1332 S : Set renames Container'Unrestricted_Access.all;
|
|
|
1333 Busy : With_Busy (S.TC'Unrestricted_Access);
|
|
|
1334
|
|
|
1335 -- Start of processing for Iterate
|
|
|
1336
|
|
|
1337 begin
|
|
|
1338 Local_Iterate (S);
|
|
|
1339 end Iterate;
|
|
|
1340
|
|
|
1341 function Iterate (Container : Set)
|
|
|
1342 return Set_Iterator_Interfaces.Reversible_Iterator'class
|
|
|
1343 is
|
|
|
1344 begin
|
|
|
1345 -- The value of the Node component influences the behavior of the First
|
|
|
1346 -- and Last selector functions of the iterator object. When the Node
|
|
|
1347 -- component is 0 (as is the case here), this means the iterator object
|
|
|
1348 -- was constructed without a start expression. This is a complete
|
|
|
1349 -- iterator, meaning that the iteration starts from the (logical)
|
|
|
1350 -- beginning of the sequence of items.
|
|
|
1351
|
|
|
1352 -- Note: For a forward iterator, Container.First is the beginning, and
|
|
|
1353 -- for a reverse iterator, Container.Last is the beginning.
|
|
|
1354
|
|
|
1355 return It : constant Iterator :=
|
|
|
1356 Iterator'(Limited_Controlled with
|
|
|
1357 Container => Container'Unrestricted_Access,
|
|
|
1358 Node => 0)
|
|
|
1359 do
|
|
|
1360 Busy (Container.TC'Unrestricted_Access.all);
|
|
|
1361 end return;
|
|
|
1362 end Iterate;
|
|
|
1363
|
|
|
1364 function Iterate (Container : Set; Start : Cursor)
|
|
|
1365 return Set_Iterator_Interfaces.Reversible_Iterator'class
|
|
|
1366 is
|
|
|
1367 begin
|
|
|
1368 -- It was formerly the case that when Start = No_Element, the partial
|
|
|
1369 -- iterator was defined to behave the same as for a complete iterator,
|
|
|
1370 -- and iterate over the entire sequence of items. However, those
|
|
|
1371 -- semantics were unintuitive and arguably error-prone (it is too easy
|
|
|
1372 -- to accidentally create an endless loop), and so they were changed,
|
|
|
1373 -- per the ARG meeting in Denver on 2011/11. However, there was no
|
|
|
1374 -- consensus about what positive meaning this corner case should have,
|
|
|
1375 -- and so it was decided to simply raise an exception. This does imply,
|
|
|
1376 -- however, that it is not possible to use a partial iterator to specify
|
|
|
1377 -- an empty sequence of items.
|
|
|
1378
|
|
|
1379 if Checks and then Start = No_Element then
|
|
|
1380 raise Constraint_Error with
|
|
|
1381 "Start position for iterator equals No_Element";
|
|
|
1382 end if;
|
|
|
1383
|
|
|
1384 if Checks and then Start.Container /= Container'Unrestricted_Access then
|
|
|
1385 raise Program_Error with
|
|
|
1386 "Start cursor of Iterate designates wrong set";
|
|
|
1387 end if;
|
|
|
1388
|
|
|
1389 pragma Assert (Vet (Container, Start.Node),
|
|
|
1390 "Start cursor of Iterate is bad");
|
|
|
1391
|
|
|
1392 -- The value of the Node component influences the behavior of the First
|
|
|
1393 -- and Last selector functions of the iterator object. When the Node
|
|
|
1394 -- component is positive (as is the case here), it means that this
|
|
|
1395 -- is a partial iteration, over a subset of the complete sequence of
|
|
|
1396 -- items. The iterator object was constructed with a start expression,
|
|
|
1397 -- indicating the position from which the iteration begins. (Note that
|
|
|
1398 -- the start position has the same value irrespective of whether this
|
|
|
1399 -- is a forward or reverse iteration.)
|
|
|
1400
|
|
|
1401 return It : constant Iterator :=
|
|
|
1402 Iterator'(Limited_Controlled with
|
|
|
1403 Container => Container'Unrestricted_Access,
|
|
|
1404 Node => Start.Node)
|
|
|
1405 do
|
|
|
1406 Busy (Container.TC'Unrestricted_Access.all);
|
|
|
1407 end return;
|
|
|
1408 end Iterate;
|
|
|
1409
|
|
|
1410 ----------
|
|
|
1411 -- Last --
|
|
|
1412 ----------
|
|
|
1413
|
|
|
1414 function Last (Container : Set) return Cursor is
|
|
|
1415 begin
|
|
|
1416 return (if Container.Last = 0 then No_Element
|
|
|
1417 else Cursor'(Container'Unrestricted_Access, Container.Last));
|
|
|
1418 end Last;
|
|
|
1419
|
|
|
1420 function Last (Object : Iterator) return Cursor is
|
|
|
1421 begin
|
|
|
1422 -- The value of the iterator object's Node component influences the
|
|
|
1423 -- behavior of the Last (and First) selector function.
|
|
|
1424
|
|
|
1425 -- When the Node component is 0, this means the iterator object was
|
|
|
1426 -- constructed without a start expression, in which case the (reverse)
|
|
|
1427 -- iteration starts from the (logical) beginning of the entire sequence
|
|
|
1428 -- (corresponding to Container.Last, for a reverse iterator).
|
|
|
1429
|
|
|
1430 -- Otherwise, this is iteration over a partial sequence of items. When
|
|
|
1431 -- the Node component is positive, the iterator object was constructed
|
|
|
1432 -- with a start expression, that specifies the position from which the
|
|
|
1433 -- (reverse) partial iteration begins.
|
|
|
1434
|
|
|
1435 if Object.Node = 0 then
|
|
|
1436 return Bounded_Ordered_Sets.Last (Object.Container.all);
|
|
|
1437 else
|
|
|
1438 return Cursor'(Object.Container, Object.Node);
|
|
|
1439 end if;
|
|
|
1440 end Last;
|
|
|
1441
|
|
|
1442 ------------------
|
|
|
1443 -- Last_Element --
|
|
|
1444 ------------------
|
|
|
1445
|
|
|
1446 function Last_Element (Container : Set) return Element_Type is
|
|
|
1447 begin
|
|
|
1448 if Checks and then Container.Last = 0 then
|
|
|
1449 raise Constraint_Error with "set is empty";
|
|
|
1450 end if;
|
|
|
1451
|
|
|
1452 return Container.Nodes (Container.Last).Element;
|
|
|
1453 end Last_Element;
|
|
|
1454
|
|
|
1455 ----------
|
|
|
1456 -- Left --
|
|
|
1457 ----------
|
|
|
1458
|
|
|
1459 function Left (Node : Node_Type) return Count_Type is
|
|
|
1460 begin
|
|
|
1461 return Node.Left;
|
|
|
1462 end Left;
|
|
|
1463
|
|
|
1464 ------------
|
|
|
1465 -- Length --
|
|
|
1466 ------------
|
|
|
1467
|
|
|
1468 function Length (Container : Set) return Count_Type is
|
|
|
1469 begin
|
|
|
1470 return Container.Length;
|
|
|
1471 end Length;
|
|
|
1472
|
|
|
1473 ----------
|
|
|
1474 -- Move --
|
|
|
1475 ----------
|
|
|
1476
|
|
|
1477 procedure Move (Target : in out Set; Source : in out Set) is
|
|
|
1478 begin
|
|
|
1479 if Target'Address = Source'Address then
|
|
|
1480 return;
|
|
|
1481 end if;
|
|
|
1482
|
|
|
1483 TC_Check (Source.TC);
|
|
|
1484
|
|
|
1485 Target.Assign (Source);
|
|
|
1486 Source.Clear;
|
|
|
1487 end Move;
|
|
|
1488
|
|
|
1489 ----------
|
|
|
1490 -- Next --
|
|
|
1491 ----------
|
|
|
1492
|
|
|
1493 function Next (Position : Cursor) return Cursor is
|
|
|
1494 begin
|
|
|
1495 if Position = No_Element then
|
|
|
1496 return No_Element;
|
|
|
1497 end if;
|
|
|
1498
|
|
|
1499 pragma Assert (Vet (Position.Container.all, Position.Node),
|
|
|
1500 "bad cursor in Next");
|
|
|
1501
|
|
|
1502 declare
|
|
|
1503 Node : constant Count_Type :=
|
|
|
1504 Tree_Operations.Next (Position.Container.all, Position.Node);
|
|
|
1505
|
|
|
1506 begin
|
|
|
1507 if Node = 0 then
|
|
|
1508 return No_Element;
|
|
|
1509 end if;
|
|
|
1510
|
|
|
1511 return Cursor'(Position.Container, Node);
|
|
|
1512 end;
|
|
|
1513 end Next;
|
|
|
1514
|
|
|
1515 procedure Next (Position : in out Cursor) is
|
|
|
1516 begin
|
|
|
1517 Position := Next (Position);
|
|
|
1518 end Next;
|
|
|
1519
|
|
|
1520 function Next (Object : Iterator; Position : Cursor) return Cursor is
|
|
|
1521 begin
|
|
|
1522 if Position.Container = null then
|
|
|
1523 return No_Element;
|
|
|
1524 end if;
|
|
|
1525
|
|
|
1526 if Checks and then Position.Container /= Object.Container then
|
|
|
1527 raise Program_Error with
|
|
|
1528 "Position cursor of Next designates wrong set";
|
|
|
1529 end if;
|
|
|
1530
|
|
|
1531 return Next (Position);
|
|
|
1532 end Next;
|
|
|
1533
|
|
|
1534 -------------
|
|
|
1535 -- Overlap --
|
|
|
1536 -------------
|
|
|
1537
|
|
|
1538 function Overlap (Left, Right : Set) return Boolean
|
|
|
1539 renames Set_Ops.Set_Overlap;
|
|
|
1540
|
|
|
1541 ------------
|
|
|
1542 -- Parent --
|
|
|
1543 ------------
|
|
|
1544
|
|
|
1545 function Parent (Node : Node_Type) return Count_Type is
|
|
|
1546 begin
|
|
|
1547 return Node.Parent;
|
|
|
1548 end Parent;
|
|
|
1549
|
|
|
1550 --------------
|
|
|
1551 -- Previous --
|
|
|
1552 --------------
|
|
|
1553
|
|
|
1554 function Previous (Position : Cursor) return Cursor is
|
|
|
1555 begin
|
|
|
1556 if Position = No_Element then
|
|
|
1557 return No_Element;
|
|
|
1558 end if;
|
|
|
1559
|
|
|
1560 pragma Assert (Vet (Position.Container.all, Position.Node),
|
|
|
1561 "bad cursor in Previous");
|
|
|
1562
|
|
|
1563 declare
|
|
|
1564 Node : constant Count_Type :=
|
|
|
1565 Tree_Operations.Previous (Position.Container.all, Position.Node);
|
|
|
1566 begin
|
|
|
1567 return (if Node = 0 then No_Element
|
|
|
1568 else Cursor'(Position.Container, Node));
|
|
|
1569 end;
|
|
|
1570 end Previous;
|
|
|
1571
|
|
|
1572 procedure Previous (Position : in out Cursor) is
|
|
|
1573 begin
|
|
|
1574 Position := Previous (Position);
|
|
|
1575 end Previous;
|
|
|
1576
|
|
|
1577 function Previous (Object : Iterator; Position : Cursor) return Cursor is
|
|
|
1578 begin
|
|
|
1579 if Position.Container = null then
|
|
|
1580 return No_Element;
|
|
|
1581 end if;
|
|
|
1582
|
|
|
1583 if Checks and then Position.Container /= Object.Container then
|
|
|
1584 raise Program_Error with
|
|
|
1585 "Position cursor of Previous designates wrong set";
|
|
|
1586 end if;
|
|
|
1587
|
|
|
1588 return Previous (Position);
|
|
|
1589 end Previous;
|
|
|
1590
|
|
|
1591 ----------------------
|
|
|
1592 -- Pseudo_Reference --
|
|
|
1593 ----------------------
|
|
|
1594
|
|
|
1595 function Pseudo_Reference
|
|
|
1596 (Container : aliased Set'Class) return Reference_Control_Type
|
|
|
1597 is
|
|
|
1598 TC : constant Tamper_Counts_Access :=
|
|
|
1599 Container.TC'Unrestricted_Access;
|
|
|
1600 begin
|
|
|
1601 return R : constant Reference_Control_Type := (Controlled with TC) do
|
|
|
1602 Lock (TC.all);
|
|
|
1603 end return;
|
|
|
1604 end Pseudo_Reference;
|
|
|
1605
|
|
|
1606 -------------------
|
|
|
1607 -- Query_Element --
|
|
|
1608 -------------------
|
|
|
1609
|
|
|
1610 procedure Query_Element
|
|
|
1611 (Position : Cursor;
|
|
|
1612 Process : not null access procedure (Element : Element_Type))
|
|
|
1613 is
|
|
|
1614 begin
|
|
|
1615 if Checks and then Position.Node = 0 then
|
|
|
1616 raise Constraint_Error with "Position cursor equals No_Element";
|
|
|
1617 end if;
|
|
|
1618
|
|
|
1619 pragma Assert (Vet (Position.Container.all, Position.Node),
|
|
|
1620 "bad cursor in Query_Element");
|
|
|
1621
|
|
|
1622 declare
|
|
|
1623 S : Set renames Position.Container.all;
|
|
|
1624 Lock : With_Lock (S.TC'Unrestricted_Access);
|
|
|
1625 begin
|
|
|
1626 Process (S.Nodes (Position.Node).Element);
|
|
|
1627 end;
|
|
|
1628 end Query_Element;
|
|
|
1629
|
|
|
1630 ----------
|
|
|
1631 -- Read --
|
|
|
1632 ----------
|
|
|
1633
|
|
|
1634 procedure Read
|
|
|
1635 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1636 Container : out Set)
|
|
|
1637 is
|
|
|
1638 procedure Read_Element (Node : in out Node_Type);
|
|
|
1639 pragma Inline (Read_Element);
|
|
|
1640
|
|
|
1641 procedure Allocate is
|
|
|
1642 new Tree_Operations.Generic_Allocate (Read_Element);
|
|
|
1643
|
|
|
1644 procedure Read_Elements is
|
|
|
1645 new Tree_Operations.Generic_Read (Allocate);
|
|
|
1646
|
|
|
1647 ------------------
|
|
|
1648 -- Read_Element --
|
|
|
1649 ------------------
|
|
|
1650
|
|
|
1651 procedure Read_Element (Node : in out Node_Type) is
|
|
|
1652 begin
|
|
|
1653 Element_Type'Read (Stream, Node.Element);
|
|
|
1654 end Read_Element;
|
|
|
1655
|
|
|
1656 -- Start of processing for Read
|
|
|
1657
|
|
|
1658 begin
|
|
|
1659 Read_Elements (Stream, Container);
|
|
|
1660 end Read;
|
|
|
1661
|
|
|
1662 procedure Read
|
|
|
1663 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1664 Item : out Cursor)
|
|
|
1665 is
|
|
|
1666 begin
|
|
|
1667 raise Program_Error with "attempt to stream set cursor";
|
|
|
1668 end Read;
|
|
|
1669
|
|
|
1670 procedure Read
|
|
|
1671 (Stream : not null access Root_Stream_Type'Class;
|
|
|
1672 Item : out Constant_Reference_Type)
|
|
|
1673 is
|
|
|
1674 begin
|
|
|
1675 raise Program_Error with "attempt to stream reference";
|
|
|
1676 end Read;
|
|
|
1677
|
|
|
1678 -------------
|
|
|
1679 -- Replace --
|
|
|
1680 -------------
|
|
|
1681
|
|
|
1682 procedure Replace (Container : in out Set; New_Item : Element_Type) is
|
|
|
1683 Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
|
|
|
1684
|
|
|
1685 begin
|
|
|
1686 if Checks and then Node = 0 then
|
|
|
1687 raise Constraint_Error with
|
|
|
1688 "attempt to replace element not in set";
|
|
|
1689 end if;
|
|
|
1690
|
|
|
1691 TE_Check (Container.TC);
|
|
|
1692
|
|
|
1693 Container.Nodes (Node).Element := New_Item;
|
|
|
1694 end Replace;
|
|
|
1695
|
|
|
1696 ---------------------
|
|
|
1697 -- Replace_Element --
|
|
|
1698 ---------------------
|
|
|
1699
|
|
|
1700 procedure Replace_Element
|
|
|
1701 (Container : in out Set;
|
|
|
1702 Index : Count_Type;
|
|
|
1703 Item : Element_Type)
|
|
|
1704 is
|
|
|
1705 pragma Assert (Index /= 0);
|
|
|
1706
|
|
|
1707 function New_Node return Count_Type;
|
|
|
1708 pragma Inline (New_Node);
|
|
|
1709
|
|
|
1710 procedure Local_Insert_Post is
|
|
|
1711 new Element_Keys.Generic_Insert_Post (New_Node);
|
|
|
1712
|
|
|
1713 procedure Local_Insert_Sans_Hint is
|
|
|
1714 new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
|
|
|
1715
|
|
|
1716 procedure Local_Insert_With_Hint is
|
|
|
1717 new Element_Keys.Generic_Conditional_Insert_With_Hint
|
|
|
1718 (Local_Insert_Post,
|
|
|
1719 Local_Insert_Sans_Hint);
|
|
|
1720
|
|
|
1721 Nodes : Nodes_Type renames Container.Nodes;
|
|
|
1722 Node : Node_Type renames Nodes (Index);
|
|
|
1723
|
|
|
1724 --------------
|
|
|
1725 -- New_Node --
|
|
|
1726 --------------
|
|
|
1727
|
|
|
1728 function New_Node return Count_Type is
|
|
|
1729 begin
|
|
|
1730 Node.Element := Item;
|
|
|
1731 Node.Color := Red_Black_Trees.Red;
|
|
|
1732 Node.Parent := 0;
|
|
|
1733 Node.Right := 0;
|
|
|
1734 Node.Left := 0;
|
|
|
1735 return Index;
|
|
|
1736 end New_Node;
|
|
|
1737
|
|
|
1738 Hint : Count_Type;
|
|
|
1739 Result : Count_Type;
|
|
|
1740 Inserted : Boolean;
|
|
|
1741 Compare : Boolean;
|
|
|
1742
|
|
|
1743 -- Start of processing for Replace_Element
|
|
|
1744
|
|
|
1745 begin
|
|
|
1746 -- Replace_Element assigns value Item to the element designated by Node,
|
|
|
1747 -- per certain semantic constraints, described as follows.
|
|
|
1748
|
|
|
1749 -- If Item is equivalent to the element, then element is replaced and
|
|
|
1750 -- there's nothing else to do. This is the easy case.
|
|
|
1751
|
|
|
1752 -- If Item is not equivalent, then the node will (possibly) have to move
|
|
|
1753 -- to some other place in the tree. This is slighly more complicated,
|
|
|
1754 -- because we must ensure that Item is not equivalent to some other
|
|
|
1755 -- element in the tree (in which case, the replacement is not allowed).
|
|
|
1756
|
|
|
1757 -- Determine whether Item is equivalent to element on the specified
|
|
|
1758 -- node.
|
|
|
1759
|
|
|
1760 declare
|
|
|
1761 Lock : With_Lock (Container.TC'Unrestricted_Access);
|
|
|
1762 begin
|
|
|
1763 Compare := (if Item < Node.Element then False
|
|
|
1764 elsif Node.Element < Item then False
|
|
|
1765 else True);
|
|
|
1766 end;
|
|
|
1767
|
|
|
1768 if Compare then
|
|
|
1769
|
|
|
1770 -- Item is equivalent to the node's element, so we will not have to
|
|
|
1771 -- move the node.
|
|
|
1772
|
|
|
1773 TE_Check (Container.TC);
|
|
|
1774
|
|
|
1775 Node.Element := Item;
|
|
|
1776 return;
|
|
|
1777 end if;
|
|
|
1778
|
|
|
1779 -- The replacement Item is not equivalent to the element on the
|
|
|
1780 -- specified node, which means that it will need to be re-inserted in a
|
|
|
1781 -- different position in the tree. We must now determine whether Item is
|
|
|
1782 -- equivalent to some other element in the tree (which would prohibit
|
|
|
1783 -- the assignment and hence the move).
|
|
|
1784
|
|
|
1785 -- Ceiling returns the smallest element equivalent or greater than the
|
|
|
1786 -- specified Item; if there is no such element, then it returns 0.
|
|
|
1787
|
|
|
1788 Hint := Element_Keys.Ceiling (Container, Item);
|
|
|
1789
|
|
|
1790 if Hint /= 0 then -- Item <= Nodes (Hint).Element
|
|
|
1791 declare
|
|
|
1792 Lock : With_Lock (Container.TC'Unrestricted_Access);
|
|
|
1793 begin
|
|
|
1794 Compare := Item < Nodes (Hint).Element;
|
|
|
1795 end;
|
|
|
1796
|
|
|
1797 -- Item is equivalent to Nodes (Hint).Element
|
|
|
1798
|
|
|
1799 if Checks and then not Compare then
|
|
|
1800
|
|
|
1801 -- Ceiling returns an element that is equivalent or greater than
|
|
|
1802 -- Item. If Item is "not less than" the element, then by
|
|
|
1803 -- elimination we know that Item is equivalent to the element.
|
|
|
1804
|
|
|
1805 -- But this means that it is not possible to assign the value of
|
|
|
1806 -- Item to the specified element (on Node), because a different
|
|
|
1807 -- element (on Hint) equivalent to Item already exsits. (Were we
|
|
|
1808 -- to change Node's element value, we would have to move Node, but
|
|
|
1809 -- we would be unable to move the Node, because its new position
|
|
|
1810 -- in the tree is already occupied by an equivalent element.)
|
|
|
1811
|
|
|
1812 raise Program_Error with "attempt to replace existing element";
|
|
|
1813 end if;
|
|
|
1814
|
|
|
1815 -- Item is not equivalent to any other element in the tree
|
|
|
1816 -- (specifically, it is less than Nodes (Hint).Element), so it is
|
|
|
1817 -- safe to assign the value of Item to Node.Element. This means that
|
|
|
1818 -- the node will have to move to a different position in the tree
|
|
|
1819 -- (because its element will have a different value).
|
|
|
1820
|
|
|
1821 -- The nearest (greater) neighbor of Item is Hint. This will be the
|
|
|
1822 -- insertion position of Node (because its element will have Item as
|
|
|
1823 -- its new value).
|
|
|
1824
|
|
|
1825 -- If Node equals Hint, the relative position of Node does not
|
|
|
1826 -- change. This allows us to perform an optimization: we need not
|
|
|
1827 -- remove Node from the tree and then reinsert it with its new value,
|
|
|
1828 -- because it would only be placed in the exact same position.
|
|
|
1829
|
|
|
1830 if Hint = Index then
|
|
|
1831 TE_Check (Container.TC);
|
|
|
1832
|
|
|
1833 Node.Element := Item;
|
|
|
1834 return;
|
|
|
1835 end if;
|
|
|
1836 end if;
|
|
|
1837
|
|
|
1838 -- If we get here, it is because Item was greater than all elements in
|
|
|
1839 -- the tree (Hint = 0), or because Item was less than some element at a
|
|
|
1840 -- different place in the tree (Item < Nodes (Hint).Element and Hint /=
|
|
|
1841 -- Index). In either case, we remove Node from the tree and then insert
|
|
|
1842 -- Item into the tree, onto the same Node.
|
|
|
1843
|
|
|
1844 Tree_Operations.Delete_Node_Sans_Free (Container, Index);
|
|
|
1845
|
|
|
1846 Local_Insert_With_Hint
|
|
|
1847 (Tree => Container,
|
|
|
1848 Position => Hint,
|
|
|
1849 Key => Item,
|
|
|
1850 Node => Result,
|
|
|
1851 Inserted => Inserted);
|
|
|
1852
|
|
|
1853 pragma Assert (Inserted);
|
|
|
1854 pragma Assert (Result = Index);
|
|
|
1855 end Replace_Element;
|
|
|
1856
|
|
|
1857 procedure Replace_Element
|
|
|
1858 (Container : in out Set;
|
|
|
1859 Position : Cursor;
|
|
|
1860 New_Item : Element_Type)
|
|
|
1861 is
|
|
|
1862 begin
|
|
|
1863 if Checks and then Position.Node = 0 then
|
|
|
1864 raise Constraint_Error with
|
|
|
1865 "Position cursor equals No_Element";
|
|
|
1866 end if;
|
|
|
1867
|
|
|
1868 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1869 then
|
|
|
1870 raise Program_Error with
|
|
|
1871 "Position cursor designates wrong set";
|
|
|
1872 end if;
|
|
|
1873
|
|
|
1874 pragma Assert (Vet (Container, Position.Node),
|
|
|
1875 "bad cursor in Replace_Element");
|
|
|
1876
|
|
|
1877 Replace_Element (Container, Position.Node, New_Item);
|
|
|
1878 end Replace_Element;
|
|
|
1879
|
|
|
1880 ---------------------
|
|
|
1881 -- Reverse_Iterate --
|
|
|
1882 ---------------------
|
|
|
1883
|
|
|
1884 procedure Reverse_Iterate
|
|
|
1885 (Container : Set;
|
|
|
1886 Process : not null access procedure (Position : Cursor))
|
|
|
1887 is
|
|
|
1888 procedure Process_Node (Node : Count_Type);
|
|
|
1889 pragma Inline (Process_Node);
|
|
|
1890
|
|
|
1891 procedure Local_Reverse_Iterate is
|
|
|
1892 new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
|
|
|
1893
|
|
|
1894 ------------------
|
|
|
1895 -- Process_Node --
|
|
|
1896 ------------------
|
|
|
1897
|
|
|
1898 procedure Process_Node (Node : Count_Type) is
|
|
|
1899 begin
|
|
|
1900 Process (Cursor'(Container'Unrestricted_Access, Node));
|
|
|
1901 end Process_Node;
|
|
|
1902
|
|
|
1903 S : Set renames Container'Unrestricted_Access.all;
|
|
|
1904 Busy : With_Busy (S.TC'Unrestricted_Access);
|
|
|
1905
|
|
|
1906 -- Start of processing for Reverse_Iterate
|
|
|
1907
|
|
|
1908 begin
|
|
|
1909 Local_Reverse_Iterate (S);
|
|
|
1910 end Reverse_Iterate;
|
|
|
1911
|
|
|
1912 -----------
|
|
|
1913 -- Right --
|
|
|
1914 -----------
|
|
|
1915
|
|
|
1916 function Right (Node : Node_Type) return Count_Type is
|
|
|
1917 begin
|
|
|
1918 return Node.Right;
|
|
|
1919 end Right;
|
|
|
1920
|
|
|
1921 ---------------
|
|
|
1922 -- Set_Color --
|
|
|
1923 ---------------
|
|
|
1924
|
|
|
1925 procedure Set_Color
|
|
|
1926 (Node : in out Node_Type;
|
|
|
1927 Color : Red_Black_Trees.Color_Type)
|
|
|
1928 is
|
|
|
1929 begin
|
|
|
1930 Node.Color := Color;
|
|
|
1931 end Set_Color;
|
|
|
1932
|
|
|
1933 --------------
|
|
|
1934 -- Set_Left --
|
|
|
1935 --------------
|
|
|
1936
|
|
|
1937 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is
|
|
|
1938 begin
|
|
|
1939 Node.Left := Left;
|
|
|
1940 end Set_Left;
|
|
|
1941
|
|
|
1942 ----------------
|
|
|
1943 -- Set_Parent --
|
|
|
1944 ----------------
|
|
|
1945
|
|
|
1946 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is
|
|
|
1947 begin
|
|
|
1948 Node.Parent := Parent;
|
|
|
1949 end Set_Parent;
|
|
|
1950
|
|
|
1951 ---------------
|
|
|
1952 -- Set_Right --
|
|
|
1953 ---------------
|
|
|
1954
|
|
|
1955 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is
|
|
|
1956 begin
|
|
|
1957 Node.Right := Right;
|
|
|
1958 end Set_Right;
|
|
|
1959
|
|
|
1960 --------------------------
|
|
|
1961 -- Symmetric_Difference --
|
|
|
1962 --------------------------
|
|
|
1963
|
|
|
1964 procedure Symmetric_Difference (Target : in out Set; Source : Set)
|
|
|
1965 renames Set_Ops.Set_Symmetric_Difference;
|
|
|
1966
|
|
|
1967 function Symmetric_Difference (Left, Right : Set) return Set
|
|
|
1968 renames Set_Ops.Set_Symmetric_Difference;
|
|
|
1969
|
|
|
1970 ------------
|
|
|
1971 -- To_Set --
|
|
|
1972 ------------
|
|
|
1973
|
|
|
1974 function To_Set (New_Item : Element_Type) return Set is
|
|
|
1975 Node : Count_Type;
|
|
|
1976 Inserted : Boolean;
|
|
|
1977 begin
|
|
|
1978 return S : Set (1) do
|
|
|
1979 Insert_Sans_Hint (S, New_Item, Node, Inserted);
|
|
|
1980 pragma Assert (Inserted);
|
|
|
1981 end return;
|
|
|
1982 end To_Set;
|
|
|
1983
|
|
|
1984 -----------
|
|
|
1985 -- Union --
|
|
|
1986 -----------
|
|
|
1987
|
|
|
1988 procedure Union (Target : in out Set; Source : Set)
|
|
|
1989 renames Set_Ops.Set_Union;
|
|
|
1990
|
|
|
1991 function Union (Left, Right : Set) return Set
|
|
|
1992 renames Set_Ops.Set_Union;
|
|
|
1993
|
|
|
1994 -----------
|
|
|
1995 -- Write --
|
|
|
1996 -----------
|
|
|
1997
|
|
|
1998 procedure Write
|
|
|
1999 (Stream : not null access Root_Stream_Type'Class;
|
|
|
2000 Container : Set)
|
|
|
2001 is
|
|
|
2002 procedure Write_Element
|
|
|
2003 (Stream : not null access Root_Stream_Type'Class;
|
|
|
2004 Node : Node_Type);
|
|
|
2005 pragma Inline (Write_Element);
|
|
|
2006
|
|
|
2007 procedure Write_Elements is
|
|
|
2008 new Tree_Operations.Generic_Write (Write_Element);
|
|
|
2009
|
|
|
2010 -------------------
|
|
|
2011 -- Write_Element --
|
|
|
2012 -------------------
|
|
|
2013
|
|
|
2014 procedure Write_Element
|
|
|
2015 (Stream : not null access Root_Stream_Type'Class;
|
|
|
2016 Node : Node_Type)
|
|
|
2017 is
|
|
|
2018 begin
|
|
|
2019 Element_Type'Write (Stream, Node.Element);
|
|
|
2020 end Write_Element;
|
|
|
2021
|
|
|
2022 -- Start of processing for Write
|
|
|
2023
|
|
|
2024 begin
|
|
|
2025 Write_Elements (Stream, Container);
|
|
|
2026 end Write;
|
|
|
2027
|
|
|
2028 procedure Write
|
|
|
2029 (Stream : not null access Root_Stream_Type'Class;
|
|
|
2030 Item : Cursor)
|
|
|
2031 is
|
|
|
2032 begin
|
|
|
2033 raise Program_Error with "attempt to stream set cursor";
|
|
|
2034 end Write;
|
|
|
2035
|
|
|
2036 procedure Write
|
|
|
2037 (Stream : not null access Root_Stream_Type'Class;
|
|
|
2038 Item : Constant_Reference_Type)
|
|
|
2039 is
|
|
|
2040 begin
|
|
|
2041 raise Program_Error with "attempt to stream reference";
|
|
|
2042 end Write;
|
|
|
2043
|
|
|
2044 end Ada.Containers.Bounded_Ordered_Sets;
|
