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