]>
Commit | Line | Data |
---|---|---|
4c2d6a70 AC |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT LIBRARY COMPONENTS -- | |
4 | -- -- | |
8704d4b3 | 5 | -- A D A . C O N T A I N E R S . O R D E R E D _ S E T S -- |
4c2d6a70 AC |
6 | -- -- |
7 | -- B o d y -- | |
8 | -- -- | |
748086b7 | 9 | -- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- |
4c2d6a70 AC |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
4c2d6a70 AC |
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 -- | |
748086b7 JJ |
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/>. -- | |
4c2d6a70 AC |
26 | -- -- |
27 | -- This unit was originally developed by Matthew J Heaney. -- | |
28 | ------------------------------------------------------------------------------ | |
29 | ||
30 | with Ada.Unchecked_Deallocation; | |
31 | ||
32 | with Ada.Containers.Red_Black_Trees.Generic_Operations; | |
33 | pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); | |
34 | ||
35 | with Ada.Containers.Red_Black_Trees.Generic_Keys; | |
36 | pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); | |
37 | ||
38 | with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; | |
39 | pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); | |
40 | ||
4c2d6a70 AC |
41 | package body Ada.Containers.Ordered_Sets is |
42 | ||
4c2d6a70 AC |
43 | ------------------------------ |
44 | -- Access to Fields of Node -- | |
45 | ------------------------------ | |
46 | ||
47 | -- These subprograms provide functional notation for access to fields | |
8fc789c8 | 48 | -- of a node, and procedural notation for modifying these fields. |
4c2d6a70 AC |
49 | |
50 | function Color (Node : Node_Access) return Color_Type; | |
51 | pragma Inline (Color); | |
52 | ||
53 | function Left (Node : Node_Access) return Node_Access; | |
54 | pragma Inline (Left); | |
55 | ||
56 | function Parent (Node : Node_Access) return Node_Access; | |
57 | pragma Inline (Parent); | |
58 | ||
59 | function Right (Node : Node_Access) return Node_Access; | |
60 | pragma Inline (Right); | |
61 | ||
62 | procedure Set_Color (Node : Node_Access; Color : Color_Type); | |
63 | pragma Inline (Set_Color); | |
64 | ||
65 | procedure Set_Left (Node : Node_Access; Left : Node_Access); | |
66 | pragma Inline (Set_Left); | |
67 | ||
68 | procedure Set_Right (Node : Node_Access; Right : Node_Access); | |
69 | pragma Inline (Set_Right); | |
70 | ||
71 | procedure Set_Parent (Node : Node_Access; Parent : Node_Access); | |
72 | pragma Inline (Set_Parent); | |
73 | ||
74 | ----------------------- | |
75 | -- Local Subprograms -- | |
76 | ----------------------- | |
77 | ||
78 | function Copy_Node (Source : Node_Access) return Node_Access; | |
79 | pragma Inline (Copy_Node); | |
80 | ||
2368f04e MH |
81 | procedure Free (X : in out Node_Access); |
82 | ||
83 | procedure Insert_Sans_Hint | |
84 | (Tree : in out Tree_Type; | |
85 | New_Item : Element_Type; | |
86 | Node : out Node_Access; | |
87 | Inserted : out Boolean); | |
88 | ||
4c2d6a70 AC |
89 | procedure Insert_With_Hint |
90 | (Dst_Tree : in out Tree_Type; | |
91 | Dst_Hint : Node_Access; | |
92 | Src_Node : Node_Access; | |
93 | Dst_Node : out Node_Access); | |
94 | ||
95 | function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; | |
96 | pragma Inline (Is_Equal_Node_Node); | |
97 | ||
98 | function Is_Greater_Element_Node | |
99 | (Left : Element_Type; | |
100 | Right : Node_Access) return Boolean; | |
101 | pragma Inline (Is_Greater_Element_Node); | |
102 | ||
103 | function Is_Less_Element_Node | |
104 | (Left : Element_Type; | |
105 | Right : Node_Access) return Boolean; | |
106 | pragma Inline (Is_Less_Element_Node); | |
107 | ||
108 | function Is_Less_Node_Node (L, R : Node_Access) return Boolean; | |
109 | pragma Inline (Is_Less_Node_Node); | |
110 | ||
8704d4b3 MH |
111 | procedure Replace_Element |
112 | (Tree : in out Tree_Type; | |
113 | Node : Node_Access; | |
114 | Item : Element_Type); | |
115 | ||
4c2d6a70 AC |
116 | -------------------------- |
117 | -- Local Instantiations -- | |
118 | -------------------------- | |
119 | ||
120 | package Tree_Operations is | |
8704d4b3 | 121 | new Red_Black_Trees.Generic_Operations (Tree_Types); |
4c2d6a70 | 122 | |
8704d4b3 MH |
123 | procedure Delete_Tree is |
124 | new Tree_Operations.Generic_Delete_Tree (Free); | |
4c2d6a70 | 125 | |
8704d4b3 MH |
126 | function Copy_Tree is |
127 | new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); | |
128 | ||
129 | use Tree_Operations; | |
4c2d6a70 AC |
130 | |
131 | function Is_Equal is | |
132 | new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); | |
133 | ||
134 | package Element_Keys is | |
135 | new Red_Black_Trees.Generic_Keys | |
136 | (Tree_Operations => Tree_Operations, | |
137 | Key_Type => Element_Type, | |
138 | Is_Less_Key_Node => Is_Less_Element_Node, | |
139 | Is_Greater_Key_Node => Is_Greater_Element_Node); | |
140 | ||
141 | package Set_Ops is | |
142 | new Generic_Set_Operations | |
143 | (Tree_Operations => Tree_Operations, | |
144 | Insert_With_Hint => Insert_With_Hint, | |
145 | Copy_Tree => Copy_Tree, | |
146 | Delete_Tree => Delete_Tree, | |
147 | Is_Less => Is_Less_Node_Node, | |
148 | Free => Free); | |
149 | ||
150 | --------- | |
151 | -- "<" -- | |
152 | --------- | |
153 | ||
154 | function "<" (Left, Right : Cursor) return Boolean is | |
155 | begin | |
ffabcde5 MH |
156 | if Left.Node = null then |
157 | raise Constraint_Error with "Left cursor equals No_Element"; | |
158 | end if; | |
159 | ||
160 | if Right.Node = null then | |
161 | raise Constraint_Error with "Right cursor equals No_Element"; | |
2368f04e MH |
162 | end if; |
163 | ||
164 | pragma Assert (Vet (Left.Container.Tree, Left.Node), | |
165 | "bad Left cursor in ""<"""); | |
166 | ||
167 | pragma Assert (Vet (Right.Container.Tree, Right.Node), | |
168 | "bad Right cursor in ""<"""); | |
169 | ||
4c2d6a70 AC |
170 | return Left.Node.Element < Right.Node.Element; |
171 | end "<"; | |
172 | ||
173 | function "<" (Left : Cursor; Right : Element_Type) return Boolean is | |
174 | begin | |
2368f04e | 175 | if Left.Node = null then |
ffabcde5 | 176 | raise Constraint_Error with "Left cursor equals No_Element"; |
2368f04e MH |
177 | end if; |
178 | ||
179 | pragma Assert (Vet (Left.Container.Tree, Left.Node), | |
180 | "bad Left cursor in ""<"""); | |
181 | ||
4c2d6a70 AC |
182 | return Left.Node.Element < Right; |
183 | end "<"; | |
184 | ||
185 | function "<" (Left : Element_Type; Right : Cursor) return Boolean is | |
186 | begin | |
2368f04e | 187 | if Right.Node = null then |
ffabcde5 | 188 | raise Constraint_Error with "Right cursor equals No_Element"; |
2368f04e MH |
189 | end if; |
190 | ||
191 | pragma Assert (Vet (Right.Container.Tree, Right.Node), | |
192 | "bad Right cursor in ""<"""); | |
193 | ||
4c2d6a70 AC |
194 | return Left < Right.Node.Element; |
195 | end "<"; | |
196 | ||
197 | --------- | |
198 | -- "=" -- | |
199 | --------- | |
200 | ||
201 | function "=" (Left, Right : Set) return Boolean is | |
202 | begin | |
4c2d6a70 AC |
203 | return Is_Equal (Left.Tree, Right.Tree); |
204 | end "="; | |
205 | ||
206 | --------- | |
207 | -- ">" -- | |
208 | --------- | |
209 | ||
210 | function ">" (Left, Right : Cursor) return Boolean is | |
211 | begin | |
ffabcde5 MH |
212 | if Left.Node = null then |
213 | raise Constraint_Error with "Left cursor equals No_Element"; | |
214 | end if; | |
215 | ||
216 | if Right.Node = null then | |
217 | raise Constraint_Error with "Right cursor equals No_Element"; | |
2368f04e MH |
218 | end if; |
219 | ||
220 | pragma Assert (Vet (Left.Container.Tree, Left.Node), | |
221 | "bad Left cursor in "">"""); | |
222 | ||
223 | pragma Assert (Vet (Right.Container.Tree, Right.Node), | |
224 | "bad Right cursor in "">"""); | |
225 | ||
4c2d6a70 AC |
226 | -- L > R same as R < L |
227 | ||
228 | return Right.Node.Element < Left.Node.Element; | |
229 | end ">"; | |
230 | ||
231 | function ">" (Left : Element_Type; Right : Cursor) return Boolean is | |
232 | begin | |
2368f04e | 233 | if Right.Node = null then |
ffabcde5 | 234 | raise Constraint_Error with "Right cursor equals No_Element"; |
2368f04e MH |
235 | end if; |
236 | ||
237 | pragma Assert (Vet (Right.Container.Tree, Right.Node), | |
238 | "bad Right cursor in "">"""); | |
239 | ||
4c2d6a70 AC |
240 | return Right.Node.Element < Left; |
241 | end ">"; | |
242 | ||
243 | function ">" (Left : Cursor; Right : Element_Type) return Boolean is | |
244 | begin | |
2368f04e | 245 | if Left.Node = null then |
ffabcde5 | 246 | raise Constraint_Error with "Left cursor equals No_Element"; |
2368f04e MH |
247 | end if; |
248 | ||
249 | pragma Assert (Vet (Left.Container.Tree, Left.Node), | |
250 | "bad Left cursor in "">"""); | |
251 | ||
4c2d6a70 AC |
252 | return Right < Left.Node.Element; |
253 | end ">"; | |
254 | ||
255 | ------------ | |
256 | -- Adjust -- | |
257 | ------------ | |
258 | ||
3c25856a | 259 | procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree); |
4c2d6a70 | 260 | |
8704d4b3 | 261 | procedure Adjust (Container : in out Set) is |
4c2d6a70 | 262 | begin |
8704d4b3 | 263 | Adjust (Container.Tree); |
4c2d6a70 AC |
264 | end Adjust; |
265 | ||
266 | ------------- | |
267 | -- Ceiling -- | |
268 | ------------- | |
269 | ||
270 | function Ceiling (Container : Set; Item : Element_Type) return Cursor is | |
271 | Node : constant Node_Access := | |
272 | Element_Keys.Ceiling (Container.Tree, Item); | |
273 | ||
274 | begin | |
275 | if Node = null then | |
276 | return No_Element; | |
277 | end if; | |
278 | ||
8704d4b3 | 279 | return Cursor'(Container'Unrestricted_Access, Node); |
4c2d6a70 AC |
280 | end Ceiling; |
281 | ||
282 | ----------- | |
283 | -- Clear -- | |
284 | ----------- | |
285 | ||
3c25856a | 286 | procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree); |
8704d4b3 | 287 | |
4c2d6a70 | 288 | procedure Clear (Container : in out Set) is |
4c2d6a70 | 289 | begin |
8704d4b3 | 290 | Clear (Container.Tree); |
4c2d6a70 AC |
291 | end Clear; |
292 | ||
293 | ----------- | |
294 | -- Color -- | |
295 | ----------- | |
296 | ||
297 | function Color (Node : Node_Access) return Color_Type is | |
298 | begin | |
299 | return Node.Color; | |
300 | end Color; | |
301 | ||
302 | -------------- | |
303 | -- Contains -- | |
304 | -------------- | |
305 | ||
306 | function Contains | |
307 | (Container : Set; | |
308 | Item : Element_Type) return Boolean | |
309 | is | |
310 | begin | |
311 | return Find (Container, Item) /= No_Element; | |
312 | end Contains; | |
313 | ||
314 | --------------- | |
315 | -- Copy_Node -- | |
316 | --------------- | |
317 | ||
318 | function Copy_Node (Source : Node_Access) return Node_Access is | |
319 | Target : constant Node_Access := | |
320 | new Node_Type'(Parent => null, | |
321 | Left => null, | |
322 | Right => null, | |
323 | Color => Source.Color, | |
324 | Element => Source.Element); | |
325 | begin | |
326 | return Target; | |
327 | end Copy_Node; | |
328 | ||
4c2d6a70 AC |
329 | ------------ |
330 | -- Delete -- | |
331 | ------------ | |
332 | ||
333 | procedure Delete (Container : in out Set; Position : in out Cursor) is | |
334 | begin | |
8704d4b3 | 335 | if Position.Node = null then |
ffabcde5 | 336 | raise Constraint_Error with "Position cursor equals No_Element"; |
4c2d6a70 AC |
337 | end if; |
338 | ||
8704d4b3 | 339 | if Position.Container /= Container'Unrestricted_Access then |
ffabcde5 | 340 | raise Program_Error with "Position cursor designates wrong set"; |
4c2d6a70 AC |
341 | end if; |
342 | ||
2368f04e MH |
343 | pragma Assert (Vet (Container.Tree, Position.Node), |
344 | "bad cursor in Delete"); | |
345 | ||
8704d4b3 | 346 | Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); |
4c2d6a70 AC |
347 | Free (Position.Node); |
348 | Position.Container := null; | |
349 | end Delete; | |
350 | ||
351 | procedure Delete (Container : in out Set; Item : Element_Type) is | |
352 | X : Node_Access := Element_Keys.Find (Container.Tree, Item); | |
353 | ||
354 | begin | |
355 | if X = null then | |
ffabcde5 | 356 | raise Constraint_Error with "attempt to delete element not in set"; |
4c2d6a70 AC |
357 | end if; |
358 | ||
8704d4b3 | 359 | Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); |
4c2d6a70 AC |
360 | Free (X); |
361 | end Delete; | |
362 | ||
363 | ------------------ | |
364 | -- Delete_First -- | |
365 | ------------------ | |
366 | ||
367 | procedure Delete_First (Container : in out Set) is | |
8704d4b3 MH |
368 | Tree : Tree_Type renames Container.Tree; |
369 | X : Node_Access := Tree.First; | |
370 | ||
4c2d6a70 | 371 | begin |
8704d4b3 MH |
372 | if X /= null then |
373 | Tree_Operations.Delete_Node_Sans_Free (Tree, X); | |
374 | Free (X); | |
375 | end if; | |
4c2d6a70 AC |
376 | end Delete_First; |
377 | ||
378 | ----------------- | |
379 | -- Delete_Last -- | |
380 | ----------------- | |
381 | ||
382 | procedure Delete_Last (Container : in out Set) is | |
8704d4b3 MH |
383 | Tree : Tree_Type renames Container.Tree; |
384 | X : Node_Access := Tree.Last; | |
4c2d6a70 | 385 | |
4c2d6a70 | 386 | begin |
8704d4b3 MH |
387 | if X /= null then |
388 | Tree_Operations.Delete_Node_Sans_Free (Tree, X); | |
4c2d6a70 | 389 | Free (X); |
8704d4b3 MH |
390 | end if; |
391 | end Delete_Last; | |
4c2d6a70 AC |
392 | |
393 | ---------------- | |
394 | -- Difference -- | |
395 | ---------------- | |
396 | ||
397 | procedure Difference (Target : in out Set; Source : Set) is | |
398 | begin | |
4c2d6a70 AC |
399 | Set_Ops.Difference (Target.Tree, Source.Tree); |
400 | end Difference; | |
401 | ||
402 | function Difference (Left, Right : Set) return Set is | |
8704d4b3 MH |
403 | Tree : constant Tree_Type := |
404 | Set_Ops.Difference (Left.Tree, Right.Tree); | |
4c2d6a70 | 405 | begin |
8704d4b3 | 406 | return Set'(Controlled with Tree); |
4c2d6a70 AC |
407 | end Difference; |
408 | ||
409 | ------------- | |
410 | -- Element -- | |
411 | ------------- | |
412 | ||
413 | function Element (Position : Cursor) return Element_Type is | |
414 | begin | |
2368f04e | 415 | if Position.Node = null then |
ffabcde5 | 416 | raise Constraint_Error with "Position cursor equals No_Element"; |
2368f04e MH |
417 | end if; |
418 | ||
419 | pragma Assert (Vet (Position.Container.Tree, Position.Node), | |
420 | "bad cursor in Element"); | |
421 | ||
4c2d6a70 AC |
422 | return Position.Node.Element; |
423 | end Element; | |
424 | ||
ba355842 MH |
425 | ------------------------- |
426 | -- Equivalent_Elements -- | |
427 | ------------------------- | |
428 | ||
429 | function Equivalent_Elements (Left, Right : Element_Type) return Boolean is | |
430 | begin | |
431 | if Left < Right | |
432 | or else Right < Left | |
433 | then | |
434 | return False; | |
435 | else | |
436 | return True; | |
437 | end if; | |
438 | end Equivalent_Elements; | |
439 | ||
8704d4b3 MH |
440 | --------------------- |
441 | -- Equivalent_Sets -- | |
442 | --------------------- | |
443 | ||
444 | function Equivalent_Sets (Left, Right : Set) return Boolean is | |
445 | function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; | |
446 | pragma Inline (Is_Equivalent_Node_Node); | |
447 | ||
448 | function Is_Equivalent is | |
449 | new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); | |
450 | ||
451 | ----------------------------- | |
452 | -- Is_Equivalent_Node_Node -- | |
453 | ----------------------------- | |
454 | ||
455 | function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is | |
456 | begin | |
457 | if L.Element < R.Element then | |
458 | return False; | |
459 | elsif R.Element < L.Element then | |
460 | return False; | |
461 | else | |
462 | return True; | |
463 | end if; | |
464 | end Is_Equivalent_Node_Node; | |
465 | ||
466 | -- Start of processing for Equivalent_Sets | |
467 | ||
468 | begin | |
469 | return Is_Equivalent (Left.Tree, Right.Tree); | |
470 | end Equivalent_Sets; | |
471 | ||
4c2d6a70 AC |
472 | ------------- |
473 | -- Exclude -- | |
474 | ------------- | |
475 | ||
476 | procedure Exclude (Container : in out Set; Item : Element_Type) is | |
477 | X : Node_Access := Element_Keys.Find (Container.Tree, Item); | |
478 | ||
479 | begin | |
480 | if X /= null then | |
8704d4b3 | 481 | Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); |
4c2d6a70 AC |
482 | Free (X); |
483 | end if; | |
484 | end Exclude; | |
485 | ||
486 | ---------- | |
487 | -- Find -- | |
488 | ---------- | |
489 | ||
490 | function Find (Container : Set; Item : Element_Type) return Cursor is | |
491 | Node : constant Node_Access := | |
492 | Element_Keys.Find (Container.Tree, Item); | |
493 | ||
494 | begin | |
495 | if Node = null then | |
496 | return No_Element; | |
497 | end if; | |
498 | ||
8704d4b3 | 499 | return Cursor'(Container'Unrestricted_Access, Node); |
4c2d6a70 AC |
500 | end Find; |
501 | ||
502 | ----------- | |
503 | -- First -- | |
504 | ----------- | |
505 | ||
506 | function First (Container : Set) return Cursor is | |
507 | begin | |
508 | if Container.Tree.First = null then | |
509 | return No_Element; | |
510 | end if; | |
511 | ||
8704d4b3 | 512 | return Cursor'(Container'Unrestricted_Access, Container.Tree.First); |
4c2d6a70 AC |
513 | end First; |
514 | ||
515 | ------------------- | |
516 | -- First_Element -- | |
517 | ------------------- | |
518 | ||
519 | function First_Element (Container : Set) return Element_Type is | |
520 | begin | |
2368f04e | 521 | if Container.Tree.First = null then |
ffabcde5 | 522 | raise Constraint_Error with "set is empty"; |
2368f04e MH |
523 | end if; |
524 | ||
4c2d6a70 AC |
525 | return Container.Tree.First.Element; |
526 | end First_Element; | |
527 | ||
528 | ----------- | |
529 | -- Floor -- | |
530 | ----------- | |
531 | ||
532 | function Floor (Container : Set; Item : Element_Type) return Cursor is | |
533 | Node : constant Node_Access := | |
534 | Element_Keys.Floor (Container.Tree, Item); | |
535 | ||
536 | begin | |
537 | if Node = null then | |
538 | return No_Element; | |
539 | end if; | |
540 | ||
8704d4b3 | 541 | return Cursor'(Container'Unrestricted_Access, Node); |
4c2d6a70 AC |
542 | end Floor; |
543 | ||
2368f04e MH |
544 | ---------- |
545 | -- Free -- | |
546 | ---------- | |
547 | ||
548 | procedure Free (X : in out Node_Access) is | |
549 | procedure Deallocate is | |
550 | new Ada.Unchecked_Deallocation (Node_Type, Node_Access); | |
551 | ||
552 | begin | |
553 | if X /= null then | |
554 | X.Parent := X; | |
555 | X.Left := X; | |
556 | X.Right := X; | |
557 | ||
558 | Deallocate (X); | |
559 | end if; | |
560 | end Free; | |
561 | ||
4c2d6a70 AC |
562 | ------------------ |
563 | -- Generic_Keys -- | |
564 | ------------------ | |
565 | ||
566 | package body Generic_Keys is | |
567 | ||
568 | ----------------------- | |
569 | -- Local Subprograms -- | |
570 | ----------------------- | |
571 | ||
572 | function Is_Greater_Key_Node | |
573 | (Left : Key_Type; | |
574 | Right : Node_Access) return Boolean; | |
575 | pragma Inline (Is_Greater_Key_Node); | |
576 | ||
577 | function Is_Less_Key_Node | |
578 | (Left : Key_Type; | |
579 | Right : Node_Access) return Boolean; | |
580 | pragma Inline (Is_Less_Key_Node); | |
581 | ||
582 | -------------------------- | |
583 | -- Local Instantiations -- | |
584 | -------------------------- | |
585 | ||
586 | package Key_Keys is | |
587 | new Red_Black_Trees.Generic_Keys | |
588 | (Tree_Operations => Tree_Operations, | |
589 | Key_Type => Key_Type, | |
590 | Is_Less_Key_Node => Is_Less_Key_Node, | |
591 | Is_Greater_Key_Node => Is_Greater_Key_Node); | |
592 | ||
4c2d6a70 AC |
593 | ------------- |
594 | -- Ceiling -- | |
595 | ------------- | |
596 | ||
597 | function Ceiling (Container : Set; Key : Key_Type) return Cursor is | |
598 | Node : constant Node_Access := | |
599 | Key_Keys.Ceiling (Container.Tree, Key); | |
600 | ||
601 | begin | |
602 | if Node = null then | |
603 | return No_Element; | |
604 | end if; | |
605 | ||
8704d4b3 | 606 | return Cursor'(Container'Unrestricted_Access, Node); |
4c2d6a70 AC |
607 | end Ceiling; |
608 | ||
4c2d6a70 AC |
609 | -------------- |
610 | -- Contains -- | |
611 | -------------- | |
612 | ||
613 | function Contains (Container : Set; Key : Key_Type) return Boolean is | |
614 | begin | |
615 | return Find (Container, Key) /= No_Element; | |
616 | end Contains; | |
617 | ||
618 | ------------ | |
619 | -- Delete -- | |
620 | ------------ | |
621 | ||
622 | procedure Delete (Container : in out Set; Key : Key_Type) is | |
623 | X : Node_Access := Key_Keys.Find (Container.Tree, Key); | |
624 | ||
625 | begin | |
626 | if X = null then | |
ffabcde5 | 627 | raise Constraint_Error with "attempt to delete key not in set"; |
4c2d6a70 AC |
628 | end if; |
629 | ||
630 | Delete_Node_Sans_Free (Container.Tree, X); | |
631 | Free (X); | |
632 | end Delete; | |
633 | ||
634 | ------------- | |
635 | -- Element -- | |
636 | ------------- | |
637 | ||
2368f04e MH |
638 | function Element (Container : Set; Key : Key_Type) return Element_Type is |
639 | Node : constant Node_Access := | |
640 | Key_Keys.Find (Container.Tree, Key); | |
8704d4b3 | 641 | |
4c2d6a70 | 642 | begin |
2368f04e | 643 | if Node = null then |
ffabcde5 | 644 | raise Constraint_Error with "key not in set"; |
2368f04e MH |
645 | end if; |
646 | ||
4c2d6a70 AC |
647 | return Node.Element; |
648 | end Element; | |
649 | ||
ba355842 MH |
650 | --------------------- |
651 | -- Equivalent_Keys -- | |
652 | --------------------- | |
653 | ||
654 | function Equivalent_Keys (Left, Right : Key_Type) return Boolean is | |
655 | begin | |
656 | if Left < Right | |
657 | or else Right < Left | |
658 | then | |
659 | return False; | |
660 | else | |
661 | return True; | |
662 | end if; | |
663 | end Equivalent_Keys; | |
664 | ||
4c2d6a70 AC |
665 | ------------- |
666 | -- Exclude -- | |
667 | ------------- | |
668 | ||
669 | procedure Exclude (Container : in out Set; Key : Key_Type) is | |
670 | X : Node_Access := Key_Keys.Find (Container.Tree, Key); | |
8704d4b3 | 671 | |
4c2d6a70 AC |
672 | begin |
673 | if X /= null then | |
674 | Delete_Node_Sans_Free (Container.Tree, X); | |
675 | Free (X); | |
676 | end if; | |
677 | end Exclude; | |
678 | ||
679 | ---------- | |
680 | -- Find -- | |
681 | ---------- | |
682 | ||
683 | function Find (Container : Set; Key : Key_Type) return Cursor is | |
684 | Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); | |
685 | ||
686 | begin | |
687 | if Node = null then | |
688 | return No_Element; | |
689 | end if; | |
690 | ||
8704d4b3 | 691 | return Cursor'(Container'Unrestricted_Access, Node); |
4c2d6a70 AC |
692 | end Find; |
693 | ||
694 | ----------- | |
695 | -- Floor -- | |
696 | ----------- | |
697 | ||
698 | function Floor (Container : Set; Key : Key_Type) return Cursor is | |
699 | Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); | |
700 | ||
701 | begin | |
702 | if Node = null then | |
703 | return No_Element; | |
704 | end if; | |
705 | ||
8704d4b3 | 706 | return Cursor'(Container'Unrestricted_Access, Node); |
4c2d6a70 AC |
707 | end Floor; |
708 | ||
709 | ------------------------- | |
710 | -- Is_Greater_Key_Node -- | |
711 | ------------------------- | |
712 | ||
713 | function Is_Greater_Key_Node | |
714 | (Left : Key_Type; | |
715 | Right : Node_Access) return Boolean | |
716 | is | |
717 | begin | |
ba355842 | 718 | return Key (Right.Element) < Left; |
4c2d6a70 AC |
719 | end Is_Greater_Key_Node; |
720 | ||
721 | ---------------------- | |
722 | -- Is_Less_Key_Node -- | |
723 | ---------------------- | |
724 | ||
725 | function Is_Less_Key_Node | |
726 | (Left : Key_Type; | |
727 | Right : Node_Access) return Boolean | |
728 | is | |
729 | begin | |
ba355842 | 730 | return Left < Key (Right.Element); |
4c2d6a70 AC |
731 | end Is_Less_Key_Node; |
732 | ||
733 | --------- | |
734 | -- Key -- | |
735 | --------- | |
736 | ||
737 | function Key (Position : Cursor) return Key_Type is | |
738 | begin | |
2368f04e | 739 | if Position.Node = null then |
ffabcde5 MH |
740 | raise Constraint_Error with |
741 | "Position cursor equals No_Element"; | |
2368f04e MH |
742 | end if; |
743 | ||
744 | pragma Assert (Vet (Position.Container.Tree, Position.Node), | |
745 | "bad cursor in Key"); | |
746 | ||
4c2d6a70 AC |
747 | return Key (Position.Node.Element); |
748 | end Key; | |
749 | ||
750 | ------------- | |
751 | -- Replace -- | |
752 | ------------- | |
753 | ||
8704d4b3 MH |
754 | procedure Replace |
755 | (Container : in out Set; | |
756 | Key : Key_Type; | |
757 | New_Item : Element_Type) | |
758 | is | |
759 | Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); | |
4c2d6a70 | 760 | |
8704d4b3 MH |
761 | begin |
762 | if Node = null then | |
ffabcde5 MH |
763 | raise Constraint_Error with |
764 | "attempt to replace key not in set"; | |
8704d4b3 | 765 | end if; |
4c2d6a70 | 766 | |
8704d4b3 MH |
767 | Replace_Element (Container.Tree, Node, New_Item); |
768 | end Replace; | |
4c2d6a70 | 769 | |
8704d4b3 MH |
770 | ----------------------------------- |
771 | -- Update_Element_Preserving_Key -- | |
772 | ----------------------------------- | |
773 | ||
774 | procedure Update_Element_Preserving_Key | |
775 | (Container : in out Set; | |
776 | Position : Cursor; | |
777 | Process : not null access procedure (Element : in out Element_Type)) | |
778 | is | |
779 | Tree : Tree_Type renames Container.Tree; | |
780 | ||
781 | begin | |
782 | if Position.Node = null then | |
ffabcde5 MH |
783 | raise Constraint_Error with |
784 | "Position cursor equals No_Element"; | |
8704d4b3 MH |
785 | end if; |
786 | ||
787 | if Position.Container /= Container'Unrestricted_Access then | |
ffabcde5 MH |
788 | raise Program_Error with |
789 | "Position cursor designates wrong set"; | |
8704d4b3 MH |
790 | end if; |
791 | ||
2368f04e MH |
792 | pragma Assert (Vet (Container.Tree, Position.Node), |
793 | "bad cursor in Update_Element_Preserving_Key"); | |
794 | ||
8704d4b3 MH |
795 | declare |
796 | E : Element_Type renames Position.Node.Element; | |
ba355842 | 797 | K : constant Key_Type := Key (E); |
8704d4b3 MH |
798 | |
799 | B : Natural renames Tree.Busy; | |
800 | L : Natural renames Tree.Lock; | |
801 | ||
802 | begin | |
803 | B := B + 1; | |
804 | L := L + 1; | |
805 | ||
806 | begin | |
807 | Process (E); | |
808 | exception | |
809 | when others => | |
810 | L := L - 1; | |
811 | B := B - 1; | |
812 | raise; | |
813 | end; | |
814 | ||
815 | L := L - 1; | |
816 | B := B - 1; | |
817 | ||
ba355842 | 818 | if Equivalent_Keys (K, Key (E)) then |
8704d4b3 MH |
819 | return; |
820 | end if; | |
821 | end; | |
822 | ||
823 | declare | |
824 | X : Node_Access := Position.Node; | |
825 | begin | |
826 | Tree_Operations.Delete_Node_Sans_Free (Tree, X); | |
827 | Free (X); | |
828 | end; | |
829 | ||
ffabcde5 | 830 | raise Program_Error with "key was modified"; |
8704d4b3 | 831 | end Update_Element_Preserving_Key; |
4c2d6a70 AC |
832 | |
833 | end Generic_Keys; | |
834 | ||
835 | ----------------- | |
836 | -- Has_Element -- | |
837 | ----------------- | |
838 | ||
839 | function Has_Element (Position : Cursor) return Boolean is | |
840 | begin | |
841 | return Position /= No_Element; | |
842 | end Has_Element; | |
843 | ||
844 | ------------- | |
845 | -- Include -- | |
846 | ------------- | |
847 | ||
848 | procedure Include (Container : in out Set; New_Item : Element_Type) is | |
849 | Position : Cursor; | |
850 | Inserted : Boolean; | |
851 | ||
852 | begin | |
853 | Insert (Container, New_Item, Position, Inserted); | |
854 | ||
855 | if not Inserted then | |
8704d4b3 | 856 | if Container.Tree.Lock > 0 then |
ffabcde5 MH |
857 | raise Program_Error with |
858 | "attempt to tamper with cursors (set is locked)"; | |
8704d4b3 MH |
859 | end if; |
860 | ||
4c2d6a70 AC |
861 | Position.Node.Element := New_Item; |
862 | end if; | |
863 | end Include; | |
864 | ||
865 | ------------ | |
866 | -- Insert -- | |
867 | ------------ | |
868 | ||
869 | procedure Insert | |
870 | (Container : in out Set; | |
871 | New_Item : Element_Type; | |
872 | Position : out Cursor; | |
873 | Inserted : out Boolean) | |
874 | is | |
4c2d6a70 AC |
875 | begin |
876 | Insert_Sans_Hint | |
877 | (Container.Tree, | |
878 | New_Item, | |
879 | Position.Node, | |
880 | Inserted); | |
881 | ||
8704d4b3 | 882 | Position.Container := Container'Unrestricted_Access; |
4c2d6a70 AC |
883 | end Insert; |
884 | ||
885 | procedure Insert | |
886 | (Container : in out Set; | |
887 | New_Item : Element_Type) | |
888 | is | |
4c2d6a70 | 889 | Position : Cursor; |
67ce0d7e RD |
890 | pragma Unreferenced (Position); |
891 | ||
4c2d6a70 AC |
892 | Inserted : Boolean; |
893 | ||
894 | begin | |
895 | Insert (Container, New_Item, Position, Inserted); | |
896 | ||
897 | if not Inserted then | |
ffabcde5 MH |
898 | raise Constraint_Error with |
899 | "attempt to insert element already in set"; | |
4c2d6a70 AC |
900 | end if; |
901 | end Insert; | |
902 | ||
2368f04e MH |
903 | ---------------------- |
904 | -- Insert_Sans_Hint -- | |
905 | ---------------------- | |
906 | ||
907 | procedure Insert_Sans_Hint | |
908 | (Tree : in out Tree_Type; | |
909 | New_Item : Element_Type; | |
910 | Node : out Node_Access; | |
911 | Inserted : out Boolean) | |
912 | is | |
913 | function New_Node return Node_Access; | |
914 | pragma Inline (New_Node); | |
915 | ||
916 | procedure Insert_Post is | |
917 | new Element_Keys.Generic_Insert_Post (New_Node); | |
918 | ||
919 | procedure Conditional_Insert_Sans_Hint is | |
920 | new Element_Keys.Generic_Conditional_Insert (Insert_Post); | |
921 | ||
922 | -------------- | |
923 | -- New_Node -- | |
924 | -------------- | |
925 | ||
926 | function New_Node return Node_Access is | |
927 | begin | |
928 | return new Node_Type'(Parent => null, | |
929 | Left => null, | |
930 | Right => null, | |
931 | Color => Red_Black_Trees.Red, | |
932 | Element => New_Item); | |
933 | end New_Node; | |
934 | ||
935 | -- Start of processing for Insert_Sans_Hint | |
936 | ||
937 | begin | |
938 | Conditional_Insert_Sans_Hint | |
939 | (Tree, | |
940 | New_Item, | |
941 | Node, | |
942 | Inserted); | |
943 | end Insert_Sans_Hint; | |
944 | ||
4c2d6a70 AC |
945 | ---------------------- |
946 | -- Insert_With_Hint -- | |
947 | ---------------------- | |
948 | ||
949 | procedure Insert_With_Hint | |
950 | (Dst_Tree : in out Tree_Type; | |
951 | Dst_Hint : Node_Access; | |
952 | Src_Node : Node_Access; | |
953 | Dst_Node : out Node_Access) | |
954 | is | |
955 | Success : Boolean; | |
67ce0d7e | 956 | pragma Unreferenced (Success); |
4c2d6a70 AC |
957 | |
958 | function New_Node return Node_Access; | |
959 | pragma Inline (New_Node); | |
960 | ||
961 | procedure Insert_Post is | |
962 | new Element_Keys.Generic_Insert_Post (New_Node); | |
963 | ||
964 | procedure Insert_Sans_Hint is | |
965 | new Element_Keys.Generic_Conditional_Insert (Insert_Post); | |
966 | ||
967 | procedure Local_Insert_With_Hint is | |
968 | new Element_Keys.Generic_Conditional_Insert_With_Hint | |
969 | (Insert_Post, | |
970 | Insert_Sans_Hint); | |
971 | ||
972 | -------------- | |
973 | -- New_Node -- | |
974 | -------------- | |
975 | ||
976 | function New_Node return Node_Access is | |
977 | Node : constant Node_Access := | |
978 | new Node_Type'(Parent => null, | |
979 | Left => null, | |
980 | Right => null, | |
981 | Color => Red, | |
982 | Element => Src_Node.Element); | |
983 | begin | |
984 | return Node; | |
985 | end New_Node; | |
986 | ||
987 | -- Start of processing for Insert_With_Hint | |
988 | ||
989 | begin | |
990 | Local_Insert_With_Hint | |
991 | (Dst_Tree, | |
992 | Dst_Hint, | |
993 | Src_Node.Element, | |
994 | Dst_Node, | |
995 | Success); | |
996 | end Insert_With_Hint; | |
997 | ||
998 | ------------------ | |
999 | -- Intersection -- | |
1000 | ------------------ | |
1001 | ||
1002 | procedure Intersection (Target : in out Set; Source : Set) is | |
1003 | begin | |
4c2d6a70 AC |
1004 | Set_Ops.Intersection (Target.Tree, Source.Tree); |
1005 | end Intersection; | |
1006 | ||
1007 | function Intersection (Left, Right : Set) return Set is | |
8704d4b3 MH |
1008 | Tree : constant Tree_Type := |
1009 | Set_Ops.Intersection (Left.Tree, Right.Tree); | |
4c2d6a70 | 1010 | begin |
8704d4b3 | 1011 | return Set'(Controlled with Tree); |
4c2d6a70 AC |
1012 | end Intersection; |
1013 | ||
1014 | -------------- | |
1015 | -- Is_Empty -- | |
1016 | -------------- | |
1017 | ||
1018 | function Is_Empty (Container : Set) return Boolean is | |
1019 | begin | |
8704d4b3 | 1020 | return Container.Tree.Length = 0; |
4c2d6a70 AC |
1021 | end Is_Empty; |
1022 | ||
1023 | ------------------------ | |
1024 | -- Is_Equal_Node_Node -- | |
1025 | ------------------------ | |
1026 | ||
1027 | function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is | |
1028 | begin | |
1029 | return L.Element = R.Element; | |
1030 | end Is_Equal_Node_Node; | |
1031 | ||
1032 | ----------------------------- | |
1033 | -- Is_Greater_Element_Node -- | |
1034 | ----------------------------- | |
1035 | ||
1036 | function Is_Greater_Element_Node | |
1037 | (Left : Element_Type; | |
1038 | Right : Node_Access) return Boolean | |
1039 | is | |
1040 | begin | |
1041 | -- Compute e > node same as node < e | |
1042 | ||
1043 | return Right.Element < Left; | |
1044 | end Is_Greater_Element_Node; | |
1045 | ||
1046 | -------------------------- | |
1047 | -- Is_Less_Element_Node -- | |
1048 | -------------------------- | |
1049 | ||
1050 | function Is_Less_Element_Node | |
1051 | (Left : Element_Type; | |
1052 | Right : Node_Access) return Boolean | |
1053 | is | |
1054 | begin | |
1055 | return Left < Right.Element; | |
1056 | end Is_Less_Element_Node; | |
1057 | ||
1058 | ----------------------- | |
1059 | -- Is_Less_Node_Node -- | |
1060 | ----------------------- | |
1061 | ||
1062 | function Is_Less_Node_Node (L, R : Node_Access) return Boolean is | |
1063 | begin | |
1064 | return L.Element < R.Element; | |
1065 | end Is_Less_Node_Node; | |
1066 | ||
1067 | --------------- | |
1068 | -- Is_Subset -- | |
1069 | --------------- | |
1070 | ||
1071 | function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is | |
1072 | begin | |
4c2d6a70 AC |
1073 | return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); |
1074 | end Is_Subset; | |
1075 | ||
1076 | ------------- | |
1077 | -- Iterate -- | |
1078 | ------------- | |
1079 | ||
1080 | procedure Iterate | |
1081 | (Container : Set; | |
1082 | Process : not null access procedure (Position : Cursor)) | |
1083 | is | |
1084 | procedure Process_Node (Node : Node_Access); | |
1085 | pragma Inline (Process_Node); | |
1086 | ||
1087 | procedure Local_Iterate is | |
1088 | new Tree_Operations.Generic_Iteration (Process_Node); | |
1089 | ||
1090 | ------------------ | |
1091 | -- Process_Node -- | |
1092 | ------------------ | |
1093 | ||
1094 | procedure Process_Node (Node : Node_Access) is | |
1095 | begin | |
8704d4b3 | 1096 | Process (Cursor'(Container'Unrestricted_Access, Node)); |
4c2d6a70 AC |
1097 | end Process_Node; |
1098 | ||
8704d4b3 MH |
1099 | T : Tree_Type renames Container.Tree'Unrestricted_Access.all; |
1100 | B : Natural renames T.Busy; | |
1101 | ||
8fc789c8 | 1102 | -- Start of processing for Iterate |
4c2d6a70 AC |
1103 | |
1104 | begin | |
8704d4b3 MH |
1105 | B := B + 1; |
1106 | ||
1107 | begin | |
1108 | Local_Iterate (T); | |
1109 | exception | |
1110 | when others => | |
1111 | B := B - 1; | |
1112 | raise; | |
1113 | end; | |
1114 | ||
1115 | B := B - 1; | |
4c2d6a70 AC |
1116 | end Iterate; |
1117 | ||
1118 | ---------- | |
1119 | -- Last -- | |
1120 | ---------- | |
1121 | ||
1122 | function Last (Container : Set) return Cursor is | |
1123 | begin | |
1124 | if Container.Tree.Last = null then | |
1125 | return No_Element; | |
1126 | end if; | |
1127 | ||
8704d4b3 | 1128 | return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); |
4c2d6a70 AC |
1129 | end Last; |
1130 | ||
1131 | ------------------ | |
1132 | -- Last_Element -- | |
1133 | ------------------ | |
1134 | ||
1135 | function Last_Element (Container : Set) return Element_Type is | |
1136 | begin | |
2368f04e | 1137 | if Container.Tree.Last = null then |
ffabcde5 | 1138 | raise Constraint_Error with "set is empty"; |
2368f04e MH |
1139 | end if; |
1140 | ||
4c2d6a70 AC |
1141 | return Container.Tree.Last.Element; |
1142 | end Last_Element; | |
1143 | ||
1144 | ---------- | |
1145 | -- Left -- | |
1146 | ---------- | |
1147 | ||
1148 | function Left (Node : Node_Access) return Node_Access is | |
1149 | begin | |
1150 | return Node.Left; | |
1151 | end Left; | |
1152 | ||
1153 | ------------ | |
1154 | -- Length -- | |
1155 | ------------ | |
1156 | ||
1157 | function Length (Container : Set) return Count_Type is | |
1158 | begin | |
1159 | return Container.Tree.Length; | |
1160 | end Length; | |
1161 | ||
1162 | ---------- | |
1163 | -- Move -- | |
1164 | ---------- | |
1165 | ||
8704d4b3 MH |
1166 | procedure Move is |
1167 | new Tree_Operations.Generic_Move (Clear); | |
1168 | ||
4c2d6a70 AC |
1169 | procedure Move (Target : in out Set; Source : in out Set) is |
1170 | begin | |
4c2d6a70 AC |
1171 | Move (Target => Target.Tree, Source => Source.Tree); |
1172 | end Move; | |
1173 | ||
1174 | ---------- | |
1175 | -- Next -- | |
1176 | ---------- | |
1177 | ||
1178 | function Next (Position : Cursor) return Cursor is | |
1179 | begin | |
1180 | if Position = No_Element then | |
1181 | return No_Element; | |
1182 | end if; | |
1183 | ||
2368f04e MH |
1184 | pragma Assert (Vet (Position.Container.Tree, Position.Node), |
1185 | "bad cursor in Next"); | |
1186 | ||
4c2d6a70 AC |
1187 | declare |
1188 | Node : constant Node_Access := | |
8704d4b3 MH |
1189 | Tree_Operations.Next (Position.Node); |
1190 | ||
4c2d6a70 AC |
1191 | begin |
1192 | if Node = null then | |
1193 | return No_Element; | |
1194 | end if; | |
1195 | ||
1196 | return Cursor'(Position.Container, Node); | |
1197 | end; | |
1198 | end Next; | |
1199 | ||
1200 | procedure Next (Position : in out Cursor) is | |
1201 | begin | |
1202 | Position := Next (Position); | |
1203 | end Next; | |
1204 | ||
1205 | ------------- | |
1206 | -- Overlap -- | |
1207 | ------------- | |
1208 | ||
1209 | function Overlap (Left, Right : Set) return Boolean is | |
1210 | begin | |
4c2d6a70 AC |
1211 | return Set_Ops.Overlap (Left.Tree, Right.Tree); |
1212 | end Overlap; | |
1213 | ||
1214 | ------------ | |
1215 | -- Parent -- | |
1216 | ------------ | |
1217 | ||
1218 | function Parent (Node : Node_Access) return Node_Access is | |
1219 | begin | |
1220 | return Node.Parent; | |
1221 | end Parent; | |
1222 | ||
1223 | -------------- | |
1224 | -- Previous -- | |
1225 | -------------- | |
1226 | ||
1227 | function Previous (Position : Cursor) return Cursor is | |
1228 | begin | |
1229 | if Position = No_Element then | |
1230 | return No_Element; | |
1231 | end if; | |
1232 | ||
2368f04e MH |
1233 | pragma Assert (Vet (Position.Container.Tree, Position.Node), |
1234 | "bad cursor in Previous"); | |
1235 | ||
4c2d6a70 AC |
1236 | declare |
1237 | Node : constant Node_Access := | |
1238 | Tree_Operations.Previous (Position.Node); | |
1239 | ||
1240 | begin | |
1241 | if Node = null then | |
1242 | return No_Element; | |
1243 | end if; | |
1244 | ||
1245 | return Cursor'(Position.Container, Node); | |
1246 | end; | |
1247 | end Previous; | |
1248 | ||
1249 | procedure Previous (Position : in out Cursor) is | |
1250 | begin | |
1251 | Position := Previous (Position); | |
1252 | end Previous; | |
1253 | ||
1254 | ------------------- | |
1255 | -- Query_Element -- | |
1256 | ------------------- | |
1257 | ||
1258 | procedure Query_Element | |
1259 | (Position : Cursor; | |
1260 | Process : not null access procedure (Element : Element_Type)) | |
1261 | is | |
2368f04e MH |
1262 | begin |
1263 | if Position.Node = null then | |
ffabcde5 | 1264 | raise Constraint_Error with "Position cursor equals No_Element"; |
2368f04e | 1265 | end if; |
8704d4b3 | 1266 | |
2368f04e MH |
1267 | pragma Assert (Vet (Position.Container.Tree, Position.Node), |
1268 | "bad cursor in Query_Element"); | |
8704d4b3 | 1269 | |
2368f04e MH |
1270 | declare |
1271 | T : Tree_Type renames Position.Container.Tree; | |
8704d4b3 | 1272 | |
2368f04e MH |
1273 | B : Natural renames T.Busy; |
1274 | L : Natural renames T.Lock; | |
8704d4b3 MH |
1275 | |
1276 | begin | |
2368f04e MH |
1277 | B := B + 1; |
1278 | L := L + 1; | |
8704d4b3 | 1279 | |
2368f04e MH |
1280 | begin |
1281 | Process (Position.Node.Element); | |
1282 | exception | |
1283 | when others => | |
1284 | L := L - 1; | |
1285 | B := B - 1; | |
1286 | raise; | |
1287 | end; | |
1288 | ||
1289 | L := L - 1; | |
1290 | B := B - 1; | |
1291 | end; | |
4c2d6a70 AC |
1292 | end Query_Element; |
1293 | ||
1294 | ---------- | |
1295 | -- Read -- | |
1296 | ---------- | |
1297 | ||
1298 | procedure Read | |
d90e94c7 | 1299 | (Stream : not null access Root_Stream_Type'Class; |
4c2d6a70 AC |
1300 | Container : out Set) |
1301 | is | |
8704d4b3 | 1302 | function Read_Node |
d90e94c7 | 1303 | (Stream : not null access Root_Stream_Type'Class) return Node_Access; |
8704d4b3 | 1304 | pragma Inline (Read_Node); |
4c2d6a70 | 1305 | |
8704d4b3 MH |
1306 | procedure Read is |
1307 | new Tree_Operations.Generic_Read (Clear, Read_Node); | |
4c2d6a70 | 1308 | |
8704d4b3 MH |
1309 | --------------- |
1310 | -- Read_Node -- | |
1311 | --------------- | |
4c2d6a70 | 1312 | |
8704d4b3 | 1313 | function Read_Node |
d90e94c7 | 1314 | (Stream : not null access Root_Stream_Type'Class) return Node_Access |
8704d4b3 | 1315 | is |
4c2d6a70 AC |
1316 | Node : Node_Access := new Node_Type; |
1317 | ||
1318 | begin | |
8704d4b3 | 1319 | Element_Type'Read (Stream, Node.Element); |
4c2d6a70 | 1320 | return Node; |
8704d4b3 MH |
1321 | |
1322 | exception | |
1323 | when others => | |
1324 | Free (Node); | |
1325 | raise; | |
1326 | end Read_Node; | |
4c2d6a70 AC |
1327 | |
1328 | -- Start of processing for Read | |
1329 | ||
1330 | begin | |
8704d4b3 | 1331 | Read (Stream, Container.Tree); |
4c2d6a70 AC |
1332 | end Read; |
1333 | ||
2368f04e | 1334 | procedure Read |
d90e94c7 | 1335 | (Stream : not null access Root_Stream_Type'Class; |
2368f04e MH |
1336 | Item : out Cursor) |
1337 | is | |
1338 | begin | |
ffabcde5 | 1339 | raise Program_Error with "attempt to stream set cursor"; |
2368f04e MH |
1340 | end Read; |
1341 | ||
4c2d6a70 AC |
1342 | ------------- |
1343 | -- Replace -- | |
1344 | ------------- | |
1345 | ||
1346 | procedure Replace (Container : in out Set; New_Item : Element_Type) is | |
1347 | Node : constant Node_Access := | |
1348 | Element_Keys.Find (Container.Tree, New_Item); | |
1349 | ||
1350 | begin | |
1351 | if Node = null then | |
ffabcde5 MH |
1352 | raise Constraint_Error with |
1353 | "attempt to replace element not in set"; | |
4c2d6a70 AC |
1354 | end if; |
1355 | ||
8704d4b3 | 1356 | if Container.Tree.Lock > 0 then |
ffabcde5 MH |
1357 | raise Program_Error with |
1358 | "attempt to tamper with cursors (set is locked)"; | |
8704d4b3 MH |
1359 | end if; |
1360 | ||
4c2d6a70 AC |
1361 | Node.Element := New_Item; |
1362 | end Replace; | |
1363 | ||
1364 | --------------------- | |
1365 | -- Replace_Element -- | |
1366 | --------------------- | |
1367 | ||
8704d4b3 MH |
1368 | procedure Replace_Element |
1369 | (Tree : in out Tree_Type; | |
1370 | Node : Node_Access; | |
1371 | Item : Element_Type) | |
1372 | is | |
3837bc7f MH |
1373 | pragma Assert (Node /= null); |
1374 | ||
1375 | function New_Node return Node_Access; | |
1376 | pragma Inline (New_Node); | |
1377 | ||
1378 | procedure Local_Insert_Post is | |
1379 | new Element_Keys.Generic_Insert_Post (New_Node); | |
1380 | ||
1381 | procedure Local_Insert_Sans_Hint is | |
1382 | new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); | |
1383 | ||
1384 | procedure Local_Insert_With_Hint is | |
1385 | new Element_Keys.Generic_Conditional_Insert_With_Hint | |
1386 | (Local_Insert_Post, | |
1387 | Local_Insert_Sans_Hint); | |
1388 | ||
1389 | -------------- | |
1390 | -- New_Node -- | |
1391 | -------------- | |
1392 | ||
1393 | function New_Node return Node_Access is | |
1394 | begin | |
1395 | Node.Element := Item; | |
1396 | Node.Color := Red; | |
1397 | Node.Parent := null; | |
1398 | Node.Right := null; | |
1399 | Node.Left := null; | |
1400 | ||
1401 | return Node; | |
1402 | end New_Node; | |
1403 | ||
1404 | Hint : Node_Access; | |
1405 | Result : Node_Access; | |
1406 | Inserted : Boolean; | |
1407 | ||
1408 | -- Start of processing for Insert | |
1409 | ||
8704d4b3 MH |
1410 | begin |
1411 | if Item < Node.Element | |
1412 | or else Node.Element < Item | |
1413 | then | |
1414 | null; | |
3837bc7f | 1415 | |
8704d4b3 MH |
1416 | else |
1417 | if Tree.Lock > 0 then | |
ffabcde5 MH |
1418 | raise Program_Error with |
1419 | "attempt to tamper with cursors (set is locked)"; | |
8704d4b3 MH |
1420 | end if; |
1421 | ||
1422 | Node.Element := Item; | |
1423 | return; | |
1424 | end if; | |
1425 | ||
3837bc7f | 1426 | Hint := Element_Keys.Ceiling (Tree, Item); |
8704d4b3 | 1427 | |
3837bc7f MH |
1428 | if Hint = null then |
1429 | null; | |
8704d4b3 | 1430 | |
3837bc7f MH |
1431 | elsif Item < Hint.Element then |
1432 | if Hint = Node then | |
1433 | if Tree.Lock > 0 then | |
1434 | raise Program_Error with | |
1435 | "attempt to tamper with cursors (set is locked)"; | |
1436 | end if; | |
8704d4b3 | 1437 | |
8704d4b3 | 1438 | Node.Element := Item; |
8704d4b3 MH |
1439 | return; |
1440 | end if; | |
8704d4b3 | 1441 | |
3837bc7f MH |
1442 | else |
1443 | pragma Assert (not (Hint.Element < Item)); | |
1444 | raise Program_Error with "attempt to replace existing element"; | |
1445 | end if; | |
8704d4b3 | 1446 | |
3837bc7f | 1447 | Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit |
8704d4b3 | 1448 | |
3837bc7f MH |
1449 | Local_Insert_With_Hint |
1450 | (Tree => Tree, | |
1451 | Position => Hint, | |
1452 | Key => Item, | |
1453 | Node => Result, | |
1454 | Inserted => Inserted); | |
1455 | ||
1456 | pragma Assert (Inserted); | |
1457 | pragma Assert (Result = Node); | |
8704d4b3 MH |
1458 | end Replace_Element; |
1459 | ||
1460 | procedure Replace_Element | |
ba355842 | 1461 | (Container : in out Set; |
8704d4b3 | 1462 | Position : Cursor; |
ba355842 | 1463 | New_Item : Element_Type) |
8704d4b3 | 1464 | is |
8704d4b3 MH |
1465 | begin |
1466 | if Position.Node = null then | |
ffabcde5 MH |
1467 | raise Constraint_Error with |
1468 | "Position cursor equals No_Element"; | |
8704d4b3 MH |
1469 | end if; |
1470 | ||
1471 | if Position.Container /= Container'Unrestricted_Access then | |
ffabcde5 MH |
1472 | raise Program_Error with |
1473 | "Position cursor designates wrong set"; | |
8704d4b3 MH |
1474 | end if; |
1475 | ||
2368f04e MH |
1476 | pragma Assert (Vet (Container.Tree, Position.Node), |
1477 | "bad cursor in Replace_Element"); | |
1478 | ||
ba355842 | 1479 | Replace_Element (Container.Tree, Position.Node, New_Item); |
8704d4b3 | 1480 | end Replace_Element; |
4c2d6a70 AC |
1481 | |
1482 | --------------------- | |
1483 | -- Reverse_Iterate -- | |
1484 | --------------------- | |
1485 | ||
1486 | procedure Reverse_Iterate | |
1487 | (Container : Set; | |
1488 | Process : not null access procedure (Position : Cursor)) | |
1489 | is | |
1490 | procedure Process_Node (Node : Node_Access); | |
1491 | pragma Inline (Process_Node); | |
1492 | ||
1493 | procedure Local_Reverse_Iterate is | |
1494 | new Tree_Operations.Generic_Reverse_Iteration (Process_Node); | |
1495 | ||
1496 | ------------------ | |
1497 | -- Process_Node -- | |
1498 | ------------------ | |
1499 | ||
1500 | procedure Process_Node (Node : Node_Access) is | |
1501 | begin | |
8704d4b3 | 1502 | Process (Cursor'(Container'Unrestricted_Access, Node)); |
4c2d6a70 AC |
1503 | end Process_Node; |
1504 | ||
8704d4b3 MH |
1505 | T : Tree_Type renames Container.Tree'Unrestricted_Access.all; |
1506 | B : Natural renames T.Busy; | |
1507 | ||
4c2d6a70 AC |
1508 | -- Start of processing for Reverse_Iterate |
1509 | ||
1510 | begin | |
8704d4b3 MH |
1511 | B := B + 1; |
1512 | ||
1513 | begin | |
1514 | Local_Reverse_Iterate (T); | |
1515 | exception | |
1516 | when others => | |
1517 | B := B - 1; | |
1518 | raise; | |
1519 | end; | |
1520 | ||
1521 | B := B - 1; | |
4c2d6a70 AC |
1522 | end Reverse_Iterate; |
1523 | ||
1524 | ----------- | |
1525 | -- Right -- | |
1526 | ----------- | |
1527 | ||
1528 | function Right (Node : Node_Access) return Node_Access is | |
1529 | begin | |
1530 | return Node.Right; | |
1531 | end Right; | |
1532 | ||
1533 | --------------- | |
1534 | -- Set_Color -- | |
1535 | --------------- | |
1536 | ||
1537 | procedure Set_Color (Node : Node_Access; Color : Color_Type) is | |
1538 | begin | |
1539 | Node.Color := Color; | |
1540 | end Set_Color; | |
1541 | ||
1542 | -------------- | |
1543 | -- Set_Left -- | |
1544 | -------------- | |
1545 | ||
1546 | procedure Set_Left (Node : Node_Access; Left : Node_Access) is | |
1547 | begin | |
1548 | Node.Left := Left; | |
1549 | end Set_Left; | |
1550 | ||
1551 | ---------------- | |
1552 | -- Set_Parent -- | |
1553 | ---------------- | |
1554 | ||
1555 | procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is | |
1556 | begin | |
1557 | Node.Parent := Parent; | |
1558 | end Set_Parent; | |
1559 | ||
1560 | --------------- | |
1561 | -- Set_Right -- | |
1562 | --------------- | |
1563 | ||
1564 | procedure Set_Right (Node : Node_Access; Right : Node_Access) is | |
1565 | begin | |
1566 | Node.Right := Right; | |
1567 | end Set_Right; | |
1568 | ||
1569 | -------------------------- | |
1570 | -- Symmetric_Difference -- | |
1571 | -------------------------- | |
1572 | ||
1573 | procedure Symmetric_Difference (Target : in out Set; Source : Set) is | |
1574 | begin | |
4c2d6a70 AC |
1575 | Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); |
1576 | end Symmetric_Difference; | |
1577 | ||
1578 | function Symmetric_Difference (Left, Right : Set) return Set is | |
8704d4b3 MH |
1579 | Tree : constant Tree_Type := |
1580 | Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); | |
4c2d6a70 | 1581 | begin |
8704d4b3 | 1582 | return Set'(Controlled with Tree); |
4c2d6a70 AC |
1583 | end Symmetric_Difference; |
1584 | ||
2368f04e MH |
1585 | ------------ |
1586 | -- To_Set -- | |
1587 | ------------ | |
1588 | ||
1589 | function To_Set (New_Item : Element_Type) return Set is | |
1590 | Tree : Tree_Type; | |
1591 | Node : Node_Access; | |
1592 | Inserted : Boolean; | |
67ce0d7e | 1593 | pragma Unreferenced (Node, Inserted); |
2368f04e MH |
1594 | begin |
1595 | Insert_Sans_Hint (Tree, New_Item, Node, Inserted); | |
1596 | return Set'(Controlled with Tree); | |
1597 | end To_Set; | |
1598 | ||
4c2d6a70 AC |
1599 | ----------- |
1600 | -- Union -- | |
1601 | ----------- | |
1602 | ||
1603 | procedure Union (Target : in out Set; Source : Set) is | |
1604 | begin | |
4c2d6a70 AC |
1605 | Set_Ops.Union (Target.Tree, Source.Tree); |
1606 | end Union; | |
1607 | ||
1608 | function Union (Left, Right : Set) return Set is | |
8704d4b3 MH |
1609 | Tree : constant Tree_Type := |
1610 | Set_Ops.Union (Left.Tree, Right.Tree); | |
4c2d6a70 | 1611 | begin |
8704d4b3 | 1612 | return Set'(Controlled with Tree); |
4c2d6a70 AC |
1613 | end Union; |
1614 | ||
1615 | ----------- | |
1616 | -- Write -- | |
1617 | ----------- | |
1618 | ||
1619 | procedure Write | |
d90e94c7 | 1620 | (Stream : not null access Root_Stream_Type'Class; |
4c2d6a70 AC |
1621 | Container : Set) |
1622 | is | |
8704d4b3 | 1623 | procedure Write_Node |
d90e94c7 | 1624 | (Stream : not null access Root_Stream_Type'Class; |
8704d4b3 MH |
1625 | Node : Node_Access); |
1626 | pragma Inline (Write_Node); | |
4c2d6a70 | 1627 | |
8704d4b3 MH |
1628 | procedure Write is |
1629 | new Tree_Operations.Generic_Write (Write_Node); | |
4c2d6a70 | 1630 | |
8704d4b3 MH |
1631 | ---------------- |
1632 | -- Write_Node -- | |
1633 | ---------------- | |
4c2d6a70 | 1634 | |
8704d4b3 | 1635 | procedure Write_Node |
d90e94c7 | 1636 | (Stream : not null access Root_Stream_Type'Class; |
8704d4b3 MH |
1637 | Node : Node_Access) |
1638 | is | |
4c2d6a70 AC |
1639 | begin |
1640 | Element_Type'Write (Stream, Node.Element); | |
8704d4b3 | 1641 | end Write_Node; |
4c2d6a70 AC |
1642 | |
1643 | -- Start of processing for Write | |
1644 | ||
1645 | begin | |
8704d4b3 | 1646 | Write (Stream, Container.Tree); |
4c2d6a70 AC |
1647 | end Write; |
1648 | ||
2368f04e | 1649 | procedure Write |
d90e94c7 | 1650 | (Stream : not null access Root_Stream_Type'Class; |
2368f04e MH |
1651 | Item : Cursor) |
1652 | is | |
1653 | begin | |
ffabcde5 | 1654 | raise Program_Error with "attempt to stream set cursor"; |
2368f04e MH |
1655 | end Write; |
1656 | ||
4c2d6a70 | 1657 | end Ada.Containers.Ordered_Sets; |