111
|
1 ------------------------------------------------------------------------------
|
|
2 -- --
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
4 -- --
|
|
5 -- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES --
|
|
6 -- --
|
|
7 -- B o d y --
|
|
8 -- --
|
131
|
9 -- Copyright (C) 2004-2018, Free Software Foundation, Inc. --
|
111
|
10 -- --
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
17 -- --
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
21 -- --
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
26 -- --
|
|
27 -- This unit was originally developed by Matthew J Heaney. --
|
|
28 ------------------------------------------------------------------------------
|
|
29
|
|
30 with Ada.Unchecked_Deallocation;
|
|
31
|
|
32 with System; use type System.Address;
|
|
33
|
|
34 package body Ada.Containers.Indefinite_Multiway_Trees is
|
|
35
|
|
36 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
|
|
37 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
|
|
38 -- See comment in Ada.Containers.Helpers
|
|
39
|
|
40 --------------------
|
|
41 -- Root_Iterator --
|
|
42 --------------------
|
|
43
|
|
44 type Root_Iterator is abstract new Limited_Controlled and
|
|
45 Tree_Iterator_Interfaces.Forward_Iterator with
|
|
46 record
|
|
47 Container : Tree_Access;
|
|
48 Subtree : Tree_Node_Access;
|
|
49 end record;
|
|
50
|
|
51 overriding procedure Finalize (Object : in out Root_Iterator);
|
|
52
|
|
53 -----------------------
|
|
54 -- Subtree_Iterator --
|
|
55 -----------------------
|
|
56
|
|
57 type Subtree_Iterator is new Root_Iterator with null record;
|
|
58
|
|
59 overriding function First (Object : Subtree_Iterator) return Cursor;
|
|
60
|
|
61 overriding function Next
|
|
62 (Object : Subtree_Iterator;
|
|
63 Position : Cursor) return Cursor;
|
|
64
|
|
65 ---------------------
|
|
66 -- Child_Iterator --
|
|
67 ---------------------
|
|
68
|
|
69 type Child_Iterator is new Root_Iterator and
|
|
70 Tree_Iterator_Interfaces.Reversible_Iterator with null record;
|
|
71
|
|
72 overriding function First (Object : Child_Iterator) return Cursor;
|
|
73
|
|
74 overriding function Next
|
|
75 (Object : Child_Iterator;
|
|
76 Position : Cursor) return Cursor;
|
|
77
|
|
78 overriding function Last (Object : Child_Iterator) return Cursor;
|
|
79
|
|
80 overriding function Previous
|
|
81 (Object : Child_Iterator;
|
|
82 Position : Cursor) return Cursor;
|
|
83
|
|
84 -----------------------
|
|
85 -- Local Subprograms --
|
|
86 -----------------------
|
|
87
|
|
88 function Root_Node (Container : Tree) return Tree_Node_Access;
|
|
89
|
|
90 procedure Free_Element is
|
|
91 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
|
|
92
|
|
93 procedure Deallocate_Node (X : in out Tree_Node_Access);
|
|
94
|
|
95 procedure Deallocate_Children
|
|
96 (Subtree : Tree_Node_Access;
|
|
97 Count : in out Count_Type);
|
|
98
|
|
99 procedure Deallocate_Subtree
|
|
100 (Subtree : in out Tree_Node_Access;
|
|
101 Count : in out Count_Type);
|
|
102
|
|
103 function Equal_Children
|
|
104 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
|
|
105
|
|
106 function Equal_Subtree
|
|
107 (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean;
|
|
108
|
|
109 procedure Iterate_Children
|
|
110 (Container : Tree_Access;
|
|
111 Subtree : Tree_Node_Access;
|
|
112 Process : not null access procedure (Position : Cursor));
|
|
113
|
|
114 procedure Iterate_Subtree
|
|
115 (Container : Tree_Access;
|
|
116 Subtree : Tree_Node_Access;
|
|
117 Process : not null access procedure (Position : Cursor));
|
|
118
|
|
119 procedure Copy_Children
|
|
120 (Source : Children_Type;
|
|
121 Parent : Tree_Node_Access;
|
|
122 Count : in out Count_Type);
|
|
123
|
|
124 procedure Copy_Subtree
|
|
125 (Source : Tree_Node_Access;
|
|
126 Parent : Tree_Node_Access;
|
|
127 Target : out Tree_Node_Access;
|
|
128 Count : in out Count_Type);
|
|
129
|
|
130 function Find_In_Children
|
|
131 (Subtree : Tree_Node_Access;
|
|
132 Item : Element_Type) return Tree_Node_Access;
|
|
133
|
|
134 function Find_In_Subtree
|
|
135 (Subtree : Tree_Node_Access;
|
|
136 Item : Element_Type) return Tree_Node_Access;
|
|
137
|
|
138 function Child_Count (Children : Children_Type) return Count_Type;
|
|
139
|
|
140 function Subtree_Node_Count
|
|
141 (Subtree : Tree_Node_Access) return Count_Type;
|
|
142
|
|
143 function Is_Reachable (From, To : Tree_Node_Access) return Boolean;
|
|
144
|
|
145 procedure Remove_Subtree (Subtree : Tree_Node_Access);
|
|
146
|
|
147 procedure Insert_Subtree_Node
|
|
148 (Subtree : Tree_Node_Access;
|
|
149 Parent : Tree_Node_Access;
|
|
150 Before : Tree_Node_Access);
|
|
151
|
|
152 procedure Insert_Subtree_List
|
|
153 (First : Tree_Node_Access;
|
|
154 Last : Tree_Node_Access;
|
|
155 Parent : Tree_Node_Access;
|
|
156 Before : Tree_Node_Access);
|
|
157
|
|
158 procedure Splice_Children
|
|
159 (Target_Parent : Tree_Node_Access;
|
|
160 Before : Tree_Node_Access;
|
|
161 Source_Parent : Tree_Node_Access);
|
|
162
|
|
163 ---------
|
|
164 -- "=" --
|
|
165 ---------
|
|
166
|
|
167 function "=" (Left, Right : Tree) return Boolean is
|
|
168 begin
|
|
169 return Equal_Children (Root_Node (Left), Root_Node (Right));
|
|
170 end "=";
|
|
171
|
|
172 ------------
|
|
173 -- Adjust --
|
|
174 ------------
|
|
175
|
|
176 procedure Adjust (Container : in out Tree) is
|
|
177 Source : constant Children_Type := Container.Root.Children;
|
|
178 Source_Count : constant Count_Type := Container.Count;
|
|
179 Target_Count : Count_Type;
|
|
180
|
|
181 begin
|
|
182 -- We first restore the target container to its default-initialized
|
|
183 -- state, before we attempt any allocation, to ensure that invariants
|
|
184 -- are preserved in the event that the allocation fails.
|
|
185
|
|
186 Container.Root.Children := Children_Type'(others => null);
|
|
187 Zero_Counts (Container.TC);
|
|
188 Container.Count := 0;
|
|
189
|
|
190 -- Copy_Children returns a count of the number of nodes that it
|
|
191 -- allocates, but it works by incrementing the value that is passed in.
|
|
192 -- We must therefore initialize the count value before calling
|
|
193 -- Copy_Children.
|
|
194
|
|
195 Target_Count := 0;
|
|
196
|
|
197 -- Now we attempt the allocation of subtrees. The invariants are
|
|
198 -- satisfied even if the allocation fails.
|
|
199
|
|
200 Copy_Children (Source, Root_Node (Container), Target_Count);
|
|
201 pragma Assert (Target_Count = Source_Count);
|
|
202
|
|
203 Container.Count := Source_Count;
|
|
204 end Adjust;
|
|
205
|
|
206 -------------------
|
|
207 -- Ancestor_Find --
|
|
208 -------------------
|
|
209
|
|
210 function Ancestor_Find
|
|
211 (Position : Cursor;
|
|
212 Item : Element_Type) return Cursor
|
|
213 is
|
|
214 R, N : Tree_Node_Access;
|
|
215
|
|
216 begin
|
|
217 if Checks and then Position = No_Element then
|
|
218 raise Constraint_Error with "Position cursor has no element";
|
|
219 end if;
|
|
220
|
|
221 -- Commented-out pending ARG ruling. ???
|
|
222
|
|
223 -- if Checks and then
|
|
224 -- Position.Container /= Container'Unrestricted_Access
|
|
225 -- then
|
|
226 -- raise Program_Error with "Position cursor not in container";
|
|
227 -- end if;
|
|
228
|
|
229 -- AI-0136 says to raise PE if Position equals the root node. This does
|
|
230 -- not seem correct, as this value is just the limiting condition of the
|
|
231 -- search. For now we omit this check pending a ruling from the ARG.???
|
|
232
|
|
233 -- if Checks and then Is_Root (Position) then
|
|
234 -- raise Program_Error with "Position cursor designates root";
|
|
235 -- end if;
|
|
236
|
|
237 R := Root_Node (Position.Container.all);
|
|
238 N := Position.Node;
|
|
239 while N /= R loop
|
|
240 if N.Element.all = Item then
|
|
241 return Cursor'(Position.Container, N);
|
|
242 end if;
|
|
243
|
|
244 N := N.Parent;
|
|
245 end loop;
|
|
246
|
|
247 return No_Element;
|
|
248 end Ancestor_Find;
|
|
249
|
|
250 ------------------
|
|
251 -- Append_Child --
|
|
252 ------------------
|
|
253
|
|
254 procedure Append_Child
|
|
255 (Container : in out Tree;
|
|
256 Parent : Cursor;
|
|
257 New_Item : Element_Type;
|
|
258 Count : Count_Type := 1)
|
|
259 is
|
|
260 First, Last : Tree_Node_Access;
|
|
261 Element : Element_Access;
|
|
262
|
|
263 begin
|
|
264 if Checks and then Parent = No_Element then
|
|
265 raise Constraint_Error with "Parent cursor has no element";
|
|
266 end if;
|
|
267
|
|
268 if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
269 raise Program_Error with "Parent cursor not in container";
|
|
270 end if;
|
|
271
|
|
272 if Count = 0 then
|
|
273 return;
|
|
274 end if;
|
|
275
|
|
276 TC_Check (Container.TC);
|
|
277
|
|
278 declare
|
|
279 -- The element allocator may need an accessibility check in the case
|
|
280 -- the actual type is class-wide or has access discriminants (see
|
|
281 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
|
|
282 -- allocator in the loop below, because the one in this block would
|
|
283 -- have failed already.
|
|
284
|
|
285 pragma Unsuppress (Accessibility_Check);
|
|
286
|
|
287 begin
|
|
288 Element := new Element_Type'(New_Item);
|
|
289 end;
|
|
290
|
|
291 First := new Tree_Node_Type'(Parent => Parent.Node,
|
|
292 Element => Element,
|
|
293 others => <>);
|
|
294
|
|
295 Last := First;
|
|
296
|
|
297 for J in Count_Type'(2) .. Count loop
|
|
298
|
|
299 -- Reclaim other nodes if Storage_Error. ???
|
|
300
|
|
301 Element := new Element_Type'(New_Item);
|
|
302 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
|
|
303 Prev => Last,
|
|
304 Element => Element,
|
|
305 others => <>);
|
|
306
|
|
307 Last := Last.Next;
|
|
308 end loop;
|
|
309
|
|
310 Insert_Subtree_List
|
|
311 (First => First,
|
|
312 Last => Last,
|
|
313 Parent => Parent.Node,
|
|
314 Before => null); -- null means "insert at end of list"
|
|
315
|
|
316 -- In order for operation Node_Count to complete in O(1) time, we cache
|
|
317 -- the count value. Here we increment the total count by the number of
|
|
318 -- nodes we just inserted.
|
|
319
|
|
320 Container.Count := Container.Count + Count;
|
|
321 end Append_Child;
|
|
322
|
|
323 ------------
|
|
324 -- Assign --
|
|
325 ------------
|
|
326
|
|
327 procedure Assign (Target : in out Tree; Source : Tree) is
|
|
328 Source_Count : constant Count_Type := Source.Count;
|
|
329 Target_Count : Count_Type;
|
|
330
|
|
331 begin
|
|
332 if Target'Address = Source'Address then
|
|
333 return;
|
|
334 end if;
|
|
335
|
|
336 Target.Clear; -- checks busy bit
|
|
337
|
|
338 -- Copy_Children returns the number of nodes that it allocates, but it
|
|
339 -- does this by incrementing the count value passed in, so we must
|
|
340 -- initialize the count before calling Copy_Children.
|
|
341
|
|
342 Target_Count := 0;
|
|
343
|
|
344 -- Note that Copy_Children inserts the newly-allocated children into
|
|
345 -- their parent list only after the allocation of all the children has
|
|
346 -- succeeded. This preserves invariants even if the allocation fails.
|
|
347
|
|
348 Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count);
|
|
349 pragma Assert (Target_Count = Source_Count);
|
|
350
|
|
351 Target.Count := Source_Count;
|
|
352 end Assign;
|
|
353
|
|
354 -----------------
|
|
355 -- Child_Count --
|
|
356 -----------------
|
|
357
|
|
358 function Child_Count (Parent : Cursor) return Count_Type is
|
|
359 begin
|
|
360 if Parent = No_Element then
|
|
361 return 0;
|
|
362 else
|
|
363 return Child_Count (Parent.Node.Children);
|
|
364 end if;
|
|
365 end Child_Count;
|
|
366
|
|
367 function Child_Count (Children : Children_Type) return Count_Type is
|
|
368 Result : Count_Type;
|
|
369 Node : Tree_Node_Access;
|
|
370
|
|
371 begin
|
|
372 Result := 0;
|
|
373 Node := Children.First;
|
|
374 while Node /= null loop
|
|
375 Result := Result + 1;
|
|
376 Node := Node.Next;
|
|
377 end loop;
|
|
378
|
|
379 return Result;
|
|
380 end Child_Count;
|
|
381
|
|
382 -----------------
|
|
383 -- Child_Depth --
|
|
384 -----------------
|
|
385
|
|
386 function Child_Depth (Parent, Child : Cursor) return Count_Type is
|
|
387 Result : Count_Type;
|
|
388 N : Tree_Node_Access;
|
|
389
|
|
390 begin
|
|
391 if Checks and then Parent = No_Element then
|
|
392 raise Constraint_Error with "Parent cursor has no element";
|
|
393 end if;
|
|
394
|
|
395 if Checks and then Child = No_Element then
|
|
396 raise Constraint_Error with "Child cursor has no element";
|
|
397 end if;
|
|
398
|
|
399 if Checks and then Parent.Container /= Child.Container then
|
|
400 raise Program_Error with "Parent and Child in different containers";
|
|
401 end if;
|
|
402
|
|
403 Result := 0;
|
|
404 N := Child.Node;
|
|
405 while N /= Parent.Node loop
|
|
406 Result := Result + 1;
|
|
407 N := N.Parent;
|
|
408
|
|
409 if Checks and then N = null then
|
|
410 raise Program_Error with "Parent is not ancestor of Child";
|
|
411 end if;
|
|
412 end loop;
|
|
413
|
|
414 return Result;
|
|
415 end Child_Depth;
|
|
416
|
|
417 -----------
|
|
418 -- Clear --
|
|
419 -----------
|
|
420
|
|
421 procedure Clear (Container : in out Tree) is
|
|
422 Container_Count : Count_Type;
|
|
423 Children_Count : Count_Type;
|
|
424
|
|
425 begin
|
|
426 TC_Check (Container.TC);
|
|
427
|
|
428 -- We first set the container count to 0, in order to preserve
|
|
429 -- invariants in case the deallocation fails. (This works because
|
|
430 -- Deallocate_Children immediately removes the children from their
|
|
431 -- parent, and then does the actual deallocation.)
|
|
432
|
|
433 Container_Count := Container.Count;
|
|
434 Container.Count := 0;
|
|
435
|
|
436 -- Deallocate_Children returns the number of nodes that it deallocates,
|
|
437 -- but it does this by incrementing the count value that is passed in,
|
|
438 -- so we must first initialize the count return value before calling it.
|
|
439
|
|
440 Children_Count := 0;
|
|
441
|
|
442 -- See comment above. Deallocate_Children immediately removes the
|
|
443 -- children list from their parent node (here, the root of the tree),
|
|
444 -- and only after that does it attempt the actual deallocation. So even
|
|
445 -- if the deallocation fails, the representation invariants
|
|
446
|
|
447 Deallocate_Children (Root_Node (Container), Children_Count);
|
|
448 pragma Assert (Children_Count = Container_Count);
|
|
449 end Clear;
|
|
450
|
|
451 ------------------------
|
|
452 -- Constant_Reference --
|
|
453 ------------------------
|
|
454
|
|
455 function Constant_Reference
|
|
456 (Container : aliased Tree;
|
|
457 Position : Cursor) return Constant_Reference_Type
|
|
458 is
|
|
459 begin
|
|
460 if Checks and then Position.Container = null then
|
|
461 raise Constraint_Error with
|
|
462 "Position cursor has no element";
|
|
463 end if;
|
|
464
|
|
465 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
466 then
|
|
467 raise Program_Error with
|
|
468 "Position cursor designates wrong container";
|
|
469 end if;
|
|
470
|
|
471 if Checks and then Position.Node = Root_Node (Container) then
|
|
472 raise Program_Error with "Position cursor designates root";
|
|
473 end if;
|
|
474
|
|
475 if Checks and then Position.Node.Element = null then
|
|
476 raise Program_Error with "Node has no element";
|
|
477 end if;
|
|
478
|
|
479 -- Implement Vet for multiway tree???
|
|
480 -- pragma Assert (Vet (Position),
|
|
481 -- "Position cursor in Constant_Reference is bad");
|
|
482
|
|
483 declare
|
|
484 TC : constant Tamper_Counts_Access :=
|
|
485 Container.TC'Unrestricted_Access;
|
|
486 begin
|
|
487 return R : constant Constant_Reference_Type :=
|
|
488 (Element => Position.Node.Element.all'Access,
|
|
489 Control => (Controlled with TC))
|
|
490 do
|
|
491 Lock (TC.all);
|
|
492 end return;
|
|
493 end;
|
|
494 end Constant_Reference;
|
|
495
|
|
496 --------------
|
|
497 -- Contains --
|
|
498 --------------
|
|
499
|
|
500 function Contains
|
|
501 (Container : Tree;
|
|
502 Item : Element_Type) return Boolean
|
|
503 is
|
|
504 begin
|
|
505 return Find (Container, Item) /= No_Element;
|
|
506 end Contains;
|
|
507
|
|
508 ----------
|
|
509 -- Copy --
|
|
510 ----------
|
|
511
|
|
512 function Copy (Source : Tree) return Tree is
|
|
513 begin
|
|
514 return Target : Tree do
|
|
515 Copy_Children
|
|
516 (Source => Source.Root.Children,
|
|
517 Parent => Root_Node (Target),
|
|
518 Count => Target.Count);
|
|
519
|
|
520 pragma Assert (Target.Count = Source.Count);
|
|
521 end return;
|
|
522 end Copy;
|
|
523
|
|
524 -------------------
|
|
525 -- Copy_Children --
|
|
526 -------------------
|
|
527
|
|
528 procedure Copy_Children
|
|
529 (Source : Children_Type;
|
|
530 Parent : Tree_Node_Access;
|
|
531 Count : in out Count_Type)
|
|
532 is
|
|
533 pragma Assert (Parent /= null);
|
|
534 pragma Assert (Parent.Children.First = null);
|
|
535 pragma Assert (Parent.Children.Last = null);
|
|
536
|
|
537 CC : Children_Type;
|
|
538 C : Tree_Node_Access;
|
|
539
|
|
540 begin
|
|
541 -- We special-case the first allocation, in order to establish the
|
|
542 -- representation invariants for type Children_Type.
|
|
543
|
|
544 C := Source.First;
|
|
545
|
|
546 if C = null then
|
|
547 return;
|
|
548 end if;
|
|
549
|
|
550 Copy_Subtree
|
|
551 (Source => C,
|
|
552 Parent => Parent,
|
|
553 Target => CC.First,
|
|
554 Count => Count);
|
|
555
|
|
556 CC.Last := CC.First;
|
|
557
|
|
558 -- The representation invariants for the Children_Type list have been
|
|
559 -- established, so we can now copy the remaining children of Source.
|
|
560
|
|
561 C := C.Next;
|
|
562 while C /= null loop
|
|
563 Copy_Subtree
|
|
564 (Source => C,
|
|
565 Parent => Parent,
|
|
566 Target => CC.Last.Next,
|
|
567 Count => Count);
|
|
568
|
|
569 CC.Last.Next.Prev := CC.Last;
|
|
570 CC.Last := CC.Last.Next;
|
|
571
|
|
572 C := C.Next;
|
|
573 end loop;
|
|
574
|
|
575 -- We add the newly-allocated children to their parent list only after
|
|
576 -- the allocation has succeeded, in order to preserve invariants of the
|
|
577 -- parent.
|
|
578
|
|
579 Parent.Children := CC;
|
|
580 end Copy_Children;
|
|
581
|
|
582 ------------------
|
|
583 -- Copy_Subtree --
|
|
584 ------------------
|
|
585
|
|
586 procedure Copy_Subtree
|
|
587 (Target : in out Tree;
|
|
588 Parent : Cursor;
|
|
589 Before : Cursor;
|
|
590 Source : Cursor)
|
|
591 is
|
|
592 Target_Subtree : Tree_Node_Access;
|
|
593 Target_Count : Count_Type;
|
|
594
|
|
595 begin
|
|
596 if Checks and then Parent = No_Element then
|
|
597 raise Constraint_Error with "Parent cursor has no element";
|
|
598 end if;
|
|
599
|
|
600 if Checks and then Parent.Container /= Target'Unrestricted_Access then
|
|
601 raise Program_Error with "Parent cursor not in container";
|
|
602 end if;
|
|
603
|
|
604 if Before /= No_Element then
|
|
605 if Checks and then Before.Container /= Target'Unrestricted_Access then
|
|
606 raise Program_Error with "Before cursor not in container";
|
|
607 end if;
|
|
608
|
|
609 if Checks and then Before.Node.Parent /= Parent.Node then
|
|
610 raise Constraint_Error with "Before cursor not child of Parent";
|
|
611 end if;
|
|
612 end if;
|
|
613
|
|
614 if Source = No_Element then
|
|
615 return;
|
|
616 end if;
|
|
617
|
|
618 if Checks and then Is_Root (Source) then
|
|
619 raise Constraint_Error with "Source cursor designates root";
|
|
620 end if;
|
|
621
|
|
622 -- Copy_Subtree returns a count of the number of nodes that it
|
|
623 -- allocates, but it works by incrementing the value that is passed in.
|
|
624 -- We must therefore initialize the count value before calling
|
|
625 -- Copy_Subtree.
|
|
626
|
|
627 Target_Count := 0;
|
|
628
|
|
629 Copy_Subtree
|
|
630 (Source => Source.Node,
|
|
631 Parent => Parent.Node,
|
|
632 Target => Target_Subtree,
|
|
633 Count => Target_Count);
|
|
634
|
|
635 pragma Assert (Target_Subtree /= null);
|
|
636 pragma Assert (Target_Subtree.Parent = Parent.Node);
|
|
637 pragma Assert (Target_Count >= 1);
|
|
638
|
|
639 Insert_Subtree_Node
|
|
640 (Subtree => Target_Subtree,
|
|
641 Parent => Parent.Node,
|
|
642 Before => Before.Node);
|
|
643
|
|
644 -- In order for operation Node_Count to complete in O(1) time, we cache
|
|
645 -- the count value. Here we increment the total count by the number of
|
|
646 -- nodes we just inserted.
|
|
647
|
|
648 Target.Count := Target.Count + Target_Count;
|
|
649 end Copy_Subtree;
|
|
650
|
|
651 procedure Copy_Subtree
|
|
652 (Source : Tree_Node_Access;
|
|
653 Parent : Tree_Node_Access;
|
|
654 Target : out Tree_Node_Access;
|
|
655 Count : in out Count_Type)
|
|
656 is
|
|
657 E : constant Element_Access := new Element_Type'(Source.Element.all);
|
|
658
|
|
659 begin
|
|
660 Target := new Tree_Node_Type'(Element => E,
|
|
661 Parent => Parent,
|
|
662 others => <>);
|
|
663
|
|
664 Count := Count + 1;
|
|
665
|
|
666 Copy_Children
|
|
667 (Source => Source.Children,
|
|
668 Parent => Target,
|
|
669 Count => Count);
|
|
670 end Copy_Subtree;
|
|
671
|
|
672 -------------------------
|
|
673 -- Deallocate_Children --
|
|
674 -------------------------
|
|
675
|
|
676 procedure Deallocate_Children
|
|
677 (Subtree : Tree_Node_Access;
|
|
678 Count : in out Count_Type)
|
|
679 is
|
|
680 pragma Assert (Subtree /= null);
|
|
681
|
|
682 CC : Children_Type := Subtree.Children;
|
|
683 C : Tree_Node_Access;
|
|
684
|
|
685 begin
|
|
686 -- We immediately remove the children from their parent, in order to
|
|
687 -- preserve invariants in case the deallocation fails.
|
|
688
|
|
689 Subtree.Children := Children_Type'(others => null);
|
|
690
|
|
691 while CC.First /= null loop
|
|
692 C := CC.First;
|
|
693 CC.First := C.Next;
|
|
694
|
|
695 Deallocate_Subtree (C, Count);
|
|
696 end loop;
|
|
697 end Deallocate_Children;
|
|
698
|
|
699 ---------------------
|
|
700 -- Deallocate_Node --
|
|
701 ---------------------
|
|
702
|
|
703 procedure Deallocate_Node (X : in out Tree_Node_Access) is
|
|
704 procedure Free_Node is
|
|
705 new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access);
|
|
706
|
|
707 -- Start of processing for Deallocate_Node
|
|
708
|
|
709 begin
|
|
710 if X /= null then
|
|
711 Free_Element (X.Element);
|
|
712 Free_Node (X);
|
|
713 end if;
|
|
714 end Deallocate_Node;
|
|
715
|
|
716 ------------------------
|
|
717 -- Deallocate_Subtree --
|
|
718 ------------------------
|
|
719
|
|
720 procedure Deallocate_Subtree
|
|
721 (Subtree : in out Tree_Node_Access;
|
|
722 Count : in out Count_Type)
|
|
723 is
|
|
724 begin
|
|
725 Deallocate_Children (Subtree, Count);
|
|
726 Deallocate_Node (Subtree);
|
|
727 Count := Count + 1;
|
|
728 end Deallocate_Subtree;
|
|
729
|
|
730 ---------------------
|
|
731 -- Delete_Children --
|
|
732 ---------------------
|
|
733
|
|
734 procedure Delete_Children
|
|
735 (Container : in out Tree;
|
|
736 Parent : Cursor)
|
|
737 is
|
|
738 Count : Count_Type;
|
|
739
|
|
740 begin
|
|
741 if Checks and then Parent = No_Element then
|
|
742 raise Constraint_Error with "Parent cursor has no element";
|
|
743 end if;
|
|
744
|
|
745 if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
746 raise Program_Error with "Parent cursor not in container";
|
|
747 end if;
|
|
748
|
|
749 TC_Check (Container.TC);
|
|
750
|
|
751 -- Deallocate_Children returns a count of the number of nodes
|
|
752 -- that it deallocates, but it works by incrementing the
|
|
753 -- value that is passed in. We must therefore initialize
|
|
754 -- the count value before calling Deallocate_Children.
|
|
755
|
|
756 Count := 0;
|
|
757
|
|
758 Deallocate_Children (Parent.Node, Count);
|
|
759 pragma Assert (Count <= Container.Count);
|
|
760
|
|
761 Container.Count := Container.Count - Count;
|
|
762 end Delete_Children;
|
|
763
|
|
764 -----------------
|
|
765 -- Delete_Leaf --
|
|
766 -----------------
|
|
767
|
|
768 procedure Delete_Leaf
|
|
769 (Container : in out Tree;
|
|
770 Position : in out Cursor)
|
|
771 is
|
|
772 X : Tree_Node_Access;
|
|
773
|
|
774 begin
|
|
775 if Checks and then Position = No_Element then
|
|
776 raise Constraint_Error with "Position cursor has no element";
|
|
777 end if;
|
|
778
|
|
779 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
780 then
|
|
781 raise Program_Error with "Position cursor not in container";
|
|
782 end if;
|
|
783
|
|
784 if Checks and then Is_Root (Position) then
|
|
785 raise Program_Error with "Position cursor designates root";
|
|
786 end if;
|
|
787
|
|
788 if Checks and then not Is_Leaf (Position) then
|
|
789 raise Constraint_Error with "Position cursor does not designate leaf";
|
|
790 end if;
|
|
791
|
|
792 TC_Check (Container.TC);
|
|
793
|
|
794 X := Position.Node;
|
|
795 Position := No_Element;
|
|
796
|
|
797 -- Restore represention invariants before attempting the actual
|
|
798 -- deallocation.
|
|
799
|
|
800 Remove_Subtree (X);
|
|
801 Container.Count := Container.Count - 1;
|
|
802
|
|
803 -- It is now safe to attempt the deallocation. This leaf node has been
|
|
804 -- disassociated from the tree, so even if the deallocation fails,
|
|
805 -- representation invariants will remain satisfied.
|
|
806
|
|
807 Deallocate_Node (X);
|
|
808 end Delete_Leaf;
|
|
809
|
|
810 --------------------
|
|
811 -- Delete_Subtree --
|
|
812 --------------------
|
|
813
|
|
814 procedure Delete_Subtree
|
|
815 (Container : in out Tree;
|
|
816 Position : in out Cursor)
|
|
817 is
|
|
818 X : Tree_Node_Access;
|
|
819 Count : Count_Type;
|
|
820
|
|
821 begin
|
|
822 if Checks and then Position = No_Element then
|
|
823 raise Constraint_Error with "Position cursor has no element";
|
|
824 end if;
|
|
825
|
|
826 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
827 then
|
|
828 raise Program_Error with "Position cursor not in container";
|
|
829 end if;
|
|
830
|
|
831 if Checks and then Is_Root (Position) then
|
|
832 raise Program_Error with "Position cursor designates root";
|
|
833 end if;
|
|
834
|
|
835 TC_Check (Container.TC);
|
|
836
|
|
837 X := Position.Node;
|
|
838 Position := No_Element;
|
|
839
|
|
840 -- Here is one case where a deallocation failure can result in the
|
|
841 -- violation of a representation invariant. We disassociate the subtree
|
|
842 -- from the tree now, but we only decrement the total node count after
|
|
843 -- we attempt the deallocation. However, if the deallocation fails, the
|
|
844 -- total node count will not get decremented.
|
|
845
|
|
846 -- One way around this dilemma is to count the nodes in the subtree
|
|
847 -- before attempt to delete the subtree, but that is an O(n) operation,
|
|
848 -- so it does not seem worth it.
|
|
849
|
|
850 -- Perhaps this is much ado about nothing, since the only way
|
|
851 -- deallocation can fail is if Controlled Finalization fails: this
|
|
852 -- propagates Program_Error so all bets are off anyway. ???
|
|
853
|
|
854 Remove_Subtree (X);
|
|
855
|
|
856 -- Deallocate_Subtree returns a count of the number of nodes that it
|
|
857 -- deallocates, but it works by incrementing the value that is passed
|
|
858 -- in. We must therefore initialize the count value before calling
|
|
859 -- Deallocate_Subtree.
|
|
860
|
|
861 Count := 0;
|
|
862
|
|
863 Deallocate_Subtree (X, Count);
|
|
864 pragma Assert (Count <= Container.Count);
|
|
865
|
|
866 -- See comments above. We would prefer to do this sooner, but there's no
|
|
867 -- way to satisfy that goal without an potentially severe execution
|
|
868 -- penalty.
|
|
869
|
|
870 Container.Count := Container.Count - Count;
|
|
871 end Delete_Subtree;
|
|
872
|
|
873 -----------
|
|
874 -- Depth --
|
|
875 -----------
|
|
876
|
|
877 function Depth (Position : Cursor) return Count_Type is
|
|
878 Result : Count_Type;
|
|
879 N : Tree_Node_Access;
|
|
880
|
|
881 begin
|
|
882 Result := 0;
|
|
883 N := Position.Node;
|
|
884 while N /= null loop
|
|
885 N := N.Parent;
|
|
886 Result := Result + 1;
|
|
887 end loop;
|
|
888
|
|
889 return Result;
|
|
890 end Depth;
|
|
891
|
|
892 -------------
|
|
893 -- Element --
|
|
894 -------------
|
|
895
|
|
896 function Element (Position : Cursor) return Element_Type is
|
|
897 begin
|
|
898 if Checks and then Position.Container = null then
|
|
899 raise Constraint_Error with "Position cursor has no element";
|
|
900 end if;
|
|
901
|
|
902 if Checks and then Position.Node = Root_Node (Position.Container.all)
|
|
903 then
|
|
904 raise Program_Error with "Position cursor designates root";
|
|
905 end if;
|
|
906
|
|
907 return Position.Node.Element.all;
|
|
908 end Element;
|
|
909
|
|
910 --------------------
|
|
911 -- Equal_Children --
|
|
912 --------------------
|
|
913
|
|
914 function Equal_Children
|
|
915 (Left_Subtree : Tree_Node_Access;
|
|
916 Right_Subtree : Tree_Node_Access) return Boolean
|
|
917 is
|
|
918 Left_Children : Children_Type renames Left_Subtree.Children;
|
|
919 Right_Children : Children_Type renames Right_Subtree.Children;
|
|
920
|
|
921 L, R : Tree_Node_Access;
|
|
922
|
|
923 begin
|
|
924 if Child_Count (Left_Children) /= Child_Count (Right_Children) then
|
|
925 return False;
|
|
926 end if;
|
|
927
|
|
928 L := Left_Children.First;
|
|
929 R := Right_Children.First;
|
|
930 while L /= null loop
|
|
931 if not Equal_Subtree (L, R) then
|
|
932 return False;
|
|
933 end if;
|
|
934
|
|
935 L := L.Next;
|
|
936 R := R.Next;
|
|
937 end loop;
|
|
938
|
|
939 return True;
|
|
940 end Equal_Children;
|
|
941
|
|
942 -------------------
|
|
943 -- Equal_Subtree --
|
|
944 -------------------
|
|
945
|
|
946 function Equal_Subtree
|
|
947 (Left_Position : Cursor;
|
|
948 Right_Position : Cursor) return Boolean
|
|
949 is
|
|
950 begin
|
|
951 if Checks and then Left_Position = No_Element then
|
|
952 raise Constraint_Error with "Left cursor has no element";
|
|
953 end if;
|
|
954
|
|
955 if Checks and then Right_Position = No_Element then
|
|
956 raise Constraint_Error with "Right cursor has no element";
|
|
957 end if;
|
|
958
|
|
959 if Left_Position = Right_Position then
|
|
960 return True;
|
|
961 end if;
|
|
962
|
|
963 if Is_Root (Left_Position) then
|
|
964 if not Is_Root (Right_Position) then
|
|
965 return False;
|
|
966 end if;
|
|
967
|
|
968 return Equal_Children (Left_Position.Node, Right_Position.Node);
|
|
969 end if;
|
|
970
|
|
971 if Is_Root (Right_Position) then
|
|
972 return False;
|
|
973 end if;
|
|
974
|
|
975 return Equal_Subtree (Left_Position.Node, Right_Position.Node);
|
|
976 end Equal_Subtree;
|
|
977
|
|
978 function Equal_Subtree
|
|
979 (Left_Subtree : Tree_Node_Access;
|
|
980 Right_Subtree : Tree_Node_Access) return Boolean
|
|
981 is
|
|
982 begin
|
|
983 if Left_Subtree.Element.all /= Right_Subtree.Element.all then
|
|
984 return False;
|
|
985 end if;
|
|
986
|
|
987 return Equal_Children (Left_Subtree, Right_Subtree);
|
|
988 end Equal_Subtree;
|
|
989
|
|
990 --------------
|
|
991 -- Finalize --
|
|
992 --------------
|
|
993
|
|
994 procedure Finalize (Object : in out Root_Iterator) is
|
|
995 begin
|
|
996 Unbusy (Object.Container.TC);
|
|
997 end Finalize;
|
|
998
|
|
999 ----------
|
|
1000 -- Find --
|
|
1001 ----------
|
|
1002
|
|
1003 function Find
|
|
1004 (Container : Tree;
|
|
1005 Item : Element_Type) return Cursor
|
|
1006 is
|
|
1007 N : constant Tree_Node_Access :=
|
|
1008 Find_In_Children (Root_Node (Container), Item);
|
|
1009
|
|
1010 begin
|
|
1011 if N = null then
|
|
1012 return No_Element;
|
|
1013 end if;
|
|
1014
|
|
1015 return Cursor'(Container'Unrestricted_Access, N);
|
|
1016 end Find;
|
|
1017
|
|
1018 -----------
|
|
1019 -- First --
|
|
1020 -----------
|
|
1021
|
|
1022 overriding function First (Object : Subtree_Iterator) return Cursor is
|
|
1023 begin
|
|
1024 if Object.Subtree = Root_Node (Object.Container.all) then
|
|
1025 return First_Child (Root (Object.Container.all));
|
|
1026 else
|
|
1027 return Cursor'(Object.Container, Object.Subtree);
|
|
1028 end if;
|
|
1029 end First;
|
|
1030
|
|
1031 overriding function First (Object : Child_Iterator) return Cursor is
|
|
1032 begin
|
|
1033 return First_Child (Cursor'(Object.Container, Object.Subtree));
|
|
1034 end First;
|
|
1035
|
|
1036 -----------------
|
|
1037 -- First_Child --
|
|
1038 -----------------
|
|
1039
|
|
1040 function First_Child (Parent : Cursor) return Cursor is
|
|
1041 Node : Tree_Node_Access;
|
|
1042
|
|
1043 begin
|
|
1044 if Checks and then Parent = No_Element then
|
|
1045 raise Constraint_Error with "Parent cursor has no element";
|
|
1046 end if;
|
|
1047
|
|
1048 Node := Parent.Node.Children.First;
|
|
1049
|
|
1050 if Node = null then
|
|
1051 return No_Element;
|
|
1052 end if;
|
|
1053
|
|
1054 return Cursor'(Parent.Container, Node);
|
|
1055 end First_Child;
|
|
1056
|
|
1057 -------------------------
|
|
1058 -- First_Child_Element --
|
|
1059 -------------------------
|
|
1060
|
|
1061 function First_Child_Element (Parent : Cursor) return Element_Type is
|
|
1062 begin
|
|
1063 return Element (First_Child (Parent));
|
|
1064 end First_Child_Element;
|
|
1065
|
|
1066 ----------------------
|
|
1067 -- Find_In_Children --
|
|
1068 ----------------------
|
|
1069
|
|
1070 function Find_In_Children
|
|
1071 (Subtree : Tree_Node_Access;
|
|
1072 Item : Element_Type) return Tree_Node_Access
|
|
1073 is
|
|
1074 N, Result : Tree_Node_Access;
|
|
1075
|
|
1076 begin
|
|
1077 N := Subtree.Children.First;
|
|
1078 while N /= null loop
|
|
1079 Result := Find_In_Subtree (N, Item);
|
|
1080
|
|
1081 if Result /= null then
|
|
1082 return Result;
|
|
1083 end if;
|
|
1084
|
|
1085 N := N.Next;
|
|
1086 end loop;
|
|
1087
|
|
1088 return null;
|
|
1089 end Find_In_Children;
|
|
1090
|
|
1091 ---------------------
|
|
1092 -- Find_In_Subtree --
|
|
1093 ---------------------
|
|
1094
|
|
1095 function Find_In_Subtree
|
|
1096 (Position : Cursor;
|
|
1097 Item : Element_Type) return Cursor
|
|
1098 is
|
|
1099 Result : Tree_Node_Access;
|
|
1100
|
|
1101 begin
|
|
1102 if Checks and then Position = No_Element then
|
|
1103 raise Constraint_Error with "Position cursor has no element";
|
|
1104 end if;
|
|
1105
|
|
1106 -- Commented-out pending ruling from ARG. ???
|
|
1107
|
|
1108 -- if Checks and then
|
|
1109 -- Position.Container /= Container'Unrestricted_Access
|
|
1110 -- then
|
|
1111 -- raise Program_Error with "Position cursor not in container";
|
|
1112 -- end if;
|
|
1113
|
|
1114 if Is_Root (Position) then
|
|
1115 Result := Find_In_Children (Position.Node, Item);
|
|
1116
|
|
1117 else
|
|
1118 Result := Find_In_Subtree (Position.Node, Item);
|
|
1119 end if;
|
|
1120
|
|
1121 if Result = null then
|
|
1122 return No_Element;
|
|
1123 end if;
|
|
1124
|
|
1125 return Cursor'(Position.Container, Result);
|
|
1126 end Find_In_Subtree;
|
|
1127
|
|
1128 function Find_In_Subtree
|
|
1129 (Subtree : Tree_Node_Access;
|
|
1130 Item : Element_Type) return Tree_Node_Access
|
|
1131 is
|
|
1132 begin
|
|
1133 if Subtree.Element.all = Item then
|
|
1134 return Subtree;
|
|
1135 end if;
|
|
1136
|
|
1137 return Find_In_Children (Subtree, Item);
|
|
1138 end Find_In_Subtree;
|
|
1139
|
|
1140 ------------------------
|
|
1141 -- Get_Element_Access --
|
|
1142 ------------------------
|
|
1143
|
|
1144 function Get_Element_Access
|
|
1145 (Position : Cursor) return not null Element_Access is
|
|
1146 begin
|
|
1147 return Position.Node.Element;
|
|
1148 end Get_Element_Access;
|
|
1149
|
|
1150 -----------------
|
|
1151 -- Has_Element --
|
|
1152 -----------------
|
|
1153
|
|
1154 function Has_Element (Position : Cursor) return Boolean is
|
|
1155 begin
|
|
1156 if Position = No_Element then
|
|
1157 return False;
|
|
1158 end if;
|
|
1159
|
|
1160 return Position.Node.Parent /= null;
|
|
1161 end Has_Element;
|
|
1162
|
|
1163 ------------------
|
|
1164 -- Insert_Child --
|
|
1165 ------------------
|
|
1166
|
|
1167 procedure Insert_Child
|
|
1168 (Container : in out Tree;
|
|
1169 Parent : Cursor;
|
|
1170 Before : Cursor;
|
|
1171 New_Item : Element_Type;
|
|
1172 Count : Count_Type := 1)
|
|
1173 is
|
|
1174 Position : Cursor;
|
|
1175 pragma Unreferenced (Position);
|
|
1176
|
|
1177 begin
|
|
1178 Insert_Child (Container, Parent, Before, New_Item, Position, Count);
|
|
1179 end Insert_Child;
|
|
1180
|
|
1181 procedure Insert_Child
|
|
1182 (Container : in out Tree;
|
|
1183 Parent : Cursor;
|
|
1184 Before : Cursor;
|
|
1185 New_Item : Element_Type;
|
|
1186 Position : out Cursor;
|
|
1187 Count : Count_Type := 1)
|
|
1188 is
|
|
1189 First : Tree_Node_Access;
|
|
1190 Last : Tree_Node_Access;
|
|
1191 Element : Element_Access;
|
|
1192
|
|
1193 begin
|
|
1194 if Checks and then Parent = No_Element then
|
|
1195 raise Constraint_Error with "Parent cursor has no element";
|
|
1196 end if;
|
|
1197
|
|
1198 if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
1199 raise Program_Error with "Parent cursor not in container";
|
|
1200 end if;
|
|
1201
|
|
1202 if Before /= No_Element then
|
|
1203 if Checks and then Before.Container /= Container'Unrestricted_Access
|
|
1204 then
|
|
1205 raise Program_Error with "Before cursor not in container";
|
|
1206 end if;
|
|
1207
|
|
1208 if Checks and then Before.Node.Parent /= Parent.Node then
|
|
1209 raise Constraint_Error with "Parent cursor not parent of Before";
|
|
1210 end if;
|
|
1211 end if;
|
|
1212
|
|
1213 if Count = 0 then
|
|
1214 Position := No_Element; -- Need ruling from ARG ???
|
|
1215 return;
|
|
1216 end if;
|
|
1217
|
|
1218 TC_Check (Container.TC);
|
|
1219
|
|
1220 declare
|
|
1221 -- The element allocator may need an accessibility check in the case
|
|
1222 -- the actual type is class-wide or has access discriminants (see
|
|
1223 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
|
|
1224 -- allocator in the loop below, because the one in this block would
|
|
1225 -- have failed already.
|
|
1226
|
|
1227 pragma Unsuppress (Accessibility_Check);
|
|
1228
|
|
1229 begin
|
|
1230 Element := new Element_Type'(New_Item);
|
|
1231 end;
|
|
1232
|
|
1233 First := new Tree_Node_Type'(Parent => Parent.Node,
|
|
1234 Element => Element,
|
|
1235 others => <>);
|
|
1236
|
|
1237 Last := First;
|
|
1238 for J in Count_Type'(2) .. Count loop
|
|
1239
|
|
1240 -- Reclaim other nodes if Storage_Error. ???
|
|
1241
|
|
1242 Element := new Element_Type'(New_Item);
|
|
1243 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
|
|
1244 Prev => Last,
|
|
1245 Element => Element,
|
|
1246 others => <>);
|
|
1247
|
|
1248 Last := Last.Next;
|
|
1249 end loop;
|
|
1250
|
|
1251 Insert_Subtree_List
|
|
1252 (First => First,
|
|
1253 Last => Last,
|
|
1254 Parent => Parent.Node,
|
|
1255 Before => Before.Node);
|
|
1256
|
|
1257 -- In order for operation Node_Count to complete in O(1) time, we cache
|
|
1258 -- the count value. Here we increment the total count by the number of
|
|
1259 -- nodes we just inserted.
|
|
1260
|
|
1261 Container.Count := Container.Count + Count;
|
|
1262
|
|
1263 Position := Cursor'(Parent.Container, First);
|
|
1264 end Insert_Child;
|
|
1265
|
|
1266 -------------------------
|
|
1267 -- Insert_Subtree_List --
|
|
1268 -------------------------
|
|
1269
|
|
1270 procedure Insert_Subtree_List
|
|
1271 (First : Tree_Node_Access;
|
|
1272 Last : Tree_Node_Access;
|
|
1273 Parent : Tree_Node_Access;
|
|
1274 Before : Tree_Node_Access)
|
|
1275 is
|
|
1276 pragma Assert (Parent /= null);
|
|
1277 C : Children_Type renames Parent.Children;
|
|
1278
|
|
1279 begin
|
|
1280 -- This is a simple utility operation to insert a list of nodes (from
|
|
1281 -- First..Last) as children of Parent. The Before node specifies where
|
|
1282 -- the new children should be inserted relative to the existing
|
|
1283 -- children.
|
|
1284
|
|
1285 if First = null then
|
|
1286 pragma Assert (Last = null);
|
|
1287 return;
|
|
1288 end if;
|
|
1289
|
|
1290 pragma Assert (Last /= null);
|
|
1291 pragma Assert (Before = null or else Before.Parent = Parent);
|
|
1292
|
|
1293 if C.First = null then
|
|
1294 C.First := First;
|
|
1295 C.First.Prev := null;
|
|
1296 C.Last := Last;
|
|
1297 C.Last.Next := null;
|
|
1298
|
|
1299 elsif Before = null then -- means "insert after existing nodes"
|
|
1300 C.Last.Next := First;
|
|
1301 First.Prev := C.Last;
|
|
1302 C.Last := Last;
|
|
1303 C.Last.Next := null;
|
|
1304
|
|
1305 elsif Before = C.First then
|
|
1306 Last.Next := C.First;
|
|
1307 C.First.Prev := Last;
|
|
1308 C.First := First;
|
|
1309 C.First.Prev := null;
|
|
1310
|
|
1311 else
|
|
1312 Before.Prev.Next := First;
|
|
1313 First.Prev := Before.Prev;
|
|
1314 Last.Next := Before;
|
|
1315 Before.Prev := Last;
|
|
1316 end if;
|
|
1317 end Insert_Subtree_List;
|
|
1318
|
|
1319 -------------------------
|
|
1320 -- Insert_Subtree_Node --
|
|
1321 -------------------------
|
|
1322
|
|
1323 procedure Insert_Subtree_Node
|
|
1324 (Subtree : Tree_Node_Access;
|
|
1325 Parent : Tree_Node_Access;
|
|
1326 Before : Tree_Node_Access)
|
|
1327 is
|
|
1328 begin
|
|
1329 -- This is a simple wrapper operation to insert a single child into the
|
|
1330 -- Parent's children list.
|
|
1331
|
|
1332 Insert_Subtree_List
|
|
1333 (First => Subtree,
|
|
1334 Last => Subtree,
|
|
1335 Parent => Parent,
|
|
1336 Before => Before);
|
|
1337 end Insert_Subtree_Node;
|
|
1338
|
|
1339 --------------
|
|
1340 -- Is_Empty --
|
|
1341 --------------
|
|
1342
|
|
1343 function Is_Empty (Container : Tree) return Boolean is
|
|
1344 begin
|
|
1345 return Container.Root.Children.First = null;
|
|
1346 end Is_Empty;
|
|
1347
|
|
1348 -------------
|
|
1349 -- Is_Leaf --
|
|
1350 -------------
|
|
1351
|
|
1352 function Is_Leaf (Position : Cursor) return Boolean is
|
|
1353 begin
|
|
1354 if Position = No_Element then
|
|
1355 return False;
|
|
1356 end if;
|
|
1357
|
|
1358 return Position.Node.Children.First = null;
|
|
1359 end Is_Leaf;
|
|
1360
|
|
1361 ------------------
|
|
1362 -- Is_Reachable --
|
|
1363 ------------------
|
|
1364
|
|
1365 function Is_Reachable (From, To : Tree_Node_Access) return Boolean is
|
|
1366 pragma Assert (From /= null);
|
|
1367 pragma Assert (To /= null);
|
|
1368
|
|
1369 N : Tree_Node_Access;
|
|
1370
|
|
1371 begin
|
|
1372 N := From;
|
|
1373 while N /= null loop
|
|
1374 if N = To then
|
|
1375 return True;
|
|
1376 end if;
|
|
1377
|
|
1378 N := N.Parent;
|
|
1379 end loop;
|
|
1380
|
|
1381 return False;
|
|
1382 end Is_Reachable;
|
|
1383
|
|
1384 -------------
|
|
1385 -- Is_Root --
|
|
1386 -------------
|
|
1387
|
|
1388 function Is_Root (Position : Cursor) return Boolean is
|
|
1389 begin
|
|
1390 if Position.Container = null then
|
|
1391 return False;
|
|
1392 end if;
|
|
1393
|
|
1394 return Position = Root (Position.Container.all);
|
|
1395 end Is_Root;
|
|
1396
|
|
1397 -------------
|
|
1398 -- Iterate --
|
|
1399 -------------
|
|
1400
|
|
1401 procedure Iterate
|
|
1402 (Container : Tree;
|
|
1403 Process : not null access procedure (Position : Cursor))
|
|
1404 is
|
|
1405 Busy : With_Busy (Container.TC'Unrestricted_Access);
|
|
1406 begin
|
|
1407 Iterate_Children
|
|
1408 (Container => Container'Unrestricted_Access,
|
|
1409 Subtree => Root_Node (Container),
|
|
1410 Process => Process);
|
|
1411 end Iterate;
|
|
1412
|
|
1413 function Iterate (Container : Tree)
|
|
1414 return Tree_Iterator_Interfaces.Forward_Iterator'Class
|
|
1415 is
|
|
1416 begin
|
|
1417 return Iterate_Subtree (Root (Container));
|
|
1418 end Iterate;
|
|
1419
|
|
1420 ----------------------
|
|
1421 -- Iterate_Children --
|
|
1422 ----------------------
|
|
1423
|
|
1424 procedure Iterate_Children
|
|
1425 (Parent : Cursor;
|
|
1426 Process : not null access procedure (Position : Cursor))
|
|
1427 is
|
|
1428 C : Tree_Node_Access;
|
|
1429 Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
|
|
1430 begin
|
|
1431 if Checks and then Parent = No_Element then
|
|
1432 raise Constraint_Error with "Parent cursor has no element";
|
|
1433 end if;
|
|
1434
|
|
1435 C := Parent.Node.Children.First;
|
|
1436 while C /= null loop
|
|
1437 Process (Position => Cursor'(Parent.Container, Node => C));
|
|
1438 C := C.Next;
|
|
1439 end loop;
|
|
1440 end Iterate_Children;
|
|
1441
|
|
1442 procedure Iterate_Children
|
|
1443 (Container : Tree_Access;
|
|
1444 Subtree : Tree_Node_Access;
|
|
1445 Process : not null access procedure (Position : Cursor))
|
|
1446 is
|
|
1447 Node : Tree_Node_Access;
|
|
1448
|
|
1449 begin
|
|
1450 -- This is a helper function to recursively iterate over all the nodes
|
|
1451 -- in a subtree, in depth-first fashion. This particular helper just
|
|
1452 -- visits the children of this subtree, not the root of the subtree node
|
|
1453 -- itself. This is useful when starting from the ultimate root of the
|
|
1454 -- entire tree (see Iterate), as that root does not have an element.
|
|
1455
|
|
1456 Node := Subtree.Children.First;
|
|
1457 while Node /= null loop
|
|
1458 Iterate_Subtree (Container, Node, Process);
|
|
1459 Node := Node.Next;
|
|
1460 end loop;
|
|
1461 end Iterate_Children;
|
|
1462
|
|
1463 function Iterate_Children
|
|
1464 (Container : Tree;
|
|
1465 Parent : Cursor)
|
|
1466 return Tree_Iterator_Interfaces.Reversible_Iterator'Class
|
|
1467 is
|
|
1468 C : constant Tree_Access := Container'Unrestricted_Access;
|
|
1469 begin
|
|
1470 if Checks and then Parent = No_Element then
|
|
1471 raise Constraint_Error with "Parent cursor has no element";
|
|
1472 end if;
|
|
1473
|
|
1474 if Checks and then Parent.Container /= C then
|
|
1475 raise Program_Error with "Parent cursor not in container";
|
|
1476 end if;
|
|
1477
|
|
1478 return It : constant Child_Iterator :=
|
|
1479 Child_Iterator'(Limited_Controlled with
|
|
1480 Container => C,
|
|
1481 Subtree => Parent.Node)
|
|
1482 do
|
|
1483 Busy (C.TC);
|
|
1484 end return;
|
|
1485 end Iterate_Children;
|
|
1486
|
|
1487 ---------------------
|
|
1488 -- Iterate_Subtree --
|
|
1489 ---------------------
|
|
1490
|
|
1491 function Iterate_Subtree
|
|
1492 (Position : Cursor)
|
|
1493 return Tree_Iterator_Interfaces.Forward_Iterator'Class
|
|
1494 is
|
|
1495 C : constant Tree_Access := Position.Container;
|
|
1496 begin
|
|
1497 if Checks and then Position = No_Element then
|
|
1498 raise Constraint_Error with "Position cursor has no element";
|
|
1499 end if;
|
|
1500
|
|
1501 -- Implement Vet for multiway trees???
|
|
1502 -- pragma Assert (Vet (Position), "bad subtree cursor");
|
|
1503
|
|
1504 return It : constant Subtree_Iterator :=
|
|
1505 (Limited_Controlled with
|
|
1506 Container => Position.Container,
|
|
1507 Subtree => Position.Node)
|
|
1508 do
|
|
1509 Busy (C.TC);
|
|
1510 end return;
|
|
1511 end Iterate_Subtree;
|
|
1512
|
|
1513 procedure Iterate_Subtree
|
|
1514 (Position : Cursor;
|
|
1515 Process : not null access procedure (Position : Cursor))
|
|
1516 is
|
|
1517 Busy : With_Busy (Position.Container.TC'Unrestricted_Access);
|
|
1518 begin
|
|
1519 if Checks and then Position = No_Element then
|
|
1520 raise Constraint_Error with "Position cursor has no element";
|
|
1521 end if;
|
|
1522
|
|
1523 if Is_Root (Position) then
|
|
1524 Iterate_Children (Position.Container, Position.Node, Process);
|
|
1525 else
|
|
1526 Iterate_Subtree (Position.Container, Position.Node, Process);
|
|
1527 end if;
|
|
1528 end Iterate_Subtree;
|
|
1529
|
|
1530 procedure Iterate_Subtree
|
|
1531 (Container : Tree_Access;
|
|
1532 Subtree : Tree_Node_Access;
|
|
1533 Process : not null access procedure (Position : Cursor))
|
|
1534 is
|
|
1535 begin
|
|
1536 -- This is a helper function to recursively iterate over all the nodes
|
|
1537 -- in a subtree, in depth-first fashion. It first visits the root of the
|
|
1538 -- subtree, then visits its children.
|
|
1539
|
|
1540 Process (Cursor'(Container, Subtree));
|
|
1541 Iterate_Children (Container, Subtree, Process);
|
|
1542 end Iterate_Subtree;
|
|
1543
|
|
1544 ----------
|
|
1545 -- Last --
|
|
1546 ----------
|
|
1547
|
|
1548 overriding function Last (Object : Child_Iterator) return Cursor is
|
|
1549 begin
|
|
1550 return Last_Child (Cursor'(Object.Container, Object.Subtree));
|
|
1551 end Last;
|
|
1552
|
|
1553 ----------------
|
|
1554 -- Last_Child --
|
|
1555 ----------------
|
|
1556
|
|
1557 function Last_Child (Parent : Cursor) return Cursor is
|
|
1558 Node : Tree_Node_Access;
|
|
1559
|
|
1560 begin
|
|
1561 if Checks and then Parent = No_Element then
|
|
1562 raise Constraint_Error with "Parent cursor has no element";
|
|
1563 end if;
|
|
1564
|
|
1565 Node := Parent.Node.Children.Last;
|
|
1566
|
|
1567 if Node = null then
|
|
1568 return No_Element;
|
|
1569 end if;
|
|
1570
|
|
1571 return (Parent.Container, Node);
|
|
1572 end Last_Child;
|
|
1573
|
|
1574 ------------------------
|
|
1575 -- Last_Child_Element --
|
|
1576 ------------------------
|
|
1577
|
|
1578 function Last_Child_Element (Parent : Cursor) return Element_Type is
|
|
1579 begin
|
|
1580 return Element (Last_Child (Parent));
|
|
1581 end Last_Child_Element;
|
|
1582
|
|
1583 ----------
|
|
1584 -- Move --
|
|
1585 ----------
|
|
1586
|
|
1587 procedure Move (Target : in out Tree; Source : in out Tree) is
|
|
1588 Node : Tree_Node_Access;
|
|
1589
|
|
1590 begin
|
|
1591 if Target'Address = Source'Address then
|
|
1592 return;
|
|
1593 end if;
|
|
1594
|
|
1595 TC_Check (Source.TC);
|
|
1596
|
|
1597 Target.Clear; -- checks busy bit
|
|
1598
|
|
1599 Target.Root.Children := Source.Root.Children;
|
|
1600 Source.Root.Children := Children_Type'(others => null);
|
|
1601
|
|
1602 Node := Target.Root.Children.First;
|
|
1603 while Node /= null loop
|
|
1604 Node.Parent := Root_Node (Target);
|
|
1605 Node := Node.Next;
|
|
1606 end loop;
|
|
1607
|
|
1608 Target.Count := Source.Count;
|
|
1609 Source.Count := 0;
|
|
1610 end Move;
|
|
1611
|
|
1612 ----------
|
|
1613 -- Next --
|
|
1614 ----------
|
|
1615
|
|
1616 function Next
|
|
1617 (Object : Subtree_Iterator;
|
|
1618 Position : Cursor) return Cursor
|
|
1619 is
|
|
1620 Node : Tree_Node_Access;
|
|
1621
|
|
1622 begin
|
|
1623 if Position.Container = null then
|
|
1624 return No_Element;
|
|
1625 end if;
|
|
1626
|
|
1627 if Checks and then Position.Container /= Object.Container then
|
|
1628 raise Program_Error with
|
|
1629 "Position cursor of Next designates wrong tree";
|
|
1630 end if;
|
|
1631
|
|
1632 Node := Position.Node;
|
|
1633
|
|
1634 if Node.Children.First /= null then
|
|
1635 return Cursor'(Object.Container, Node.Children.First);
|
|
1636 end if;
|
|
1637
|
|
1638 while Node /= Object.Subtree loop
|
|
1639 if Node.Next /= null then
|
|
1640 return Cursor'(Object.Container, Node.Next);
|
|
1641 end if;
|
|
1642
|
|
1643 Node := Node.Parent;
|
|
1644 end loop;
|
|
1645
|
|
1646 return No_Element;
|
|
1647 end Next;
|
|
1648
|
|
1649 function Next
|
|
1650 (Object : Child_Iterator;
|
|
1651 Position : Cursor) return Cursor
|
|
1652 is
|
|
1653 begin
|
|
1654 if Position.Container = null then
|
|
1655 return No_Element;
|
|
1656 end if;
|
|
1657
|
|
1658 if Checks and then Position.Container /= Object.Container then
|
|
1659 raise Program_Error with
|
|
1660 "Position cursor of Next designates wrong tree";
|
|
1661 end if;
|
|
1662
|
|
1663 return Next_Sibling (Position);
|
|
1664 end Next;
|
|
1665
|
|
1666 ------------------
|
|
1667 -- Next_Sibling --
|
|
1668 ------------------
|
|
1669
|
|
1670 function Next_Sibling (Position : Cursor) return Cursor is
|
|
1671 begin
|
|
1672 if Position = No_Element then
|
|
1673 return No_Element;
|
|
1674 end if;
|
|
1675
|
|
1676 if Position.Node.Next = null then
|
|
1677 return No_Element;
|
|
1678 end if;
|
|
1679
|
|
1680 return Cursor'(Position.Container, Position.Node.Next);
|
|
1681 end Next_Sibling;
|
|
1682
|
|
1683 procedure Next_Sibling (Position : in out Cursor) is
|
|
1684 begin
|
|
1685 Position := Next_Sibling (Position);
|
|
1686 end Next_Sibling;
|
|
1687
|
|
1688 ----------------
|
|
1689 -- Node_Count --
|
|
1690 ----------------
|
|
1691
|
|
1692 function Node_Count (Container : Tree) return Count_Type is
|
|
1693 begin
|
|
1694 -- Container.Count is the number of nodes we have actually allocated. We
|
|
1695 -- cache the value specifically so this Node_Count operation can execute
|
|
1696 -- in O(1) time, which makes it behave similarly to how the Length
|
|
1697 -- selector function behaves for other containers.
|
|
1698 --
|
|
1699 -- The cached node count value only describes the nodes we have
|
|
1700 -- allocated; the root node itself is not included in that count. The
|
|
1701 -- Node_Count operation returns a value that includes the root node
|
|
1702 -- (because the RM says so), so we must add 1 to our cached value.
|
|
1703
|
|
1704 return 1 + Container.Count;
|
|
1705 end Node_Count;
|
|
1706
|
|
1707 ------------
|
|
1708 -- Parent --
|
|
1709 ------------
|
|
1710
|
|
1711 function Parent (Position : Cursor) return Cursor is
|
|
1712 begin
|
|
1713 if Position = No_Element then
|
|
1714 return No_Element;
|
|
1715 end if;
|
|
1716
|
|
1717 if Position.Node.Parent = null then
|
|
1718 return No_Element;
|
|
1719 end if;
|
|
1720
|
|
1721 return Cursor'(Position.Container, Position.Node.Parent);
|
|
1722 end Parent;
|
|
1723
|
|
1724 -------------------
|
131
|
1725 -- Prepend_Child --
|
111
|
1726 -------------------
|
|
1727
|
|
1728 procedure Prepend_Child
|
|
1729 (Container : in out Tree;
|
|
1730 Parent : Cursor;
|
|
1731 New_Item : Element_Type;
|
|
1732 Count : Count_Type := 1)
|
|
1733 is
|
|
1734 First, Last : Tree_Node_Access;
|
|
1735 Element : Element_Access;
|
|
1736
|
|
1737 begin
|
|
1738 if Checks and then Parent = No_Element then
|
|
1739 raise Constraint_Error with "Parent cursor has no element";
|
|
1740 end if;
|
|
1741
|
|
1742 if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
1743 raise Program_Error with "Parent cursor not in container";
|
|
1744 end if;
|
|
1745
|
|
1746 if Count = 0 then
|
|
1747 return;
|
|
1748 end if;
|
|
1749
|
|
1750 TC_Check (Container.TC);
|
|
1751
|
|
1752 declare
|
|
1753 -- The element allocator may need an accessibility check in the case
|
|
1754 -- the actual type is class-wide or has access discriminants (see
|
|
1755 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
|
|
1756 -- allocator in the loop below, because the one in this block would
|
|
1757 -- have failed already.
|
|
1758
|
|
1759 pragma Unsuppress (Accessibility_Check);
|
|
1760
|
|
1761 begin
|
|
1762 Element := new Element_Type'(New_Item);
|
|
1763 end;
|
|
1764
|
|
1765 First := new Tree_Node_Type'(Parent => Parent.Node,
|
|
1766 Element => Element,
|
|
1767 others => <>);
|
|
1768
|
|
1769 Last := First;
|
|
1770
|
|
1771 for J in Count_Type'(2) .. Count loop
|
|
1772
|
|
1773 -- Reclaim other nodes if Storage_Error. ???
|
|
1774
|
|
1775 Element := new Element_Type'(New_Item);
|
|
1776 Last.Next := new Tree_Node_Type'(Parent => Parent.Node,
|
|
1777 Prev => Last,
|
|
1778 Element => Element,
|
|
1779 others => <>);
|
|
1780
|
|
1781 Last := Last.Next;
|
|
1782 end loop;
|
|
1783
|
|
1784 Insert_Subtree_List
|
|
1785 (First => First,
|
|
1786 Last => Last,
|
|
1787 Parent => Parent.Node,
|
|
1788 Before => Parent.Node.Children.First);
|
|
1789
|
|
1790 -- In order for operation Node_Count to complete in O(1) time, we cache
|
|
1791 -- the count value. Here we increment the total count by the number of
|
|
1792 -- nodes we just inserted.
|
|
1793
|
|
1794 Container.Count := Container.Count + Count;
|
|
1795 end Prepend_Child;
|
|
1796
|
|
1797 --------------
|
|
1798 -- Previous --
|
|
1799 --------------
|
|
1800
|
|
1801 overriding function Previous
|
|
1802 (Object : Child_Iterator;
|
|
1803 Position : Cursor) return Cursor
|
|
1804 is
|
|
1805 begin
|
|
1806 if Position.Container = null then
|
|
1807 return No_Element;
|
|
1808 end if;
|
|
1809
|
|
1810 if Checks and then Position.Container /= Object.Container then
|
|
1811 raise Program_Error with
|
|
1812 "Position cursor of Previous designates wrong tree";
|
|
1813 end if;
|
|
1814
|
|
1815 return Previous_Sibling (Position);
|
|
1816 end Previous;
|
|
1817
|
|
1818 ----------------------
|
|
1819 -- Previous_Sibling --
|
|
1820 ----------------------
|
|
1821
|
|
1822 function Previous_Sibling (Position : Cursor) return Cursor is
|
|
1823 begin
|
|
1824 if Position = No_Element then
|
|
1825 return No_Element;
|
|
1826 end if;
|
|
1827
|
|
1828 if Position.Node.Prev = null then
|
|
1829 return No_Element;
|
|
1830 end if;
|
|
1831
|
|
1832 return Cursor'(Position.Container, Position.Node.Prev);
|
|
1833 end Previous_Sibling;
|
|
1834
|
|
1835 procedure Previous_Sibling (Position : in out Cursor) is
|
|
1836 begin
|
|
1837 Position := Previous_Sibling (Position);
|
|
1838 end Previous_Sibling;
|
|
1839
|
|
1840 ----------------------
|
|
1841 -- Pseudo_Reference --
|
|
1842 ----------------------
|
|
1843
|
|
1844 function Pseudo_Reference
|
|
1845 (Container : aliased Tree'Class) return Reference_Control_Type
|
|
1846 is
|
|
1847 TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
|
|
1848 begin
|
|
1849 return R : constant Reference_Control_Type := (Controlled with TC) do
|
|
1850 Lock (TC.all);
|
|
1851 end return;
|
|
1852 end Pseudo_Reference;
|
|
1853
|
|
1854 -------------------
|
|
1855 -- Query_Element --
|
|
1856 -------------------
|
|
1857
|
|
1858 procedure Query_Element
|
|
1859 (Position : Cursor;
|
|
1860 Process : not null access procedure (Element : Element_Type))
|
|
1861 is
|
|
1862 T : Tree renames Position.Container.all'Unrestricted_Access.all;
|
|
1863 Lock : With_Lock (T.TC'Unrestricted_Access);
|
|
1864 begin
|
|
1865 if Checks and then Position = No_Element then
|
|
1866 raise Constraint_Error with "Position cursor has no element";
|
|
1867 end if;
|
|
1868
|
|
1869 if Checks and then Is_Root (Position) then
|
|
1870 raise Program_Error with "Position cursor designates root";
|
|
1871 end if;
|
|
1872
|
|
1873 Process (Position.Node.Element.all);
|
|
1874 end Query_Element;
|
|
1875
|
|
1876 ----------
|
|
1877 -- Read --
|
|
1878 ----------
|
|
1879
|
|
1880 procedure Read
|
|
1881 (Stream : not null access Root_Stream_Type'Class;
|
|
1882 Container : out Tree)
|
|
1883 is
|
|
1884 procedure Read_Children (Subtree : Tree_Node_Access);
|
|
1885
|
|
1886 function Read_Subtree
|
|
1887 (Parent : Tree_Node_Access) return Tree_Node_Access;
|
|
1888
|
|
1889 Total_Count : Count_Type'Base;
|
|
1890 -- Value read from the stream that says how many elements follow
|
|
1891
|
|
1892 Read_Count : Count_Type'Base;
|
|
1893 -- Actual number of elements read from the stream
|
|
1894
|
|
1895 -------------------
|
|
1896 -- Read_Children --
|
|
1897 -------------------
|
|
1898
|
|
1899 procedure Read_Children (Subtree : Tree_Node_Access) is
|
|
1900 pragma Assert (Subtree /= null);
|
|
1901 pragma Assert (Subtree.Children.First = null);
|
|
1902 pragma Assert (Subtree.Children.Last = null);
|
|
1903
|
|
1904 Count : Count_Type'Base;
|
|
1905 -- Number of child subtrees
|
|
1906
|
|
1907 C : Children_Type;
|
|
1908
|
|
1909 begin
|
|
1910 Count_Type'Read (Stream, Count);
|
|
1911
|
|
1912 if Checks and then Count < 0 then
|
|
1913 raise Program_Error with "attempt to read from corrupt stream";
|
|
1914 end if;
|
|
1915
|
|
1916 if Count = 0 then
|
|
1917 return;
|
|
1918 end if;
|
|
1919
|
|
1920 C.First := Read_Subtree (Parent => Subtree);
|
|
1921 C.Last := C.First;
|
|
1922
|
|
1923 for J in Count_Type'(2) .. Count loop
|
|
1924 C.Last.Next := Read_Subtree (Parent => Subtree);
|
|
1925 C.Last.Next.Prev := C.Last;
|
|
1926 C.Last := C.Last.Next;
|
|
1927 end loop;
|
|
1928
|
|
1929 -- Now that the allocation and reads have completed successfully, it
|
|
1930 -- is safe to link the children to their parent.
|
|
1931
|
|
1932 Subtree.Children := C;
|
|
1933 end Read_Children;
|
|
1934
|
|
1935 ------------------
|
|
1936 -- Read_Subtree --
|
|
1937 ------------------
|
|
1938
|
|
1939 function Read_Subtree
|
|
1940 (Parent : Tree_Node_Access) return Tree_Node_Access
|
|
1941 is
|
|
1942 Element : constant Element_Access :=
|
|
1943 new Element_Type'(Element_Type'Input (Stream));
|
|
1944
|
|
1945 Subtree : constant Tree_Node_Access :=
|
|
1946 new Tree_Node_Type'
|
|
1947 (Parent => Parent, Element => Element, others => <>);
|
|
1948
|
|
1949 begin
|
|
1950 Read_Count := Read_Count + 1;
|
|
1951
|
|
1952 Read_Children (Subtree);
|
|
1953
|
|
1954 return Subtree;
|
|
1955 end Read_Subtree;
|
|
1956
|
|
1957 -- Start of processing for Read
|
|
1958
|
|
1959 begin
|
|
1960 Container.Clear; -- checks busy bit
|
|
1961
|
|
1962 Count_Type'Read (Stream, Total_Count);
|
|
1963
|
|
1964 if Checks and then Total_Count < 0 then
|
|
1965 raise Program_Error with "attempt to read from corrupt stream";
|
|
1966 end if;
|
|
1967
|
|
1968 if Total_Count = 0 then
|
|
1969 return;
|
|
1970 end if;
|
|
1971
|
|
1972 Read_Count := 0;
|
|
1973
|
|
1974 Read_Children (Root_Node (Container));
|
|
1975
|
|
1976 if Checks and then Read_Count /= Total_Count then
|
|
1977 raise Program_Error with "attempt to read from corrupt stream";
|
|
1978 end if;
|
|
1979
|
|
1980 Container.Count := Total_Count;
|
|
1981 end Read;
|
|
1982
|
|
1983 procedure Read
|
|
1984 (Stream : not null access Root_Stream_Type'Class;
|
|
1985 Position : out Cursor)
|
|
1986 is
|
|
1987 begin
|
|
1988 raise Program_Error with "attempt to read tree cursor from stream";
|
|
1989 end Read;
|
|
1990
|
|
1991 procedure Read
|
|
1992 (Stream : not null access Root_Stream_Type'Class;
|
|
1993 Item : out Reference_Type)
|
|
1994 is
|
|
1995 begin
|
|
1996 raise Program_Error with "attempt to stream reference";
|
|
1997 end Read;
|
|
1998
|
|
1999 procedure Read
|
|
2000 (Stream : not null access Root_Stream_Type'Class;
|
|
2001 Item : out Constant_Reference_Type)
|
|
2002 is
|
|
2003 begin
|
|
2004 raise Program_Error with "attempt to stream reference";
|
|
2005 end Read;
|
|
2006
|
|
2007 ---------------
|
|
2008 -- Reference --
|
|
2009 ---------------
|
|
2010
|
|
2011 function Reference
|
|
2012 (Container : aliased in out Tree;
|
|
2013 Position : Cursor) return Reference_Type
|
|
2014 is
|
|
2015 begin
|
|
2016 if Checks and then Position.Container = null then
|
|
2017 raise Constraint_Error with
|
|
2018 "Position cursor has no element";
|
|
2019 end if;
|
|
2020
|
|
2021 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
2022 then
|
|
2023 raise Program_Error with
|
|
2024 "Position cursor designates wrong container";
|
|
2025 end if;
|
|
2026
|
|
2027 if Checks and then Position.Node = Root_Node (Container) then
|
|
2028 raise Program_Error with "Position cursor designates root";
|
|
2029 end if;
|
|
2030
|
|
2031 if Checks and then Position.Node.Element = null then
|
|
2032 raise Program_Error with "Node has no element";
|
|
2033 end if;
|
|
2034
|
|
2035 -- Implement Vet for multiway tree???
|
|
2036 -- pragma Assert (Vet (Position),
|
|
2037 -- "Position cursor in Constant_Reference is bad");
|
|
2038
|
|
2039 declare
|
|
2040 TC : constant Tamper_Counts_Access :=
|
|
2041 Container.TC'Unrestricted_Access;
|
|
2042 begin
|
|
2043 return R : constant Reference_Type :=
|
|
2044 (Element => Position.Node.Element.all'Access,
|
|
2045 Control => (Controlled with TC))
|
|
2046 do
|
|
2047 Lock (TC.all);
|
|
2048 end return;
|
|
2049 end;
|
|
2050 end Reference;
|
|
2051
|
|
2052 --------------------
|
|
2053 -- Remove_Subtree --
|
|
2054 --------------------
|
|
2055
|
|
2056 procedure Remove_Subtree (Subtree : Tree_Node_Access) is
|
|
2057 C : Children_Type renames Subtree.Parent.Children;
|
|
2058
|
|
2059 begin
|
|
2060 -- This is a utility operation to remove a subtree node from its
|
|
2061 -- parent's list of children.
|
|
2062
|
|
2063 if C.First = Subtree then
|
|
2064 pragma Assert (Subtree.Prev = null);
|
|
2065
|
|
2066 if C.Last = Subtree then
|
|
2067 pragma Assert (Subtree.Next = null);
|
|
2068 C.First := null;
|
|
2069 C.Last := null;
|
|
2070
|
|
2071 else
|
|
2072 C.First := Subtree.Next;
|
|
2073 C.First.Prev := null;
|
|
2074 end if;
|
|
2075
|
|
2076 elsif C.Last = Subtree then
|
|
2077 pragma Assert (Subtree.Next = null);
|
|
2078 C.Last := Subtree.Prev;
|
|
2079 C.Last.Next := null;
|
|
2080
|
|
2081 else
|
|
2082 Subtree.Prev.Next := Subtree.Next;
|
|
2083 Subtree.Next.Prev := Subtree.Prev;
|
|
2084 end if;
|
|
2085 end Remove_Subtree;
|
|
2086
|
|
2087 ----------------------
|
|
2088 -- Replace_Element --
|
|
2089 ----------------------
|
|
2090
|
|
2091 procedure Replace_Element
|
|
2092 (Container : in out Tree;
|
|
2093 Position : Cursor;
|
|
2094 New_Item : Element_Type)
|
|
2095 is
|
|
2096 E, X : Element_Access;
|
|
2097
|
|
2098 begin
|
|
2099 if Checks and then Position = No_Element then
|
|
2100 raise Constraint_Error with "Position cursor has no element";
|
|
2101 end if;
|
|
2102
|
|
2103 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
2104 then
|
|
2105 raise Program_Error with "Position cursor not in container";
|
|
2106 end if;
|
|
2107
|
|
2108 if Checks and then Is_Root (Position) then
|
|
2109 raise Program_Error with "Position cursor designates root";
|
|
2110 end if;
|
|
2111
|
|
2112 TE_Check (Container.TC);
|
|
2113
|
|
2114 declare
|
|
2115 -- The element allocator may need an accessibility check in the case
|
|
2116 -- the actual type is class-wide or has access discriminants (see
|
|
2117 -- RM 4.8(10.1) and AI12-0035).
|
|
2118
|
|
2119 pragma Unsuppress (Accessibility_Check);
|
|
2120
|
|
2121 begin
|
|
2122 E := new Element_Type'(New_Item);
|
|
2123 end;
|
|
2124
|
|
2125 X := Position.Node.Element;
|
|
2126 Position.Node.Element := E;
|
|
2127
|
|
2128 Free_Element (X);
|
|
2129 end Replace_Element;
|
|
2130
|
|
2131 ------------------------------
|
|
2132 -- Reverse_Iterate_Children --
|
|
2133 ------------------------------
|
|
2134
|
|
2135 procedure Reverse_Iterate_Children
|
|
2136 (Parent : Cursor;
|
|
2137 Process : not null access procedure (Position : Cursor))
|
|
2138 is
|
|
2139 C : Tree_Node_Access;
|
|
2140 Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
|
|
2141 begin
|
|
2142 if Checks and then Parent = No_Element then
|
|
2143 raise Constraint_Error with "Parent cursor has no element";
|
|
2144 end if;
|
|
2145
|
|
2146 C := Parent.Node.Children.Last;
|
|
2147 while C /= null loop
|
|
2148 Process (Position => Cursor'(Parent.Container, Node => C));
|
|
2149 C := C.Prev;
|
|
2150 end loop;
|
|
2151 end Reverse_Iterate_Children;
|
|
2152
|
|
2153 ----------
|
|
2154 -- Root --
|
|
2155 ----------
|
|
2156
|
|
2157 function Root (Container : Tree) return Cursor is
|
|
2158 begin
|
|
2159 return (Container'Unrestricted_Access, Root_Node (Container));
|
|
2160 end Root;
|
|
2161
|
|
2162 ---------------
|
|
2163 -- Root_Node --
|
|
2164 ---------------
|
|
2165
|
|
2166 function Root_Node (Container : Tree) return Tree_Node_Access is
|
|
2167 begin
|
|
2168 return Container.Root'Unrestricted_Access;
|
|
2169 end Root_Node;
|
|
2170
|
|
2171 ---------------------
|
|
2172 -- Splice_Children --
|
|
2173 ---------------------
|
|
2174
|
|
2175 procedure Splice_Children
|
|
2176 (Target : in out Tree;
|
|
2177 Target_Parent : Cursor;
|
|
2178 Before : Cursor;
|
|
2179 Source : in out Tree;
|
|
2180 Source_Parent : Cursor)
|
|
2181 is
|
|
2182 Count : Count_Type;
|
|
2183
|
|
2184 begin
|
|
2185 if Checks and then Target_Parent = No_Element then
|
|
2186 raise Constraint_Error with "Target_Parent cursor has no element";
|
|
2187 end if;
|
|
2188
|
|
2189 if Checks and then Target_Parent.Container /= Target'Unrestricted_Access
|
|
2190 then
|
|
2191 raise Program_Error
|
|
2192 with "Target_Parent cursor not in Target container";
|
|
2193 end if;
|
|
2194
|
|
2195 if Before /= No_Element then
|
|
2196 if Checks and then Before.Container /= Target'Unrestricted_Access then
|
|
2197 raise Program_Error
|
|
2198 with "Before cursor not in Target container";
|
|
2199 end if;
|
|
2200
|
|
2201 if Checks and then Before.Node.Parent /= Target_Parent.Node then
|
|
2202 raise Constraint_Error
|
|
2203 with "Before cursor not child of Target_Parent";
|
|
2204 end if;
|
|
2205 end if;
|
|
2206
|
|
2207 if Checks and then Source_Parent = No_Element then
|
|
2208 raise Constraint_Error with "Source_Parent cursor has no element";
|
|
2209 end if;
|
|
2210
|
|
2211 if Checks and then Source_Parent.Container /= Source'Unrestricted_Access
|
|
2212 then
|
|
2213 raise Program_Error
|
|
2214 with "Source_Parent cursor not in Source container";
|
|
2215 end if;
|
|
2216
|
|
2217 if Target'Address = Source'Address then
|
|
2218 if Target_Parent = Source_Parent then
|
|
2219 return;
|
|
2220 end if;
|
|
2221
|
|
2222 TC_Check (Target.TC);
|
|
2223
|
|
2224 if Checks and then Is_Reachable (From => Target_Parent.Node,
|
|
2225 To => Source_Parent.Node)
|
|
2226 then
|
|
2227 raise Constraint_Error
|
|
2228 with "Source_Parent is ancestor of Target_Parent";
|
|
2229 end if;
|
|
2230
|
|
2231 Splice_Children
|
|
2232 (Target_Parent => Target_Parent.Node,
|
|
2233 Before => Before.Node,
|
|
2234 Source_Parent => Source_Parent.Node);
|
|
2235
|
|
2236 return;
|
|
2237 end if;
|
|
2238
|
|
2239 TC_Check (Target.TC);
|
|
2240 TC_Check (Source.TC);
|
|
2241
|
|
2242 -- We cache the count of the nodes we have allocated, so that operation
|
|
2243 -- Node_Count can execute in O(1) time. But that means we must count the
|
|
2244 -- nodes in the subtree we remove from Source and insert into Target, in
|
|
2245 -- order to keep the count accurate.
|
|
2246
|
|
2247 Count := Subtree_Node_Count (Source_Parent.Node);
|
|
2248 pragma Assert (Count >= 1);
|
|
2249
|
|
2250 Count := Count - 1; -- because Source_Parent node does not move
|
|
2251
|
|
2252 Splice_Children
|
|
2253 (Target_Parent => Target_Parent.Node,
|
|
2254 Before => Before.Node,
|
|
2255 Source_Parent => Source_Parent.Node);
|
|
2256
|
|
2257 Source.Count := Source.Count - Count;
|
|
2258 Target.Count := Target.Count + Count;
|
|
2259 end Splice_Children;
|
|
2260
|
|
2261 procedure Splice_Children
|
|
2262 (Container : in out Tree;
|
|
2263 Target_Parent : Cursor;
|
|
2264 Before : Cursor;
|
|
2265 Source_Parent : Cursor)
|
|
2266 is
|
|
2267 begin
|
|
2268 if Checks and then Target_Parent = No_Element then
|
|
2269 raise Constraint_Error with "Target_Parent cursor has no element";
|
|
2270 end if;
|
|
2271
|
|
2272 if Checks and then
|
|
2273 Target_Parent.Container /= Container'Unrestricted_Access
|
|
2274 then
|
|
2275 raise Program_Error
|
|
2276 with "Target_Parent cursor not in container";
|
|
2277 end if;
|
|
2278
|
|
2279 if Before /= No_Element then
|
|
2280 if Checks and then Before.Container /= Container'Unrestricted_Access
|
|
2281 then
|
|
2282 raise Program_Error
|
|
2283 with "Before cursor not in container";
|
|
2284 end if;
|
|
2285
|
|
2286 if Checks and then Before.Node.Parent /= Target_Parent.Node then
|
|
2287 raise Constraint_Error
|
|
2288 with "Before cursor not child of Target_Parent";
|
|
2289 end if;
|
|
2290 end if;
|
|
2291
|
|
2292 if Checks and then Source_Parent = No_Element then
|
|
2293 raise Constraint_Error with "Source_Parent cursor has no element";
|
|
2294 end if;
|
|
2295
|
|
2296 if Checks and then
|
|
2297 Source_Parent.Container /= Container'Unrestricted_Access
|
|
2298 then
|
|
2299 raise Program_Error
|
|
2300 with "Source_Parent cursor not in container";
|
|
2301 end if;
|
|
2302
|
|
2303 if Target_Parent = Source_Parent then
|
|
2304 return;
|
|
2305 end if;
|
|
2306
|
|
2307 TC_Check (Container.TC);
|
|
2308
|
|
2309 if Checks and then Is_Reachable (From => Target_Parent.Node,
|
|
2310 To => Source_Parent.Node)
|
|
2311 then
|
|
2312 raise Constraint_Error
|
|
2313 with "Source_Parent is ancestor of Target_Parent";
|
|
2314 end if;
|
|
2315
|
|
2316 Splice_Children
|
|
2317 (Target_Parent => Target_Parent.Node,
|
|
2318 Before => Before.Node,
|
|
2319 Source_Parent => Source_Parent.Node);
|
|
2320 end Splice_Children;
|
|
2321
|
|
2322 procedure Splice_Children
|
|
2323 (Target_Parent : Tree_Node_Access;
|
|
2324 Before : Tree_Node_Access;
|
|
2325 Source_Parent : Tree_Node_Access)
|
|
2326 is
|
|
2327 CC : constant Children_Type := Source_Parent.Children;
|
|
2328 C : Tree_Node_Access;
|
|
2329
|
|
2330 begin
|
|
2331 -- This is a utility operation to remove the children from Source parent
|
|
2332 -- and insert them into Target parent.
|
|
2333
|
|
2334 Source_Parent.Children := Children_Type'(others => null);
|
|
2335
|
|
2336 -- Fix up the Parent pointers of each child to designate its new Target
|
|
2337 -- parent.
|
|
2338
|
|
2339 C := CC.First;
|
|
2340 while C /= null loop
|
|
2341 C.Parent := Target_Parent;
|
|
2342 C := C.Next;
|
|
2343 end loop;
|
|
2344
|
|
2345 Insert_Subtree_List
|
|
2346 (First => CC.First,
|
|
2347 Last => CC.Last,
|
|
2348 Parent => Target_Parent,
|
|
2349 Before => Before);
|
|
2350 end Splice_Children;
|
|
2351
|
|
2352 --------------------
|
|
2353 -- Splice_Subtree --
|
|
2354 --------------------
|
|
2355
|
|
2356 procedure Splice_Subtree
|
|
2357 (Target : in out Tree;
|
|
2358 Parent : Cursor;
|
|
2359 Before : Cursor;
|
|
2360 Source : in out Tree;
|
|
2361 Position : in out Cursor)
|
|
2362 is
|
|
2363 Subtree_Count : Count_Type;
|
|
2364
|
|
2365 begin
|
|
2366 if Checks and then Parent = No_Element then
|
|
2367 raise Constraint_Error with "Parent cursor has no element";
|
|
2368 end if;
|
|
2369
|
|
2370 if Checks and then Parent.Container /= Target'Unrestricted_Access then
|
|
2371 raise Program_Error with "Parent cursor not in Target container";
|
|
2372 end if;
|
|
2373
|
|
2374 if Before /= No_Element then
|
|
2375 if Checks and then Before.Container /= Target'Unrestricted_Access then
|
|
2376 raise Program_Error with "Before cursor not in Target container";
|
|
2377 end if;
|
|
2378
|
|
2379 if Checks and then Before.Node.Parent /= Parent.Node then
|
|
2380 raise Constraint_Error with "Before cursor not child of Parent";
|
|
2381 end if;
|
|
2382 end if;
|
|
2383
|
|
2384 if Checks and then Position = No_Element then
|
|
2385 raise Constraint_Error with "Position cursor has no element";
|
|
2386 end if;
|
|
2387
|
|
2388 if Checks and then Position.Container /= Source'Unrestricted_Access then
|
|
2389 raise Program_Error with "Position cursor not in Source container";
|
|
2390 end if;
|
|
2391
|
|
2392 if Checks and then Is_Root (Position) then
|
|
2393 raise Program_Error with "Position cursor designates root";
|
|
2394 end if;
|
|
2395
|
|
2396 if Target'Address = Source'Address then
|
|
2397 if Position.Node.Parent = Parent.Node then
|
|
2398 if Position.Node = Before.Node then
|
|
2399 return;
|
|
2400 end if;
|
|
2401
|
|
2402 if Position.Node.Next = Before.Node then
|
|
2403 return;
|
|
2404 end if;
|
|
2405 end if;
|
|
2406
|
|
2407 TC_Check (Target.TC);
|
|
2408
|
|
2409 if Checks and then
|
|
2410 Is_Reachable (From => Parent.Node, To => Position.Node)
|
|
2411 then
|
|
2412 raise Constraint_Error with "Position is ancestor of Parent";
|
|
2413 end if;
|
|
2414
|
|
2415 Remove_Subtree (Position.Node);
|
|
2416
|
|
2417 Position.Node.Parent := Parent.Node;
|
|
2418 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
|
|
2419
|
|
2420 return;
|
|
2421 end if;
|
|
2422
|
|
2423 TC_Check (Target.TC);
|
|
2424 TC_Check (Source.TC);
|
|
2425
|
|
2426 -- This is an unfortunate feature of this API: we must count the nodes
|
|
2427 -- in the subtree that we remove from the source tree, which is an O(n)
|
|
2428 -- operation. It would have been better if the Tree container did not
|
|
2429 -- have a Node_Count selector; a user that wants the number of nodes in
|
|
2430 -- the tree could simply call Subtree_Node_Count, with the understanding
|
|
2431 -- that such an operation is O(n).
|
|
2432 --
|
|
2433 -- Of course, we could choose to implement the Node_Count selector as an
|
|
2434 -- O(n) operation, which would turn this splice operation into an O(1)
|
|
2435 -- operation. ???
|
|
2436
|
|
2437 Subtree_Count := Subtree_Node_Count (Position.Node);
|
|
2438 pragma Assert (Subtree_Count <= Source.Count);
|
|
2439
|
|
2440 Remove_Subtree (Position.Node);
|
|
2441 Source.Count := Source.Count - Subtree_Count;
|
|
2442
|
|
2443 Position.Node.Parent := Parent.Node;
|
|
2444 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
|
|
2445
|
|
2446 Target.Count := Target.Count + Subtree_Count;
|
|
2447
|
|
2448 Position.Container := Target'Unrestricted_Access;
|
|
2449 end Splice_Subtree;
|
|
2450
|
|
2451 procedure Splice_Subtree
|
|
2452 (Container : in out Tree;
|
|
2453 Parent : Cursor;
|
|
2454 Before : Cursor;
|
|
2455 Position : Cursor)
|
|
2456 is
|
|
2457 begin
|
|
2458 if Checks and then Parent = No_Element then
|
|
2459 raise Constraint_Error with "Parent cursor has no element";
|
|
2460 end if;
|
|
2461
|
|
2462 if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
2463 raise Program_Error with "Parent cursor not in container";
|
|
2464 end if;
|
|
2465
|
|
2466 if Before /= No_Element then
|
|
2467 if Checks and then Before.Container /= Container'Unrestricted_Access
|
|
2468 then
|
|
2469 raise Program_Error with "Before cursor not in container";
|
|
2470 end if;
|
|
2471
|
|
2472 if Checks and then Before.Node.Parent /= Parent.Node then
|
|
2473 raise Constraint_Error with "Before cursor not child of Parent";
|
|
2474 end if;
|
|
2475 end if;
|
|
2476
|
|
2477 if Checks and then Position = No_Element then
|
|
2478 raise Constraint_Error with "Position cursor has no element";
|
|
2479 end if;
|
|
2480
|
|
2481 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
2482 then
|
|
2483 raise Program_Error with "Position cursor not in container";
|
|
2484 end if;
|
|
2485
|
|
2486 if Checks and then Is_Root (Position) then
|
|
2487
|
|
2488 -- Should this be PE instead? Need ARG confirmation. ???
|
|
2489
|
|
2490 raise Constraint_Error with "Position cursor designates root";
|
|
2491 end if;
|
|
2492
|
|
2493 if Position.Node.Parent = Parent.Node then
|
|
2494 if Position.Node = Before.Node then
|
|
2495 return;
|
|
2496 end if;
|
|
2497
|
|
2498 if Position.Node.Next = Before.Node then
|
|
2499 return;
|
|
2500 end if;
|
|
2501 end if;
|
|
2502
|
|
2503 TC_Check (Container.TC);
|
|
2504
|
|
2505 if Checks and then
|
|
2506 Is_Reachable (From => Parent.Node, To => Position.Node)
|
|
2507 then
|
|
2508 raise Constraint_Error with "Position is ancestor of Parent";
|
|
2509 end if;
|
|
2510
|
|
2511 Remove_Subtree (Position.Node);
|
|
2512
|
|
2513 Position.Node.Parent := Parent.Node;
|
|
2514 Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node);
|
|
2515 end Splice_Subtree;
|
|
2516
|
|
2517 ------------------------
|
|
2518 -- Subtree_Node_Count --
|
|
2519 ------------------------
|
|
2520
|
|
2521 function Subtree_Node_Count (Position : Cursor) return Count_Type is
|
|
2522 begin
|
|
2523 if Position = No_Element then
|
|
2524 return 0;
|
|
2525 end if;
|
|
2526
|
|
2527 return Subtree_Node_Count (Position.Node);
|
|
2528 end Subtree_Node_Count;
|
|
2529
|
|
2530 function Subtree_Node_Count
|
|
2531 (Subtree : Tree_Node_Access) return Count_Type
|
|
2532 is
|
|
2533 Result : Count_Type;
|
|
2534 Node : Tree_Node_Access;
|
|
2535
|
|
2536 begin
|
|
2537 Result := 1;
|
|
2538 Node := Subtree.Children.First;
|
|
2539 while Node /= null loop
|
|
2540 Result := Result + Subtree_Node_Count (Node);
|
|
2541 Node := Node.Next;
|
|
2542 end loop;
|
|
2543
|
|
2544 return Result;
|
|
2545 end Subtree_Node_Count;
|
|
2546
|
|
2547 ----------
|
|
2548 -- Swap --
|
|
2549 ----------
|
|
2550
|
|
2551 procedure Swap
|
|
2552 (Container : in out Tree;
|
|
2553 I, J : Cursor)
|
|
2554 is
|
|
2555 begin
|
|
2556 if Checks and then I = No_Element then
|
|
2557 raise Constraint_Error with "I cursor has no element";
|
|
2558 end if;
|
|
2559
|
|
2560 if Checks and then I.Container /= Container'Unrestricted_Access then
|
|
2561 raise Program_Error with "I cursor not in container";
|
|
2562 end if;
|
|
2563
|
|
2564 if Checks and then Is_Root (I) then
|
|
2565 raise Program_Error with "I cursor designates root";
|
|
2566 end if;
|
|
2567
|
|
2568 if I = J then -- make this test sooner???
|
|
2569 return;
|
|
2570 end if;
|
|
2571
|
|
2572 if Checks and then J = No_Element then
|
|
2573 raise Constraint_Error with "J cursor has no element";
|
|
2574 end if;
|
|
2575
|
|
2576 if Checks and then J.Container /= Container'Unrestricted_Access then
|
|
2577 raise Program_Error with "J cursor not in container";
|
|
2578 end if;
|
|
2579
|
|
2580 if Checks and then Is_Root (J) then
|
|
2581 raise Program_Error with "J cursor designates root";
|
|
2582 end if;
|
|
2583
|
|
2584 TE_Check (Container.TC);
|
|
2585
|
|
2586 declare
|
|
2587 EI : constant Element_Access := I.Node.Element;
|
|
2588
|
|
2589 begin
|
|
2590 I.Node.Element := J.Node.Element;
|
|
2591 J.Node.Element := EI;
|
|
2592 end;
|
|
2593 end Swap;
|
|
2594
|
|
2595 --------------------
|
|
2596 -- Update_Element --
|
|
2597 --------------------
|
|
2598
|
|
2599 procedure Update_Element
|
|
2600 (Container : in out Tree;
|
|
2601 Position : Cursor;
|
|
2602 Process : not null access procedure (Element : in out Element_Type))
|
|
2603 is
|
|
2604 T : Tree renames Position.Container.all'Unrestricted_Access.all;
|
|
2605 Lock : With_Lock (T.TC'Unrestricted_Access);
|
|
2606 begin
|
|
2607 if Checks and then Position = No_Element then
|
|
2608 raise Constraint_Error with "Position cursor has no element";
|
|
2609 end if;
|
|
2610
|
|
2611 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
2612 then
|
|
2613 raise Program_Error with "Position cursor not in container";
|
|
2614 end if;
|
|
2615
|
|
2616 if Checks and then Is_Root (Position) then
|
|
2617 raise Program_Error with "Position cursor designates root";
|
|
2618 end if;
|
|
2619
|
|
2620 Process (Position.Node.Element.all);
|
|
2621 end Update_Element;
|
|
2622
|
|
2623 -----------
|
|
2624 -- Write --
|
|
2625 -----------
|
|
2626
|
|
2627 procedure Write
|
|
2628 (Stream : not null access Root_Stream_Type'Class;
|
|
2629 Container : Tree)
|
|
2630 is
|
|
2631 procedure Write_Children (Subtree : Tree_Node_Access);
|
|
2632 procedure Write_Subtree (Subtree : Tree_Node_Access);
|
|
2633
|
|
2634 --------------------
|
|
2635 -- Write_Children --
|
|
2636 --------------------
|
|
2637
|
|
2638 procedure Write_Children (Subtree : Tree_Node_Access) is
|
|
2639 CC : Children_Type renames Subtree.Children;
|
|
2640 C : Tree_Node_Access;
|
|
2641
|
|
2642 begin
|
|
2643 Count_Type'Write (Stream, Child_Count (CC));
|
|
2644
|
|
2645 C := CC.First;
|
|
2646 while C /= null loop
|
|
2647 Write_Subtree (C);
|
|
2648 C := C.Next;
|
|
2649 end loop;
|
|
2650 end Write_Children;
|
|
2651
|
|
2652 -------------------
|
|
2653 -- Write_Subtree --
|
|
2654 -------------------
|
|
2655
|
|
2656 procedure Write_Subtree (Subtree : Tree_Node_Access) is
|
|
2657 begin
|
|
2658 Element_Type'Output (Stream, Subtree.Element.all);
|
|
2659 Write_Children (Subtree);
|
|
2660 end Write_Subtree;
|
|
2661
|
|
2662 -- Start of processing for Write
|
|
2663
|
|
2664 begin
|
|
2665 Count_Type'Write (Stream, Container.Count);
|
|
2666
|
|
2667 if Container.Count = 0 then
|
|
2668 return;
|
|
2669 end if;
|
|
2670
|
|
2671 Write_Children (Root_Node (Container));
|
|
2672 end Write;
|
|
2673
|
|
2674 procedure Write
|
|
2675 (Stream : not null access Root_Stream_Type'Class;
|
|
2676 Position : Cursor)
|
|
2677 is
|
|
2678 begin
|
|
2679 raise Program_Error with "attempt to write tree cursor to stream";
|
|
2680 end Write;
|
|
2681
|
|
2682 procedure Write
|
|
2683 (Stream : not null access Root_Stream_Type'Class;
|
|
2684 Item : Reference_Type)
|
|
2685 is
|
|
2686 begin
|
|
2687 raise Program_Error with "attempt to stream reference";
|
|
2688 end Write;
|
|
2689
|
|
2690 procedure Write
|
|
2691 (Stream : not null access Root_Stream_Type'Class;
|
|
2692 Item : Constant_Reference_Type)
|
|
2693 is
|
|
2694 begin
|
|
2695 raise Program_Error with "attempt to stream reference";
|
|
2696 end Write;
|
|
2697
|
|
2698 end Ada.Containers.Indefinite_Multiway_Trees;
|