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