|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 2011-2019, 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.Finalization;
|
|
|
31 with System; use type System.Address;
|
|
|
32
|
|
|
33 package body Ada.Containers.Bounded_Multiway_Trees is
|
|
|
34
|
|
|
35 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
|
|
|
36 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
|
|
|
37 -- See comment in Ada.Containers.Helpers
|
|
|
38
|
|
|
39 use Finalization;
|
|
|
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 : Count_Type;
|
|
|
50 end record;
|
|
|
51
|
|
|
52 overriding procedure Finalize (Object : in out Root_Iterator);
|
|
|
53
|
|
|
54 -----------------------
|
|
|
55 -- Subtree_Iterator --
|
|
|
56 -----------------------
|
|
|
57
|
|
|
58 type Subtree_Iterator is new Root_Iterator with null record;
|
|
|
59
|
|
|
60 overriding function First (Object : Subtree_Iterator) return Cursor;
|
|
|
61
|
|
|
62 overriding function Next
|
|
|
63 (Object : Subtree_Iterator;
|
|
|
64 Position : Cursor) return Cursor;
|
|
|
65
|
|
|
66 ---------------------
|
|
|
67 -- Child_Iterator --
|
|
|
68 ---------------------
|
|
|
69
|
|
|
70 type Child_Iterator is new Root_Iterator and
|
|
|
71 Tree_Iterator_Interfaces.Reversible_Iterator with null record;
|
|
|
72
|
|
|
73 overriding function First (Object : Child_Iterator) return Cursor;
|
|
|
74
|
|
|
75 overriding function Next
|
|
|
76 (Object : Child_Iterator;
|
|
|
77 Position : Cursor) return Cursor;
|
|
|
78
|
|
|
79 overriding function Last (Object : Child_Iterator) return Cursor;
|
|
|
80
|
|
|
81 overriding function Previous
|
|
|
82 (Object : Child_Iterator;
|
|
|
83 Position : Cursor) return Cursor;
|
|
|
84
|
|
|
85 -----------------------
|
|
|
86 -- Local Subprograms --
|
|
|
87 -----------------------
|
|
|
88
|
|
|
89 procedure Initialize_Node (Container : in out Tree; Index : Count_Type);
|
|
|
90 procedure Initialize_Root (Container : in out Tree);
|
|
|
91
|
|
|
92 procedure Allocate_Node
|
|
|
93 (Container : in out Tree;
|
|
|
94 Initialize_Element : not null access procedure (Index : Count_Type);
|
|
|
95 New_Node : out Count_Type);
|
|
|
96
|
|
|
97 procedure Allocate_Node
|
|
|
98 (Container : in out Tree;
|
|
|
99 New_Item : Element_Type;
|
|
|
100 New_Node : out Count_Type);
|
|
|
101
|
|
|
102 procedure Allocate_Node
|
|
|
103 (Container : in out Tree;
|
|
|
104 Stream : not null access Root_Stream_Type'Class;
|
|
|
105 New_Node : out Count_Type);
|
|
|
106
|
|
|
107 procedure Deallocate_Node
|
|
|
108 (Container : in out Tree;
|
|
|
109 X : Count_Type);
|
|
|
110
|
|
|
111 procedure Deallocate_Children
|
|
|
112 (Container : in out Tree;
|
|
|
113 Subtree : Count_Type;
|
|
|
114 Count : in out Count_Type);
|
|
|
115
|
|
|
116 procedure Deallocate_Subtree
|
|
|
117 (Container : in out Tree;
|
|
|
118 Subtree : Count_Type;
|
|
|
119 Count : in out Count_Type);
|
|
|
120
|
|
|
121 function Equal_Children
|
|
|
122 (Left_Tree : Tree;
|
|
|
123 Left_Subtree : Count_Type;
|
|
|
124 Right_Tree : Tree;
|
|
|
125 Right_Subtree : Count_Type) return Boolean;
|
|
|
126
|
|
|
127 function Equal_Subtree
|
|
|
128 (Left_Tree : Tree;
|
|
|
129 Left_Subtree : Count_Type;
|
|
|
130 Right_Tree : Tree;
|
|
|
131 Right_Subtree : Count_Type) return Boolean;
|
|
|
132
|
|
|
133 procedure Iterate_Children
|
|
|
134 (Container : Tree;
|
|
|
135 Subtree : Count_Type;
|
|
|
136 Process : not null access procedure (Position : Cursor));
|
|
|
137
|
|
|
138 procedure Iterate_Subtree
|
|
|
139 (Container : Tree;
|
|
|
140 Subtree : Count_Type;
|
|
|
141 Process : not null access procedure (Position : Cursor));
|
|
|
142
|
|
|
143 procedure Copy_Children
|
|
|
144 (Source : Tree;
|
|
|
145 Source_Parent : Count_Type;
|
|
|
146 Target : in out Tree;
|
|
|
147 Target_Parent : Count_Type;
|
|
|
148 Count : in out Count_Type);
|
|
|
149
|
|
|
150 procedure Copy_Subtree
|
|
|
151 (Source : Tree;
|
|
|
152 Source_Subtree : Count_Type;
|
|
|
153 Target : in out Tree;
|
|
|
154 Target_Parent : Count_Type;
|
|
|
155 Target_Subtree : out Count_Type;
|
|
|
156 Count : in out Count_Type);
|
|
|
157
|
|
|
158 function Find_In_Children
|
|
|
159 (Container : Tree;
|
|
|
160 Subtree : Count_Type;
|
|
|
161 Item : Element_Type) return Count_Type;
|
|
|
162
|
|
|
163 function Find_In_Subtree
|
|
|
164 (Container : Tree;
|
|
|
165 Subtree : Count_Type;
|
|
|
166 Item : Element_Type) return Count_Type;
|
|
|
167
|
|
|
168 function Child_Count
|
|
|
169 (Container : Tree;
|
|
|
170 Parent : Count_Type) return Count_Type;
|
|
|
171
|
|
|
172 function Subtree_Node_Count
|
|
|
173 (Container : Tree;
|
|
|
174 Subtree : Count_Type) return Count_Type;
|
|
|
175
|
|
|
176 function Is_Reachable
|
|
|
177 (Container : Tree;
|
|
|
178 From, To : Count_Type) return Boolean;
|
|
|
179
|
|
|
180 function Root_Node (Container : Tree) return Count_Type;
|
|
|
181
|
|
|
182 procedure Remove_Subtree
|
|
|
183 (Container : in out Tree;
|
|
|
184 Subtree : Count_Type);
|
|
|
185
|
|
|
186 procedure Insert_Subtree_Node
|
|
|
187 (Container : in out Tree;
|
|
|
188 Subtree : Count_Type'Base;
|
|
|
189 Parent : Count_Type;
|
|
|
190 Before : Count_Type'Base);
|
|
|
191
|
|
|
192 procedure Insert_Subtree_List
|
|
|
193 (Container : in out Tree;
|
|
|
194 First : Count_Type'Base;
|
|
|
195 Last : Count_Type'Base;
|
|
|
196 Parent : Count_Type;
|
|
|
197 Before : Count_Type'Base);
|
|
|
198
|
|
|
199 procedure Splice_Children
|
|
|
200 (Container : in out Tree;
|
|
|
201 Target_Parent : Count_Type;
|
|
|
202 Before : Count_Type'Base;
|
|
|
203 Source_Parent : Count_Type);
|
|
|
204
|
|
|
205 procedure Splice_Children
|
|
|
206 (Target : in out Tree;
|
|
|
207 Target_Parent : Count_Type;
|
|
|
208 Before : Count_Type'Base;
|
|
|
209 Source : in out Tree;
|
|
|
210 Source_Parent : Count_Type);
|
|
|
211
|
|
|
212 procedure Splice_Subtree
|
|
|
213 (Target : in out Tree;
|
|
|
214 Parent : Count_Type;
|
|
|
215 Before : Count_Type'Base;
|
|
|
216 Source : in out Tree;
|
|
|
217 Position : in out Count_Type); -- source on input, target on output
|
|
|
218
|
|
|
219 ---------
|
|
|
220 -- "=" --
|
|
|
221 ---------
|
|
|
222
|
|
|
223 function "=" (Left, Right : Tree) return Boolean is
|
|
|
224 begin
|
|
|
225 if Left.Count /= Right.Count then
|
|
|
226 return False;
|
|
|
227 end if;
|
|
|
228
|
|
|
229 if Left.Count = 0 then
|
|
|
230 return True;
|
|
|
231 end if;
|
|
|
232
|
|
|
233 return Equal_Children
|
|
|
234 (Left_Tree => Left,
|
|
|
235 Left_Subtree => Root_Node (Left),
|
|
|
236 Right_Tree => Right,
|
|
|
237 Right_Subtree => Root_Node (Right));
|
|
|
238 end "=";
|
|
|
239
|
|
|
240 -------------------
|
|
|
241 -- Allocate_Node --
|
|
|
242 -------------------
|
|
|
243
|
|
|
244 procedure Allocate_Node
|
|
|
245 (Container : in out Tree;
|
|
|
246 Initialize_Element : not null access procedure (Index : Count_Type);
|
|
|
247 New_Node : out Count_Type)
|
|
|
248 is
|
|
|
249 begin
|
|
|
250 if Container.Free >= 0 then
|
|
|
251 New_Node := Container.Free;
|
|
|
252 pragma Assert (New_Node in Container.Elements'Range);
|
|
|
253
|
|
|
254 -- We always perform the assignment first, before we change container
|
|
|
255 -- state, in order to defend against exceptions duration assignment.
|
|
|
256
|
|
|
257 Initialize_Element (New_Node);
|
|
|
258
|
|
|
259 Container.Free := Container.Nodes (New_Node).Next;
|
|
|
260
|
|
|
261 else
|
|
|
262 -- A negative free store value means that the links of the nodes in
|
|
|
263 -- the free store have not been initialized. In this case, the nodes
|
|
|
264 -- are physically contiguous in the array, starting at the index that
|
|
|
265 -- is the absolute value of the Container.Free, and continuing until
|
|
|
266 -- the end of the array (Nodes'Last).
|
|
|
267
|
|
|
268 New_Node := abs Container.Free;
|
|
|
269 pragma Assert (New_Node in Container.Elements'Range);
|
|
|
270
|
|
|
271 -- As above, we perform this assignment first, before modifying any
|
|
|
272 -- container state.
|
|
|
273
|
|
|
274 Initialize_Element (New_Node);
|
|
|
275
|
|
|
276 Container.Free := Container.Free - 1;
|
|
|
277
|
|
|
278 if abs Container.Free > Container.Capacity then
|
|
|
279 Container.Free := 0;
|
|
|
280 end if;
|
|
|
281 end if;
|
|
|
282
|
|
|
283 Initialize_Node (Container, New_Node);
|
|
|
284 end Allocate_Node;
|
|
|
285
|
|
|
286 procedure Allocate_Node
|
|
|
287 (Container : in out Tree;
|
|
|
288 New_Item : Element_Type;
|
|
|
289 New_Node : out Count_Type)
|
|
|
290 is
|
|
|
291 procedure Initialize_Element (Index : Count_Type);
|
|
|
292
|
|
|
293 procedure Initialize_Element (Index : Count_Type) is
|
|
|
294 begin
|
|
|
295 Container.Elements (Index) := New_Item;
|
|
|
296 end Initialize_Element;
|
|
|
297
|
|
|
298 begin
|
|
|
299 Allocate_Node (Container, Initialize_Element'Access, New_Node);
|
|
|
300 end Allocate_Node;
|
|
|
301
|
|
|
302 procedure Allocate_Node
|
|
|
303 (Container : in out Tree;
|
|
|
304 Stream : not null access Root_Stream_Type'Class;
|
|
|
305 New_Node : out Count_Type)
|
|
|
306 is
|
|
|
307 procedure Initialize_Element (Index : Count_Type);
|
|
|
308
|
|
|
309 procedure Initialize_Element (Index : Count_Type) is
|
|
|
310 begin
|
|
|
311 Element_Type'Read (Stream, Container.Elements (Index));
|
|
|
312 end Initialize_Element;
|
|
|
313
|
|
|
314 begin
|
|
|
315 Allocate_Node (Container, Initialize_Element'Access, New_Node);
|
|
|
316 end Allocate_Node;
|
|
|
317
|
|
|
318 -------------------
|
|
|
319 -- Ancestor_Find --
|
|
|
320 -------------------
|
|
|
321
|
|
|
322 function Ancestor_Find
|
|
|
323 (Position : Cursor;
|
|
|
324 Item : Element_Type) return Cursor
|
|
|
325 is
|
|
|
326 R, N : Count_Type;
|
|
|
327
|
|
|
328 begin
|
|
|
329 if Checks and then Position = No_Element then
|
|
|
330 raise Constraint_Error with "Position cursor has no element";
|
|
|
331 end if;
|
|
|
332
|
|
|
333 -- AI-0136 says to raise PE if Position equals the root node. This does
|
|
|
334 -- not seem correct, as this value is just the limiting condition of the
|
|
|
335 -- search. For now we omit this check, pending a ruling from the ARG.
|
|
|
336 -- ???
|
|
|
337 --
|
|
|
338 -- if Checks and then Is_Root (Position) then
|
|
|
339 -- raise Program_Error with "Position cursor designates root";
|
|
|
340 -- end if;
|
|
|
341
|
|
|
342 R := Root_Node (Position.Container.all);
|
|
|
343 N := Position.Node;
|
|
|
344 while N /= R loop
|
|
|
345 if Position.Container.Elements (N) = Item then
|
|
|
346 return Cursor'(Position.Container, N);
|
|
|
347 end if;
|
|
|
348
|
|
|
349 N := Position.Container.Nodes (N).Parent;
|
|
|
350 end loop;
|
|
|
351
|
|
|
352 return No_Element;
|
|
|
353 end Ancestor_Find;
|
|
|
354
|
|
|
355 ------------------
|
|
|
356 -- Append_Child --
|
|
|
357 ------------------
|
|
|
358
|
|
|
359 procedure Append_Child
|
|
|
360 (Container : in out Tree;
|
|
|
361 Parent : Cursor;
|
|
|
362 New_Item : Element_Type;
|
|
|
363 Count : Count_Type := 1)
|
|
|
364 is
|
|
|
365 Nodes : Tree_Node_Array renames Container.Nodes;
|
|
|
366 First, Last : Count_Type;
|
|
|
367
|
|
|
368 begin
|
|
|
369 if Checks and then Parent = No_Element then
|
|
|
370 raise Constraint_Error with "Parent cursor has no element";
|
|
|
371 end if;
|
|
|
372
|
|
|
373 if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
|
374 raise Program_Error with "Parent cursor not in container";
|
|
|
375 end if;
|
|
|
376
|
|
|
377 if Count = 0 then
|
|
|
378 return;
|
|
|
379 end if;
|
|
|
380
|
|
|
381 if Checks and then Container.Count > Container.Capacity - Count then
|
|
|
382 raise Capacity_Error
|
|
|
383 with "requested count exceeds available storage";
|
|
|
384 end if;
|
|
|
385
|
|
|
386 TC_Check (Container.TC);
|
|
|
387
|
|
|
388 if Container.Count = 0 then
|
|
|
389 Initialize_Root (Container);
|
|
|
390 end if;
|
|
|
391
|
|
|
392 Allocate_Node (Container, New_Item, First);
|
|
|
393 Nodes (First).Parent := Parent.Node;
|
|
|
394
|
|
|
395 Last := First;
|
|
|
396 for J in Count_Type'(2) .. Count loop
|
|
|
397 Allocate_Node (Container, New_Item, Nodes (Last).Next);
|
|
|
398 Nodes (Nodes (Last).Next).Parent := Parent.Node;
|
|
|
399 Nodes (Nodes (Last).Next).Prev := Last;
|
|
|
400
|
|
|
401 Last := Nodes (Last).Next;
|
|
|
402 end loop;
|
|
|
403
|
|
|
404 Insert_Subtree_List
|
|
|
405 (Container => Container,
|
|
|
406 First => First,
|
|
|
407 Last => Last,
|
|
|
408 Parent => Parent.Node,
|
|
|
409 Before => No_Node); -- means "insert at end of list"
|
|
|
410
|
|
|
411 Container.Count := Container.Count + Count;
|
|
|
412 end Append_Child;
|
|
|
413
|
|
|
414 ------------
|
|
|
415 -- Assign --
|
|
|
416 ------------
|
|
|
417
|
|
|
418 procedure Assign (Target : in out Tree; Source : Tree) is
|
|
|
419 Target_Count : Count_Type;
|
|
|
420
|
|
|
421 begin
|
|
|
422 if Target'Address = Source'Address then
|
|
|
423 return;
|
|
|
424 end if;
|
|
|
425
|
|
|
426 if Checks and then Target.Capacity < Source.Count then
|
|
|
427 raise Capacity_Error -- ???
|
|
|
428 with "Target capacity is less than Source count";
|
|
|
429 end if;
|
|
|
430
|
|
|
431 Target.Clear; -- Checks busy bit
|
|
|
432
|
|
|
433 if Source.Count = 0 then
|
|
|
434 return;
|
|
|
435 end if;
|
|
|
436
|
|
|
437 Initialize_Root (Target);
|
|
|
438
|
|
|
439 -- Copy_Children returns the number of nodes that it allocates, but it
|
|
|
440 -- does this by incrementing the count value passed in, so we must
|
|
|
441 -- initialize the count before calling Copy_Children.
|
|
|
442
|
|
|
443 Target_Count := 0;
|
|
|
444
|
|
|
445 Copy_Children
|
|
|
446 (Source => Source,
|
|
|
447 Source_Parent => Root_Node (Source),
|
|
|
448 Target => Target,
|
|
|
449 Target_Parent => Root_Node (Target),
|
|
|
450 Count => Target_Count);
|
|
|
451
|
|
|
452 pragma Assert (Target_Count = Source.Count);
|
|
|
453 Target.Count := Source.Count;
|
|
|
454 end Assign;
|
|
|
455
|
|
|
456 -----------------
|
|
|
457 -- Child_Count --
|
|
|
458 -----------------
|
|
|
459
|
|
|
460 function Child_Count (Parent : Cursor) return Count_Type is
|
|
|
461 begin
|
|
|
462 if Parent = No_Element then
|
|
|
463 return 0;
|
|
|
464
|
|
|
465 elsif Parent.Container.Count = 0 then
|
|
|
466 pragma Assert (Is_Root (Parent));
|
|
|
467 return 0;
|
|
|
468
|
|
|
469 else
|
|
|
470 return Child_Count (Parent.Container.all, Parent.Node);
|
|
|
471 end if;
|
|
|
472 end Child_Count;
|
|
|
473
|
|
|
474 function Child_Count
|
|
|
475 (Container : Tree;
|
|
|
476 Parent : Count_Type) return Count_Type
|
|
|
477 is
|
|
|
478 NN : Tree_Node_Array renames Container.Nodes;
|
|
|
479 CC : Children_Type renames NN (Parent).Children;
|
|
|
480
|
|
|
481 Result : Count_Type;
|
|
|
482 Node : Count_Type'Base;
|
|
|
483
|
|
|
484 begin
|
|
|
485 Result := 0;
|
|
|
486 Node := CC.First;
|
|
|
487 while Node > 0 loop
|
|
|
488 Result := Result + 1;
|
|
|
489 Node := NN (Node).Next;
|
|
|
490 end loop;
|
|
|
491
|
|
|
492 return Result;
|
|
|
493 end Child_Count;
|
|
|
494
|
|
|
495 -----------------
|
|
|
496 -- Child_Depth --
|
|
|
497 -----------------
|
|
|
498
|
|
|
499 function Child_Depth (Parent, Child : Cursor) return Count_Type is
|
|
|
500 Result : Count_Type;
|
|
|
501 N : Count_Type'Base;
|
|
|
502
|
|
|
503 begin
|
|
|
504 if Checks and then Parent = No_Element then
|
|
|
505 raise Constraint_Error with "Parent cursor has no element";
|
|
|
506 end if;
|
|
|
507
|
|
|
508 if Checks and then Child = No_Element then
|
|
|
509 raise Constraint_Error with "Child cursor has no element";
|
|
|
510 end if;
|
|
|
511
|
|
|
512 if Checks and then Parent.Container /= Child.Container then
|
|
|
513 raise Program_Error with "Parent and Child in different containers";
|
|
|
514 end if;
|
|
|
515
|
|
|
516 if Parent.Container.Count = 0 then
|
|
|
517 pragma Assert (Is_Root (Parent));
|
|
|
518 pragma Assert (Child = Parent);
|
|
|
519 return 0;
|
|
|
520 end if;
|
|
|
521
|
|
|
522 Result := 0;
|
|
|
523 N := Child.Node;
|
|
|
524 while N /= Parent.Node loop
|
|
|
525 Result := Result + 1;
|
|
|
526 N := Parent.Container.Nodes (N).Parent;
|
|
|
527
|
|
|
528 if Checks and then N < 0 then
|
|
|
529 raise Program_Error with "Parent is not ancestor of Child";
|
|
|
530 end if;
|
|
|
531 end loop;
|
|
|
532
|
|
|
533 return Result;
|
|
|
534 end Child_Depth;
|
|
|
535
|
|
|
536 -----------
|
|
|
537 -- Clear --
|
|
|
538 -----------
|
|
|
539
|
|
|
540 procedure Clear (Container : in out Tree) is
|
|
|
541 Container_Count : constant Count_Type := Container.Count;
|
|
|
542 Count : Count_Type;
|
|
|
543
|
|
|
544 begin
|
|
|
545 TC_Check (Container.TC);
|
|
|
546
|
|
|
547 if Container_Count = 0 then
|
|
|
548 return;
|
|
|
549 end if;
|
|
|
550
|
|
|
551 Container.Count := 0;
|
|
|
552
|
|
|
553 -- Deallocate_Children returns the number of nodes that it deallocates,
|
|
|
554 -- but it does this by incrementing the count value that is passed in,
|
|
|
555 -- so we must first initialize the count return value before calling it.
|
|
|
556
|
|
|
557 Count := 0;
|
|
|
558
|
|
|
559 Deallocate_Children
|
|
|
560 (Container => Container,
|
|
|
561 Subtree => Root_Node (Container),
|
|
|
562 Count => Count);
|
|
|
563
|
|
|
564 pragma Assert (Count = Container_Count);
|
|
|
565 end Clear;
|
|
|
566
|
|
|
567 ------------------------
|
|
|
568 -- Constant_Reference --
|
|
|
569 ------------------------
|
|
|
570
|
|
|
571 function Constant_Reference
|
|
|
572 (Container : aliased Tree;
|
|
|
573 Position : Cursor) return Constant_Reference_Type
|
|
|
574 is
|
|
|
575 begin
|
|
|
576 if Checks and then Position.Container = null then
|
|
|
577 raise Constraint_Error with
|
|
|
578 "Position cursor has no element";
|
|
|
579 end if;
|
|
|
580
|
|
|
581 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
582 then
|
|
|
583 raise Program_Error with
|
|
|
584 "Position cursor designates wrong container";
|
|
|
585 end if;
|
|
|
586
|
|
|
587 if Checks and then Position.Node = Root_Node (Container) then
|
|
|
588 raise Program_Error with "Position cursor designates root";
|
|
|
589 end if;
|
|
|
590
|
|
|
591 -- Implement Vet for multiway tree???
|
|
|
592 -- pragma Assert (Vet (Position),
|
|
|
593 -- "Position cursor in Constant_Reference is bad");
|
|
|
594
|
|
|
595 declare
|
|
|
596 TC : constant Tamper_Counts_Access :=
|
|
|
597 Container.TC'Unrestricted_Access;
|
|
|
598 begin
|
|
|
599 return R : constant Constant_Reference_Type :=
|
|
|
600 (Element => Container.Elements (Position.Node)'Access,
|
|
|
601 Control => (Controlled with TC))
|
|
|
602 do
|
|
145
|
603 Busy (TC.all);
|
|
111
|
604 end return;
|
|
|
605 end;
|
|
|
606 end Constant_Reference;
|
|
|
607
|
|
|
608 --------------
|
|
|
609 -- Contains --
|
|
|
610 --------------
|
|
|
611
|
|
|
612 function Contains
|
|
|
613 (Container : Tree;
|
|
|
614 Item : Element_Type) return Boolean
|
|
|
615 is
|
|
|
616 begin
|
|
|
617 return Find (Container, Item) /= No_Element;
|
|
|
618 end Contains;
|
|
|
619
|
|
|
620 ----------
|
|
|
621 -- Copy --
|
|
|
622 ----------
|
|
|
623
|
|
|
624 function Copy
|
|
|
625 (Source : Tree;
|
|
|
626 Capacity : Count_Type := 0) return Tree
|
|
|
627 is
|
|
145
|
628 C : constant Count_Type :=
|
|
|
629 (if Capacity = 0 then Source.Count
|
|
|
630 else Capacity);
|
|
111
|
631 begin
|
|
145
|
632 if Checks and then C < Source.Count then
|
|
|
633 raise Capacity_Error with "Capacity too small";
|
|
111
|
634 end if;
|
|
|
635
|
|
|
636 return Target : Tree (Capacity => C) do
|
|
|
637 Initialize_Root (Target);
|
|
|
638
|
|
|
639 if Source.Count = 0 then
|
|
|
640 return;
|
|
|
641 end if;
|
|
|
642
|
|
|
643 Copy_Children
|
|
|
644 (Source => Source,
|
|
|
645 Source_Parent => Root_Node (Source),
|
|
|
646 Target => Target,
|
|
|
647 Target_Parent => Root_Node (Target),
|
|
|
648 Count => Target.Count);
|
|
|
649
|
|
|
650 pragma Assert (Target.Count = Source.Count);
|
|
|
651 end return;
|
|
|
652 end Copy;
|
|
|
653
|
|
|
654 -------------------
|
|
|
655 -- Copy_Children --
|
|
|
656 -------------------
|
|
|
657
|
|
|
658 procedure Copy_Children
|
|
|
659 (Source : Tree;
|
|
|
660 Source_Parent : Count_Type;
|
|
|
661 Target : in out Tree;
|
|
|
662 Target_Parent : Count_Type;
|
|
|
663 Count : in out Count_Type)
|
|
|
664 is
|
|
|
665 S_Nodes : Tree_Node_Array renames Source.Nodes;
|
|
|
666 S_Node : Tree_Node_Type renames S_Nodes (Source_Parent);
|
|
|
667
|
|
|
668 T_Nodes : Tree_Node_Array renames Target.Nodes;
|
|
|
669 T_Node : Tree_Node_Type renames T_Nodes (Target_Parent);
|
|
|
670
|
|
|
671 pragma Assert (T_Node.Children.First <= 0);
|
|
|
672 pragma Assert (T_Node.Children.Last <= 0);
|
|
|
673
|
|
|
674 T_CC : Children_Type;
|
|
|
675 C : Count_Type'Base;
|
|
|
676
|
|
|
677 begin
|
|
|
678 -- We special-case the first allocation, in order to establish the
|
|
|
679 -- representation invariants for type Children_Type.
|
|
|
680
|
|
|
681 C := S_Node.Children.First;
|
|
|
682
|
|
|
683 if C <= 0 then -- source parent has no children
|
|
|
684 return;
|
|
|
685 end if;
|
|
|
686
|
|
|
687 Copy_Subtree
|
|
|
688 (Source => Source,
|
|
|
689 Source_Subtree => C,
|
|
|
690 Target => Target,
|
|
|
691 Target_Parent => Target_Parent,
|
|
|
692 Target_Subtree => T_CC.First,
|
|
|
693 Count => Count);
|
|
|
694
|
|
|
695 T_CC.Last := T_CC.First;
|
|
|
696
|
|
|
697 -- The representation invariants for the Children_Type list have been
|
|
|
698 -- established, so we can now copy the remaining children of Source.
|
|
|
699
|
|
|
700 C := S_Nodes (C).Next;
|
|
|
701 while C > 0 loop
|
|
|
702 Copy_Subtree
|
|
|
703 (Source => Source,
|
|
|
704 Source_Subtree => C,
|
|
|
705 Target => Target,
|
|
|
706 Target_Parent => Target_Parent,
|
|
|
707 Target_Subtree => T_Nodes (T_CC.Last).Next,
|
|
|
708 Count => Count);
|
|
|
709
|
|
|
710 T_Nodes (T_Nodes (T_CC.Last).Next).Prev := T_CC.Last;
|
|
|
711 T_CC.Last := T_Nodes (T_CC.Last).Next;
|
|
|
712
|
|
|
713 C := S_Nodes (C).Next;
|
|
|
714 end loop;
|
|
|
715
|
|
|
716 -- We add the newly-allocated children to their parent list only after
|
|
|
717 -- the allocation has succeeded, in order to preserve invariants of the
|
|
|
718 -- parent.
|
|
|
719
|
|
|
720 T_Node.Children := T_CC;
|
|
|
721 end Copy_Children;
|
|
|
722
|
|
|
723 ------------------
|
|
|
724 -- Copy_Subtree --
|
|
|
725 ------------------
|
|
|
726
|
|
|
727 procedure Copy_Subtree
|
|
|
728 (Target : in out Tree;
|
|
|
729 Parent : Cursor;
|
|
|
730 Before : Cursor;
|
|
|
731 Source : Cursor)
|
|
|
732 is
|
|
|
733 Target_Subtree : Count_Type;
|
|
|
734 Target_Count : Count_Type;
|
|
|
735
|
|
|
736 begin
|
|
|
737 if Checks and then Parent = No_Element then
|
|
|
738 raise Constraint_Error with "Parent cursor has no element";
|
|
|
739 end if;
|
|
|
740
|
|
|
741 if Checks and then Parent.Container /= Target'Unrestricted_Access then
|
|
|
742 raise Program_Error with "Parent cursor not in container";
|
|
|
743 end if;
|
|
|
744
|
|
|
745 if Before /= No_Element then
|
|
|
746 if Checks and then Before.Container /= Target'Unrestricted_Access then
|
|
|
747 raise Program_Error with "Before cursor not in container";
|
|
|
748 end if;
|
|
|
749
|
|
|
750 if Checks and then
|
|
|
751 Before.Container.Nodes (Before.Node).Parent /= Parent.Node
|
|
|
752 then
|
|
|
753 raise Constraint_Error with "Before cursor not child of Parent";
|
|
|
754 end if;
|
|
|
755 end if;
|
|
|
756
|
|
|
757 if Source = No_Element then
|
|
|
758 return;
|
|
|
759 end if;
|
|
|
760
|
|
|
761 if Checks and then Is_Root (Source) then
|
|
|
762 raise Constraint_Error with "Source cursor designates root";
|
|
|
763 end if;
|
|
|
764
|
|
|
765 if Target.Count = 0 then
|
|
|
766 Initialize_Root (Target);
|
|
|
767 end if;
|
|
|
768
|
|
|
769 -- Copy_Subtree returns a count of the number of nodes that it
|
|
|
770 -- allocates, but it works by incrementing the value that is passed
|
|
|
771 -- in. We must therefore initialize the count value before calling
|
|
|
772 -- Copy_Subtree.
|
|
|
773
|
|
|
774 Target_Count := 0;
|
|
|
775
|
|
|
776 Copy_Subtree
|
|
|
777 (Source => Source.Container.all,
|
|
|
778 Source_Subtree => Source.Node,
|
|
|
779 Target => Target,
|
|
|
780 Target_Parent => Parent.Node,
|
|
|
781 Target_Subtree => Target_Subtree,
|
|
|
782 Count => Target_Count);
|
|
|
783
|
|
|
784 Insert_Subtree_Node
|
|
|
785 (Container => Target,
|
|
|
786 Subtree => Target_Subtree,
|
|
|
787 Parent => Parent.Node,
|
|
|
788 Before => Before.Node);
|
|
|
789
|
|
|
790 Target.Count := Target.Count + Target_Count;
|
|
|
791 end Copy_Subtree;
|
|
|
792
|
|
|
793 procedure Copy_Subtree
|
|
|
794 (Source : Tree;
|
|
|
795 Source_Subtree : Count_Type;
|
|
|
796 Target : in out Tree;
|
|
|
797 Target_Parent : Count_Type;
|
|
|
798 Target_Subtree : out Count_Type;
|
|
|
799 Count : in out Count_Type)
|
|
|
800 is
|
|
|
801 T_Nodes : Tree_Node_Array renames Target.Nodes;
|
|
|
802
|
|
|
803 begin
|
|
|
804 -- First we allocate the root of the target subtree.
|
|
|
805
|
|
|
806 Allocate_Node
|
|
|
807 (Container => Target,
|
|
|
808 New_Item => Source.Elements (Source_Subtree),
|
|
|
809 New_Node => Target_Subtree);
|
|
|
810
|
|
|
811 T_Nodes (Target_Subtree).Parent := Target_Parent;
|
|
|
812 Count := Count + 1;
|
|
|
813
|
|
|
814 -- We now have a new subtree (for the Target tree), containing only a
|
|
|
815 -- copy of the corresponding element in the Source subtree. Next we copy
|
|
|
816 -- the children of the Source subtree as children of the new Target
|
|
|
817 -- subtree.
|
|
|
818
|
|
|
819 Copy_Children
|
|
|
820 (Source => Source,
|
|
|
821 Source_Parent => Source_Subtree,
|
|
|
822 Target => Target,
|
|
|
823 Target_Parent => Target_Subtree,
|
|
|
824 Count => Count);
|
|
|
825 end Copy_Subtree;
|
|
|
826
|
|
|
827 -------------------------
|
|
|
828 -- Deallocate_Children --
|
|
|
829 -------------------------
|
|
|
830
|
|
|
831 procedure Deallocate_Children
|
|
|
832 (Container : in out Tree;
|
|
|
833 Subtree : Count_Type;
|
|
|
834 Count : in out Count_Type)
|
|
|
835 is
|
|
|
836 Nodes : Tree_Node_Array renames Container.Nodes;
|
|
|
837 Node : Tree_Node_Type renames Nodes (Subtree); -- parent
|
|
|
838 CC : Children_Type renames Node.Children;
|
|
|
839 C : Count_Type'Base;
|
|
|
840
|
|
|
841 begin
|
|
|
842 while CC.First > 0 loop
|
|
|
843 C := CC.First;
|
|
|
844 CC.First := Nodes (C).Next;
|
|
|
845
|
|
|
846 Deallocate_Subtree (Container, C, Count);
|
|
|
847 end loop;
|
|
|
848
|
|
|
849 CC.Last := 0;
|
|
|
850 end Deallocate_Children;
|
|
|
851
|
|
|
852 ---------------------
|
|
|
853 -- Deallocate_Node --
|
|
|
854 ---------------------
|
|
|
855
|
|
|
856 procedure Deallocate_Node
|
|
|
857 (Container : in out Tree;
|
|
|
858 X : Count_Type)
|
|
|
859 is
|
|
|
860 NN : Tree_Node_Array renames Container.Nodes;
|
|
|
861 pragma Assert (X > 0);
|
|
|
862 pragma Assert (X <= NN'Last);
|
|
|
863
|
|
|
864 N : Tree_Node_Type renames NN (X);
|
|
|
865 pragma Assert (N.Parent /= X); -- node is active
|
|
|
866
|
|
|
867 begin
|
|
|
868 -- The tree container actually contains two lists: one for the "active"
|
|
|
869 -- nodes that contain elements that have been inserted onto the tree,
|
|
|
870 -- and another for the "inactive" nodes of the free store, from which
|
|
|
871 -- nodes are allocated when a new child is inserted in the tree.
|
|
|
872
|
|
|
873 -- We desire that merely declaring a tree object should have only
|
|
|
874 -- minimal cost; specially, we want to avoid having to initialize the
|
|
|
875 -- free store (to fill in the links), especially if the capacity of the
|
|
|
876 -- tree object is large.
|
|
|
877
|
|
|
878 -- The head of the free list is indicated by Container.Free. If its
|
|
|
879 -- value is non-negative, then the free store has been initialized in
|
|
|
880 -- the "normal" way: Container.Free points to the head of the list of
|
|
|
881 -- free (inactive) nodes, and the value 0 means the free list is
|
|
|
882 -- empty. Each node on the free list has been initialized to point to
|
|
|
883 -- the next free node (via its Next component), and the value 0 means
|
|
|
884 -- that this is the last node of the free list.
|
|
|
885
|
|
|
886 -- If Container.Free is negative, then the links on the free store have
|
|
|
887 -- not been initialized. In this case the link values are implied: the
|
|
|
888 -- free store comprises the components of the node array started with
|
|
|
889 -- the absolute value of Container.Free, and continuing until the end of
|
|
|
890 -- the array (Nodes'Last).
|
|
|
891
|
|
|
892 -- We prefer to lazy-init the free store (in fact, we would prefer to
|
|
|
893 -- not initialize it at all, because such initialization is an O(n)
|
|
|
894 -- operation). The time when we need to actually initialize the nodes in
|
|
|
895 -- the free store is when the node that becomes inactive is not at the
|
|
|
896 -- end of the active list. The free store would then be discontigous and
|
|
|
897 -- so its nodes would need to be linked in the traditional way.
|
|
|
898
|
|
|
899 -- It might be possible to perform an optimization here. Suppose that
|
|
|
900 -- the free store can be represented as having two parts: one comprising
|
|
|
901 -- the non-contiguous inactive nodes linked together in the normal way,
|
|
|
902 -- and the other comprising the contiguous inactive nodes (that are not
|
|
|
903 -- linked together, at the end of the nodes array). This would allow us
|
|
|
904 -- to never have to initialize the free store, except in a lazy way as
|
|
|
905 -- nodes become inactive. ???
|
|
|
906
|
|
|
907 -- When an element is deleted from the list container, its node becomes
|
|
|
908 -- inactive, and so we set its Parent and Prev components to an
|
|
|
909 -- impossible value (the index of the node itself), to indicate that it
|
|
|
910 -- is now inactive. This provides a useful way to detect a dangling
|
|
|
911 -- cursor reference.
|
|
|
912
|
|
|
913 N.Parent := X; -- Node is deallocated (not on active list)
|
|
|
914 N.Prev := X;
|
|
|
915
|
|
|
916 if Container.Free >= 0 then
|
|
|
917 -- The free store has previously been initialized. All we need to do
|
|
|
918 -- here is link the newly-free'd node onto the free list.
|
|
|
919
|
|
|
920 N.Next := Container.Free;
|
|
|
921 Container.Free := X;
|
|
|
922
|
|
|
923 elsif X + 1 = abs Container.Free then
|
|
|
924 -- The free store has not been initialized, and the node becoming
|
|
|
925 -- inactive immediately precedes the start of the free store. All
|
|
|
926 -- we need to do is move the start of the free store back by one.
|
|
|
927
|
|
|
928 N.Next := X; -- Not strictly necessary, but marginally safer
|
|
|
929 Container.Free := Container.Free + 1;
|
|
|
930
|
|
|
931 else
|
|
|
932 -- The free store has not been initialized, and the node becoming
|
|
|
933 -- inactive does not immediately precede the free store. Here we
|
|
|
934 -- first initialize the free store (meaning the links are given
|
|
|
935 -- values in the traditional way), and then link the newly-free'd
|
|
|
936 -- node onto the head of the free store.
|
|
|
937
|
|
|
938 -- See the comments above for an optimization opportunity. If the
|
|
|
939 -- next link for a node on the free store is negative, then this
|
|
|
940 -- means the remaining nodes on the free store are physically
|
|
|
941 -- contiguous, starting at the absolute value of that index value.
|
|
|
942 -- ???
|
|
|
943
|
|
|
944 Container.Free := abs Container.Free;
|
|
|
945
|
|
|
946 if Container.Free > Container.Capacity then
|
|
|
947 Container.Free := 0;
|
|
|
948
|
|
|
949 else
|
|
|
950 for J in Container.Free .. Container.Capacity - 1 loop
|
|
|
951 NN (J).Next := J + 1;
|
|
|
952 end loop;
|
|
|
953
|
|
|
954 NN (Container.Capacity).Next := 0;
|
|
|
955 end if;
|
|
|
956
|
|
|
957 NN (X).Next := Container.Free;
|
|
|
958 Container.Free := X;
|
|
|
959 end if;
|
|
|
960 end Deallocate_Node;
|
|
|
961
|
|
|
962 ------------------------
|
|
|
963 -- Deallocate_Subtree --
|
|
|
964 ------------------------
|
|
|
965
|
|
|
966 procedure Deallocate_Subtree
|
|
|
967 (Container : in out Tree;
|
|
|
968 Subtree : Count_Type;
|
|
|
969 Count : in out Count_Type)
|
|
|
970 is
|
|
|
971 begin
|
|
|
972 Deallocate_Children (Container, Subtree, Count);
|
|
|
973 Deallocate_Node (Container, Subtree);
|
|
|
974 Count := Count + 1;
|
|
|
975 end Deallocate_Subtree;
|
|
|
976
|
|
|
977 ---------------------
|
|
|
978 -- Delete_Children --
|
|
|
979 ---------------------
|
|
|
980
|
|
|
981 procedure Delete_Children
|
|
|
982 (Container : in out Tree;
|
|
|
983 Parent : Cursor)
|
|
|
984 is
|
|
|
985 Count : Count_Type;
|
|
|
986
|
|
|
987 begin
|
|
|
988 if Checks and then Parent = No_Element then
|
|
|
989 raise Constraint_Error with "Parent cursor has no element";
|
|
|
990 end if;
|
|
|
991
|
|
|
992 if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
|
993 raise Program_Error with "Parent cursor not in container";
|
|
|
994 end if;
|
|
|
995
|
|
|
996 TC_Check (Container.TC);
|
|
|
997
|
|
|
998 if Container.Count = 0 then
|
|
|
999 pragma Assert (Is_Root (Parent));
|
|
|
1000 return;
|
|
|
1001 end if;
|
|
|
1002
|
|
|
1003 -- Deallocate_Children returns a count of the number of nodes that it
|
|
|
1004 -- deallocates, but it works by incrementing the value that is passed
|
|
|
1005 -- in. We must therefore initialize the count value before calling
|
|
|
1006 -- Deallocate_Children.
|
|
|
1007
|
|
|
1008 Count := 0;
|
|
|
1009
|
|
|
1010 Deallocate_Children (Container, Parent.Node, Count);
|
|
|
1011 pragma Assert (Count <= Container.Count);
|
|
|
1012
|
|
|
1013 Container.Count := Container.Count - Count;
|
|
|
1014 end Delete_Children;
|
|
|
1015
|
|
|
1016 -----------------
|
|
|
1017 -- Delete_Leaf --
|
|
|
1018 -----------------
|
|
|
1019
|
|
|
1020 procedure Delete_Leaf
|
|
|
1021 (Container : in out Tree;
|
|
|
1022 Position : in out Cursor)
|
|
|
1023 is
|
|
|
1024 X : Count_Type;
|
|
|
1025
|
|
|
1026 begin
|
|
|
1027 if Checks and then Position = No_Element then
|
|
|
1028 raise Constraint_Error with "Position cursor has no element";
|
|
|
1029 end if;
|
|
|
1030
|
|
|
1031 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1032 then
|
|
|
1033 raise Program_Error with "Position cursor not in container";
|
|
|
1034 end if;
|
|
|
1035
|
|
|
1036 if Checks and then Is_Root (Position) then
|
|
|
1037 raise Program_Error with "Position cursor designates root";
|
|
|
1038 end if;
|
|
|
1039
|
|
|
1040 if Checks and then not Is_Leaf (Position) then
|
|
|
1041 raise Constraint_Error with "Position cursor does not designate leaf";
|
|
|
1042 end if;
|
|
|
1043
|
|
|
1044 TC_Check (Container.TC);
|
|
|
1045
|
|
|
1046 X := Position.Node;
|
|
|
1047 Position := No_Element;
|
|
|
1048
|
|
|
1049 Remove_Subtree (Container, X);
|
|
|
1050 Container.Count := Container.Count - 1;
|
|
|
1051
|
|
|
1052 Deallocate_Node (Container, X);
|
|
|
1053 end Delete_Leaf;
|
|
|
1054
|
|
|
1055 --------------------
|
|
|
1056 -- Delete_Subtree --
|
|
|
1057 --------------------
|
|
|
1058
|
|
|
1059 procedure Delete_Subtree
|
|
|
1060 (Container : in out Tree;
|
|
|
1061 Position : in out Cursor)
|
|
|
1062 is
|
|
|
1063 X : Count_Type;
|
|
|
1064 Count : Count_Type;
|
|
|
1065
|
|
|
1066 begin
|
|
|
1067 if Checks and then Position = No_Element then
|
|
|
1068 raise Constraint_Error with "Position cursor has no element";
|
|
|
1069 end if;
|
|
|
1070
|
|
|
1071 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
1072 then
|
|
|
1073 raise Program_Error with "Position cursor not in container";
|
|
|
1074 end if;
|
|
|
1075
|
|
|
1076 if Checks and then Is_Root (Position) then
|
|
|
1077 raise Program_Error with "Position cursor designates root";
|
|
|
1078 end if;
|
|
|
1079
|
|
|
1080 TC_Check (Container.TC);
|
|
|
1081
|
|
|
1082 X := Position.Node;
|
|
|
1083 Position := No_Element;
|
|
|
1084
|
|
|
1085 Remove_Subtree (Container, X);
|
|
|
1086
|
|
|
1087 -- Deallocate_Subtree returns a count of the number of nodes that it
|
|
|
1088 -- deallocates, but it works by incrementing the value that is passed
|
|
|
1089 -- in. We must therefore initialize the count value before calling
|
|
|
1090 -- Deallocate_Subtree.
|
|
|
1091
|
|
|
1092 Count := 0;
|
|
|
1093
|
|
|
1094 Deallocate_Subtree (Container, X, Count);
|
|
|
1095 pragma Assert (Count <= Container.Count);
|
|
|
1096
|
|
|
1097 Container.Count := Container.Count - Count;
|
|
|
1098 end Delete_Subtree;
|
|
|
1099
|
|
|
1100 -----------
|
|
|
1101 -- Depth --
|
|
|
1102 -----------
|
|
|
1103
|
|
|
1104 function Depth (Position : Cursor) return Count_Type is
|
|
|
1105 Result : Count_Type;
|
|
|
1106 N : Count_Type'Base;
|
|
|
1107
|
|
|
1108 begin
|
|
|
1109 if Position = No_Element then
|
|
|
1110 return 0;
|
|
|
1111 end if;
|
|
|
1112
|
|
|
1113 if Is_Root (Position) then
|
|
|
1114 return 1;
|
|
|
1115 end if;
|
|
|
1116
|
|
|
1117 Result := 0;
|
|
|
1118 N := Position.Node;
|
|
|
1119 while N >= 0 loop
|
|
|
1120 N := Position.Container.Nodes (N).Parent;
|
|
|
1121 Result := Result + 1;
|
|
|
1122 end loop;
|
|
|
1123
|
|
|
1124 return Result;
|
|
|
1125 end Depth;
|
|
|
1126
|
|
|
1127 -------------
|
|
|
1128 -- Element --
|
|
|
1129 -------------
|
|
|
1130
|
|
|
1131 function Element (Position : Cursor) return Element_Type is
|
|
|
1132 begin
|
|
|
1133 if Checks and then Position.Container = null then
|
|
|
1134 raise Constraint_Error with "Position cursor has no element";
|
|
|
1135 end if;
|
|
|
1136
|
|
|
1137 if Checks and then Position.Node = Root_Node (Position.Container.all)
|
|
|
1138 then
|
|
|
1139 raise Program_Error with "Position cursor designates root";
|
|
|
1140 end if;
|
|
|
1141
|
|
|
1142 return Position.Container.Elements (Position.Node);
|
|
|
1143 end Element;
|
|
|
1144
|
|
|
1145 --------------------
|
|
|
1146 -- Equal_Children --
|
|
|
1147 --------------------
|
|
|
1148
|
|
|
1149 function Equal_Children
|
|
|
1150 (Left_Tree : Tree;
|
|
|
1151 Left_Subtree : Count_Type;
|
|
|
1152 Right_Tree : Tree;
|
|
|
1153 Right_Subtree : Count_Type) return Boolean
|
|
|
1154 is
|
|
|
1155 L_NN : Tree_Node_Array renames Left_Tree.Nodes;
|
|
|
1156 R_NN : Tree_Node_Array renames Right_Tree.Nodes;
|
|
|
1157
|
|
|
1158 Left_Children : Children_Type renames L_NN (Left_Subtree).Children;
|
|
|
1159 Right_Children : Children_Type renames R_NN (Right_Subtree).Children;
|
|
|
1160
|
|
|
1161 L, R : Count_Type'Base;
|
|
|
1162
|
|
|
1163 begin
|
|
|
1164 if Child_Count (Left_Tree, Left_Subtree)
|
|
|
1165 /= Child_Count (Right_Tree, Right_Subtree)
|
|
|
1166 then
|
|
|
1167 return False;
|
|
|
1168 end if;
|
|
|
1169
|
|
|
1170 L := Left_Children.First;
|
|
|
1171 R := Right_Children.First;
|
|
|
1172 while L > 0 loop
|
|
|
1173 if not Equal_Subtree (Left_Tree, L, Right_Tree, R) then
|
|
|
1174 return False;
|
|
|
1175 end if;
|
|
|
1176
|
|
|
1177 L := L_NN (L).Next;
|
|
|
1178 R := R_NN (R).Next;
|
|
|
1179 end loop;
|
|
|
1180
|
|
|
1181 return True;
|
|
|
1182 end Equal_Children;
|
|
|
1183
|
|
|
1184 -------------------
|
|
|
1185 -- Equal_Subtree --
|
|
|
1186 -------------------
|
|
|
1187
|
|
|
1188 function Equal_Subtree
|
|
|
1189 (Left_Position : Cursor;
|
|
|
1190 Right_Position : Cursor) return Boolean
|
|
|
1191 is
|
|
|
1192 begin
|
|
|
1193 if Checks and then Left_Position = No_Element then
|
|
|
1194 raise Constraint_Error with "Left cursor has no element";
|
|
|
1195 end if;
|
|
|
1196
|
|
|
1197 if Checks and then Right_Position = No_Element then
|
|
|
1198 raise Constraint_Error with "Right cursor has no element";
|
|
|
1199 end if;
|
|
|
1200
|
|
|
1201 if Left_Position = Right_Position then
|
|
|
1202 return True;
|
|
|
1203 end if;
|
|
|
1204
|
|
|
1205 if Is_Root (Left_Position) then
|
|
|
1206 if not Is_Root (Right_Position) then
|
|
|
1207 return False;
|
|
|
1208 end if;
|
|
|
1209
|
|
|
1210 if Left_Position.Container.Count = 0 then
|
|
|
1211 return Right_Position.Container.Count = 0;
|
|
|
1212 end if;
|
|
|
1213
|
|
|
1214 if Right_Position.Container.Count = 0 then
|
|
|
1215 return False;
|
|
|
1216 end if;
|
|
|
1217
|
|
|
1218 return Equal_Children
|
|
|
1219 (Left_Tree => Left_Position.Container.all,
|
|
|
1220 Left_Subtree => Left_Position.Node,
|
|
|
1221 Right_Tree => Right_Position.Container.all,
|
|
|
1222 Right_Subtree => Right_Position.Node);
|
|
|
1223 end if;
|
|
|
1224
|
|
|
1225 if Is_Root (Right_Position) then
|
|
|
1226 return False;
|
|
|
1227 end if;
|
|
|
1228
|
|
|
1229 return Equal_Subtree
|
|
|
1230 (Left_Tree => Left_Position.Container.all,
|
|
|
1231 Left_Subtree => Left_Position.Node,
|
|
|
1232 Right_Tree => Right_Position.Container.all,
|
|
|
1233 Right_Subtree => Right_Position.Node);
|
|
|
1234 end Equal_Subtree;
|
|
|
1235
|
|
|
1236 function Equal_Subtree
|
|
|
1237 (Left_Tree : Tree;
|
|
|
1238 Left_Subtree : Count_Type;
|
|
|
1239 Right_Tree : Tree;
|
|
|
1240 Right_Subtree : Count_Type) return Boolean
|
|
|
1241 is
|
|
|
1242 begin
|
|
|
1243 if Left_Tree.Elements (Left_Subtree) /=
|
|
|
1244 Right_Tree.Elements (Right_Subtree)
|
|
|
1245 then
|
|
|
1246 return False;
|
|
|
1247 end if;
|
|
|
1248
|
|
|
1249 return Equal_Children
|
|
|
1250 (Left_Tree => Left_Tree,
|
|
|
1251 Left_Subtree => Left_Subtree,
|
|
|
1252 Right_Tree => Right_Tree,
|
|
|
1253 Right_Subtree => Right_Subtree);
|
|
|
1254 end Equal_Subtree;
|
|
|
1255
|
|
|
1256 --------------
|
|
|
1257 -- Finalize --
|
|
|
1258 --------------
|
|
|
1259
|
|
|
1260 procedure Finalize (Object : in out Root_Iterator) is
|
|
|
1261 begin
|
|
|
1262 Unbusy (Object.Container.TC);
|
|
|
1263 end Finalize;
|
|
|
1264
|
|
|
1265 ----------
|
|
|
1266 -- Find --
|
|
|
1267 ----------
|
|
|
1268
|
|
|
1269 function Find
|
|
|
1270 (Container : Tree;
|
|
|
1271 Item : Element_Type) return Cursor
|
|
|
1272 is
|
|
|
1273 Node : Count_Type;
|
|
|
1274
|
|
|
1275 begin
|
|
|
1276 if Container.Count = 0 then
|
|
|
1277 return No_Element;
|
|
|
1278 end if;
|
|
|
1279
|
|
|
1280 Node := Find_In_Children (Container, Root_Node (Container), Item);
|
|
|
1281
|
|
|
1282 if Node = 0 then
|
|
|
1283 return No_Element;
|
|
|
1284 end if;
|
|
|
1285
|
|
|
1286 return Cursor'(Container'Unrestricted_Access, Node);
|
|
|
1287 end Find;
|
|
|
1288
|
|
|
1289 -----------
|
|
|
1290 -- First --
|
|
|
1291 -----------
|
|
|
1292
|
|
|
1293 overriding function First (Object : Subtree_Iterator) return Cursor is
|
|
|
1294 begin
|
|
|
1295 if Object.Subtree = Root_Node (Object.Container.all) then
|
|
|
1296 return First_Child (Root (Object.Container.all));
|
|
|
1297 else
|
|
|
1298 return Cursor'(Object.Container, Object.Subtree);
|
|
|
1299 end if;
|
|
|
1300 end First;
|
|
|
1301
|
|
|
1302 overriding function First (Object : Child_Iterator) return Cursor is
|
|
|
1303 begin
|
|
|
1304 return First_Child (Cursor'(Object.Container, Object.Subtree));
|
|
|
1305 end First;
|
|
|
1306
|
|
|
1307 -----------------
|
|
|
1308 -- First_Child --
|
|
|
1309 -----------------
|
|
|
1310
|
|
|
1311 function First_Child (Parent : Cursor) return Cursor is
|
|
|
1312 Node : Count_Type'Base;
|
|
|
1313
|
|
|
1314 begin
|
|
|
1315 if Checks and then Parent = No_Element then
|
|
|
1316 raise Constraint_Error with "Parent cursor has no element";
|
|
|
1317 end if;
|
|
|
1318
|
|
|
1319 if Parent.Container.Count = 0 then
|
|
|
1320 pragma Assert (Is_Root (Parent));
|
|
|
1321 return No_Element;
|
|
|
1322 end if;
|
|
|
1323
|
|
|
1324 Node := Parent.Container.Nodes (Parent.Node).Children.First;
|
|
|
1325
|
|
|
1326 if Node <= 0 then
|
|
|
1327 return No_Element;
|
|
|
1328 end if;
|
|
|
1329
|
|
|
1330 return Cursor'(Parent.Container, Node);
|
|
|
1331 end First_Child;
|
|
|
1332
|
|
|
1333 -------------------------
|
|
|
1334 -- First_Child_Element --
|
|
|
1335 -------------------------
|
|
|
1336
|
|
|
1337 function First_Child_Element (Parent : Cursor) return Element_Type is
|
|
|
1338 begin
|
|
|
1339 return Element (First_Child (Parent));
|
|
|
1340 end First_Child_Element;
|
|
|
1341
|
|
|
1342 ----------------------
|
|
|
1343 -- Find_In_Children --
|
|
|
1344 ----------------------
|
|
|
1345
|
|
|
1346 function Find_In_Children
|
|
|
1347 (Container : Tree;
|
|
|
1348 Subtree : Count_Type;
|
|
|
1349 Item : Element_Type) return Count_Type
|
|
|
1350 is
|
|
|
1351 N : Count_Type'Base;
|
|
|
1352 Result : Count_Type;
|
|
|
1353
|
|
|
1354 begin
|
|
|
1355 N := Container.Nodes (Subtree).Children.First;
|
|
|
1356 while N > 0 loop
|
|
|
1357 Result := Find_In_Subtree (Container, N, Item);
|
|
|
1358
|
|
|
1359 if Result > 0 then
|
|
|
1360 return Result;
|
|
|
1361 end if;
|
|
|
1362
|
|
|
1363 N := Container.Nodes (N).Next;
|
|
|
1364 end loop;
|
|
|
1365
|
|
|
1366 return 0;
|
|
|
1367 end Find_In_Children;
|
|
|
1368
|
|
|
1369 ---------------------
|
|
|
1370 -- Find_In_Subtree --
|
|
|
1371 ---------------------
|
|
|
1372
|
|
|
1373 function Find_In_Subtree
|
|
|
1374 (Position : Cursor;
|
|
|
1375 Item : Element_Type) return Cursor
|
|
|
1376 is
|
|
|
1377 Result : Count_Type;
|
|
|
1378
|
|
|
1379 begin
|
|
|
1380 if Checks and then Position = No_Element then
|
|
|
1381 raise Constraint_Error with "Position cursor has no element";
|
|
|
1382 end if;
|
|
|
1383
|
|
|
1384 -- Commented-out pending ruling by ARG. ???
|
|
|
1385
|
|
|
1386 -- if Checks and then
|
|
|
1387 -- Position.Container /= Container'Unrestricted_Access
|
|
|
1388 -- then
|
|
|
1389 -- raise Program_Error with "Position cursor not in container";
|
|
|
1390 -- end if;
|
|
|
1391
|
|
|
1392 if Position.Container.Count = 0 then
|
|
|
1393 pragma Assert (Is_Root (Position));
|
|
|
1394 return No_Element;
|
|
|
1395 end if;
|
|
|
1396
|
|
|
1397 if Is_Root (Position) then
|
|
|
1398 Result := Find_In_Children
|
|
|
1399 (Container => Position.Container.all,
|
|
|
1400 Subtree => Position.Node,
|
|
|
1401 Item => Item);
|
|
|
1402
|
|
|
1403 else
|
|
|
1404 Result := Find_In_Subtree
|
|
|
1405 (Container => Position.Container.all,
|
|
|
1406 Subtree => Position.Node,
|
|
|
1407 Item => Item);
|
|
|
1408 end if;
|
|
|
1409
|
|
|
1410 if Result = 0 then
|
|
|
1411 return No_Element;
|
|
|
1412 end if;
|
|
|
1413
|
|
|
1414 return Cursor'(Position.Container, Result);
|
|
|
1415 end Find_In_Subtree;
|
|
|
1416
|
|
|
1417 function Find_In_Subtree
|
|
|
1418 (Container : Tree;
|
|
|
1419 Subtree : Count_Type;
|
|
|
1420 Item : Element_Type) return Count_Type
|
|
|
1421 is
|
|
|
1422 begin
|
|
|
1423 if Container.Elements (Subtree) = Item then
|
|
|
1424 return Subtree;
|
|
|
1425 end if;
|
|
|
1426
|
|
|
1427 return Find_In_Children (Container, Subtree, Item);
|
|
|
1428 end Find_In_Subtree;
|
|
|
1429
|
|
|
1430 ------------------------
|
|
|
1431 -- Get_Element_Access --
|
|
|
1432 ------------------------
|
|
|
1433
|
|
|
1434 function Get_Element_Access
|
|
|
1435 (Position : Cursor) return not null Element_Access is
|
|
|
1436 begin
|
|
|
1437 return Position.Container.Elements (Position.Node)'Access;
|
|
|
1438 end Get_Element_Access;
|
|
|
1439
|
|
|
1440 -----------------
|
|
|
1441 -- Has_Element --
|
|
|
1442 -----------------
|
|
|
1443
|
|
|
1444 function Has_Element (Position : Cursor) return Boolean is
|
|
|
1445 begin
|
|
|
1446 if Position = No_Element then
|
|
|
1447 return False;
|
|
|
1448 end if;
|
|
|
1449
|
|
|
1450 return Position.Node /= Root_Node (Position.Container.all);
|
|
|
1451 end Has_Element;
|
|
|
1452
|
|
|
1453 ---------------------
|
|
|
1454 -- Initialize_Node --
|
|
|
1455 ---------------------
|
|
|
1456
|
|
|
1457 procedure Initialize_Node
|
|
|
1458 (Container : in out Tree;
|
|
|
1459 Index : Count_Type)
|
|
|
1460 is
|
|
|
1461 begin
|
|
|
1462 Container.Nodes (Index) :=
|
|
|
1463 (Parent => No_Node,
|
|
|
1464 Prev => 0,
|
|
|
1465 Next => 0,
|
|
|
1466 Children => (others => 0));
|
|
|
1467 end Initialize_Node;
|
|
|
1468
|
|
|
1469 ---------------------
|
|
|
1470 -- Initialize_Root --
|
|
|
1471 ---------------------
|
|
|
1472
|
|
|
1473 procedure Initialize_Root (Container : in out Tree) is
|
|
|
1474 begin
|
|
|
1475 Initialize_Node (Container, Root_Node (Container));
|
|
|
1476 end Initialize_Root;
|
|
|
1477
|
|
|
1478 ------------------
|
|
|
1479 -- Insert_Child --
|
|
|
1480 ------------------
|
|
|
1481
|
|
|
1482 procedure Insert_Child
|
|
|
1483 (Container : in out Tree;
|
|
|
1484 Parent : Cursor;
|
|
|
1485 Before : Cursor;
|
|
|
1486 New_Item : Element_Type;
|
|
|
1487 Count : Count_Type := 1)
|
|
|
1488 is
|
|
|
1489 Position : Cursor;
|
|
|
1490 pragma Unreferenced (Position);
|
|
|
1491
|
|
|
1492 begin
|
|
|
1493 Insert_Child (Container, Parent, Before, New_Item, Position, Count);
|
|
|
1494 end Insert_Child;
|
|
|
1495
|
|
|
1496 procedure Insert_Child
|
|
|
1497 (Container : in out Tree;
|
|
|
1498 Parent : Cursor;
|
|
|
1499 Before : Cursor;
|
|
|
1500 New_Item : Element_Type;
|
|
|
1501 Position : out Cursor;
|
|
|
1502 Count : Count_Type := 1)
|
|
|
1503 is
|
|
|
1504 Nodes : Tree_Node_Array renames Container.Nodes;
|
|
|
1505 First : Count_Type;
|
|
|
1506 Last : Count_Type;
|
|
|
1507
|
|
|
1508 begin
|
|
|
1509 if Checks and then Parent = No_Element then
|
|
|
1510 raise Constraint_Error with "Parent cursor has no element";
|
|
|
1511 end if;
|
|
|
1512
|
|
|
1513 if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
|
1514 raise Program_Error with "Parent cursor not in container";
|
|
|
1515 end if;
|
|
|
1516
|
|
|
1517 if Before /= No_Element then
|
|
|
1518 if Checks and then Before.Container /= Container'Unrestricted_Access
|
|
|
1519 then
|
|
|
1520 raise Program_Error with "Before cursor not in container";
|
|
|
1521 end if;
|
|
|
1522
|
|
|
1523 if Checks and then
|
|
|
1524 Before.Container.Nodes (Before.Node).Parent /= Parent.Node
|
|
|
1525 then
|
|
|
1526 raise Constraint_Error with "Parent cursor not parent of Before";
|
|
|
1527 end if;
|
|
|
1528 end if;
|
|
|
1529
|
|
|
1530 if Count = 0 then
|
|
|
1531 Position := No_Element; -- Need ruling from ARG ???
|
|
|
1532 return;
|
|
|
1533 end if;
|
|
|
1534
|
|
|
1535 if Checks and then Container.Count > Container.Capacity - Count then
|
|
|
1536 raise Capacity_Error
|
|
|
1537 with "requested count exceeds available storage";
|
|
|
1538 end if;
|
|
|
1539
|
|
|
1540 TC_Check (Container.TC);
|
|
|
1541
|
|
|
1542 if Container.Count = 0 then
|
|
|
1543 Initialize_Root (Container);
|
|
|
1544 end if;
|
|
|
1545
|
|
|
1546 Allocate_Node (Container, New_Item, First);
|
|
|
1547 Nodes (First).Parent := Parent.Node;
|
|
|
1548
|
|
|
1549 Last := First;
|
|
|
1550 for J in Count_Type'(2) .. Count loop
|
|
|
1551 Allocate_Node (Container, New_Item, Nodes (Last).Next);
|
|
|
1552 Nodes (Nodes (Last).Next).Parent := Parent.Node;
|
|
|
1553 Nodes (Nodes (Last).Next).Prev := Last;
|
|
|
1554
|
|
|
1555 Last := Nodes (Last).Next;
|
|
|
1556 end loop;
|
|
|
1557
|
|
|
1558 Insert_Subtree_List
|
|
|
1559 (Container => Container,
|
|
|
1560 First => First,
|
|
|
1561 Last => Last,
|
|
|
1562 Parent => Parent.Node,
|
|
|
1563 Before => Before.Node);
|
|
|
1564
|
|
|
1565 Container.Count := Container.Count + Count;
|
|
|
1566
|
|
|
1567 Position := Cursor'(Parent.Container, First);
|
|
|
1568 end Insert_Child;
|
|
|
1569
|
|
|
1570 procedure Insert_Child
|
|
|
1571 (Container : in out Tree;
|
|
|
1572 Parent : Cursor;
|
|
|
1573 Before : Cursor;
|
|
|
1574 Position : out Cursor;
|
|
|
1575 Count : Count_Type := 1)
|
|
|
1576 is
|
|
|
1577 Nodes : Tree_Node_Array renames Container.Nodes;
|
|
|
1578 First : Count_Type;
|
|
|
1579 Last : Count_Type;
|
|
|
1580
|
|
|
1581 pragma Warnings (Off);
|
|
|
1582 Default_Initialized_Item : Element_Type;
|
|
|
1583 pragma Unmodified (Default_Initialized_Item);
|
|
|
1584 -- OK to reference, see below
|
|
|
1585
|
|
|
1586 begin
|
|
|
1587 if Checks and then Parent = No_Element then
|
|
|
1588 raise Constraint_Error with "Parent cursor has no element";
|
|
|
1589 end if;
|
|
|
1590
|
|
|
1591 if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
|
1592 raise Program_Error with "Parent cursor not in container";
|
|
|
1593 end if;
|
|
|
1594
|
|
|
1595 if Before /= No_Element then
|
|
|
1596 if Checks and then Before.Container /= Container'Unrestricted_Access
|
|
|
1597 then
|
|
|
1598 raise Program_Error with "Before cursor not in container";
|
|
|
1599 end if;
|
|
|
1600
|
|
|
1601 if Checks and then
|
|
|
1602 Before.Container.Nodes (Before.Node).Parent /= Parent.Node
|
|
|
1603 then
|
|
|
1604 raise Constraint_Error with "Parent cursor not parent of Before";
|
|
|
1605 end if;
|
|
|
1606 end if;
|
|
|
1607
|
|
|
1608 if Count = 0 then
|
|
|
1609 Position := No_Element; -- Need ruling from ARG ???
|
|
|
1610 return;
|
|
|
1611 end if;
|
|
|
1612
|
|
|
1613 if Checks and then Container.Count > Container.Capacity - Count then
|
|
|
1614 raise Capacity_Error
|
|
|
1615 with "requested count exceeds available storage";
|
|
|
1616 end if;
|
|
|
1617
|
|
|
1618 TC_Check (Container.TC);
|
|
|
1619
|
|
|
1620 if Container.Count = 0 then
|
|
|
1621 Initialize_Root (Container);
|
|
|
1622 end if;
|
|
|
1623
|
|
|
1624 -- There is no explicit element provided, but in an instance the element
|
|
|
1625 -- type may be a scalar with a Default_Value aspect, or a composite
|
|
|
1626 -- type with such a scalar component, or components with default
|
|
|
1627 -- initialization, so insert the specified number of possibly
|
|
|
1628 -- initialized elements at the given position.
|
|
|
1629
|
|
|
1630 Allocate_Node (Container, Default_Initialized_Item, First);
|
|
|
1631 Nodes (First).Parent := Parent.Node;
|
|
|
1632
|
|
|
1633 Last := First;
|
|
|
1634 for J in Count_Type'(2) .. Count loop
|
|
|
1635 Allocate_Node
|
|
|
1636 (Container, Default_Initialized_Item, Nodes (Last).Next);
|
|
|
1637 Nodes (Nodes (Last).Next).Parent := Parent.Node;
|
|
|
1638 Nodes (Nodes (Last).Next).Prev := Last;
|
|
|
1639
|
|
|
1640 Last := Nodes (Last).Next;
|
|
|
1641 end loop;
|
|
|
1642
|
|
|
1643 Insert_Subtree_List
|
|
|
1644 (Container => Container,
|
|
|
1645 First => First,
|
|
|
1646 Last => Last,
|
|
|
1647 Parent => Parent.Node,
|
|
|
1648 Before => Before.Node);
|
|
|
1649
|
|
|
1650 Container.Count := Container.Count + Count;
|
|
|
1651
|
|
|
1652 Position := Cursor'(Parent.Container, First);
|
|
|
1653 pragma Warnings (On);
|
|
|
1654 end Insert_Child;
|
|
|
1655
|
|
|
1656 -------------------------
|
|
|
1657 -- Insert_Subtree_List --
|
|
|
1658 -------------------------
|
|
|
1659
|
|
|
1660 procedure Insert_Subtree_List
|
|
|
1661 (Container : in out Tree;
|
|
|
1662 First : Count_Type'Base;
|
|
|
1663 Last : Count_Type'Base;
|
|
|
1664 Parent : Count_Type;
|
|
|
1665 Before : Count_Type'Base)
|
|
|
1666 is
|
|
|
1667 NN : Tree_Node_Array renames Container.Nodes;
|
|
|
1668 N : Tree_Node_Type renames NN (Parent);
|
|
|
1669 CC : Children_Type renames N.Children;
|
|
|
1670
|
|
|
1671 begin
|
|
|
1672 -- This is a simple utility operation to insert a list of nodes
|
|
|
1673 -- (First..Last) as children of Parent. The Before node specifies where
|
|
|
1674 -- the new children should be inserted relative to existing children.
|
|
|
1675
|
|
|
1676 if First <= 0 then
|
|
|
1677 pragma Assert (Last <= 0);
|
|
|
1678 return;
|
|
|
1679 end if;
|
|
|
1680
|
|
|
1681 pragma Assert (Last > 0);
|
|
|
1682 pragma Assert (Before <= 0 or else NN (Before).Parent = Parent);
|
|
|
1683
|
|
|
1684 if CC.First <= 0 then -- no existing children
|
|
|
1685 CC.First := First;
|
|
|
1686 NN (CC.First).Prev := 0;
|
|
|
1687 CC.Last := Last;
|
|
|
1688 NN (CC.Last).Next := 0;
|
|
|
1689
|
|
|
1690 elsif Before <= 0 then -- means "insert after existing nodes"
|
|
|
1691 NN (CC.Last).Next := First;
|
|
|
1692 NN (First).Prev := CC.Last;
|
|
|
1693 CC.Last := Last;
|
|
|
1694 NN (CC.Last).Next := 0;
|
|
|
1695
|
|
|
1696 elsif Before = CC.First then
|
|
|
1697 NN (Last).Next := CC.First;
|
|
|
1698 NN (CC.First).Prev := Last;
|
|
|
1699 CC.First := First;
|
|
|
1700 NN (CC.First).Prev := 0;
|
|
|
1701
|
|
|
1702 else
|
|
|
1703 NN (NN (Before).Prev).Next := First;
|
|
|
1704 NN (First).Prev := NN (Before).Prev;
|
|
|
1705 NN (Last).Next := Before;
|
|
|
1706 NN (Before).Prev := Last;
|
|
|
1707 end if;
|
|
|
1708 end Insert_Subtree_List;
|
|
|
1709
|
|
|
1710 -------------------------
|
|
|
1711 -- Insert_Subtree_Node --
|
|
|
1712 -------------------------
|
|
|
1713
|
|
|
1714 procedure Insert_Subtree_Node
|
|
|
1715 (Container : in out Tree;
|
|
|
1716 Subtree : Count_Type'Base;
|
|
|
1717 Parent : Count_Type;
|
|
|
1718 Before : Count_Type'Base)
|
|
|
1719 is
|
|
|
1720 begin
|
|
|
1721 -- This is a simple wrapper operation to insert a single child into the
|
|
|
1722 -- Parent's children list.
|
|
|
1723
|
|
|
1724 Insert_Subtree_List
|
|
|
1725 (Container => Container,
|
|
|
1726 First => Subtree,
|
|
|
1727 Last => Subtree,
|
|
|
1728 Parent => Parent,
|
|
|
1729 Before => Before);
|
|
|
1730 end Insert_Subtree_Node;
|
|
|
1731
|
|
|
1732 --------------
|
|
|
1733 -- Is_Empty --
|
|
|
1734 --------------
|
|
|
1735
|
|
|
1736 function Is_Empty (Container : Tree) return Boolean is
|
|
|
1737 begin
|
|
|
1738 return Container.Count = 0;
|
|
|
1739 end Is_Empty;
|
|
|
1740
|
|
|
1741 -------------
|
|
|
1742 -- Is_Leaf --
|
|
|
1743 -------------
|
|
|
1744
|
|
|
1745 function Is_Leaf (Position : Cursor) return Boolean is
|
|
|
1746 begin
|
|
|
1747 if Position = No_Element then
|
|
|
1748 return False;
|
|
|
1749 end if;
|
|
|
1750
|
|
|
1751 if Position.Container.Count = 0 then
|
|
|
1752 pragma Assert (Is_Root (Position));
|
|
|
1753 return True;
|
|
|
1754 end if;
|
|
|
1755
|
|
|
1756 return Position.Container.Nodes (Position.Node).Children.First <= 0;
|
|
|
1757 end Is_Leaf;
|
|
|
1758
|
|
|
1759 ------------------
|
|
|
1760 -- Is_Reachable --
|
|
|
1761 ------------------
|
|
|
1762
|
|
|
1763 function Is_Reachable
|
|
|
1764 (Container : Tree;
|
|
|
1765 From, To : Count_Type) return Boolean
|
|
|
1766 is
|
|
145
|
1767 Idx : Count_Type'Base := From;
|
|
111
|
1768 begin
|
|
|
1769 while Idx >= 0 loop
|
|
|
1770 if Idx = To then
|
|
|
1771 return True;
|
|
|
1772 end if;
|
|
|
1773
|
|
|
1774 Idx := Container.Nodes (Idx).Parent;
|
|
|
1775 end loop;
|
|
|
1776
|
|
|
1777 return False;
|
|
|
1778 end Is_Reachable;
|
|
|
1779
|
|
|
1780 -------------
|
|
|
1781 -- Is_Root --
|
|
|
1782 -------------
|
|
|
1783
|
|
|
1784 function Is_Root (Position : Cursor) return Boolean is
|
|
|
1785 begin
|
|
|
1786 return
|
|
|
1787 (if Position.Container = null then False
|
|
|
1788 else Position.Node = Root_Node (Position.Container.all));
|
|
|
1789 end Is_Root;
|
|
|
1790
|
|
|
1791 -------------
|
|
|
1792 -- Iterate --
|
|
|
1793 -------------
|
|
|
1794
|
|
|
1795 procedure Iterate
|
|
|
1796 (Container : Tree;
|
|
|
1797 Process : not null access procedure (Position : Cursor))
|
|
|
1798 is
|
|
|
1799 Busy : With_Busy (Container.TC'Unrestricted_Access);
|
|
|
1800 begin
|
|
|
1801 if Container.Count = 0 then
|
|
|
1802 return;
|
|
|
1803 end if;
|
|
|
1804
|
|
|
1805 Iterate_Children
|
|
|
1806 (Container => Container,
|
|
|
1807 Subtree => Root_Node (Container),
|
|
|
1808 Process => Process);
|
|
|
1809 end Iterate;
|
|
|
1810
|
|
|
1811 function Iterate (Container : Tree)
|
|
|
1812 return Tree_Iterator_Interfaces.Forward_Iterator'Class
|
|
|
1813 is
|
|
|
1814 begin
|
|
|
1815 return Iterate_Subtree (Root (Container));
|
|
|
1816 end Iterate;
|
|
|
1817
|
|
|
1818 ----------------------
|
|
|
1819 -- Iterate_Children --
|
|
|
1820 ----------------------
|
|
|
1821
|
|
|
1822 procedure Iterate_Children
|
|
|
1823 (Parent : Cursor;
|
|
|
1824 Process : not null access procedure (Position : Cursor))
|
|
|
1825 is
|
|
|
1826 begin
|
|
|
1827 if Checks and then Parent = No_Element then
|
|
|
1828 raise Constraint_Error with "Parent cursor has no element";
|
|
|
1829 end if;
|
|
|
1830
|
|
|
1831 if Parent.Container.Count = 0 then
|
|
|
1832 pragma Assert (Is_Root (Parent));
|
|
|
1833 return;
|
|
|
1834 end if;
|
|
|
1835
|
|
|
1836 declare
|
|
|
1837 C : Count_Type;
|
|
|
1838 NN : Tree_Node_Array renames Parent.Container.Nodes;
|
|
|
1839 Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
|
|
|
1840
|
|
|
1841 begin
|
|
|
1842 C := NN (Parent.Node).Children.First;
|
|
|
1843 while C > 0 loop
|
|
|
1844 Process (Cursor'(Parent.Container, Node => C));
|
|
|
1845 C := NN (C).Next;
|
|
|
1846 end loop;
|
|
|
1847 end;
|
|
|
1848 end Iterate_Children;
|
|
|
1849
|
|
|
1850 procedure Iterate_Children
|
|
|
1851 (Container : Tree;
|
|
|
1852 Subtree : Count_Type;
|
|
|
1853 Process : not null access procedure (Position : Cursor))
|
|
|
1854 is
|
|
|
1855 NN : Tree_Node_Array renames Container.Nodes;
|
|
|
1856 N : Tree_Node_Type renames NN (Subtree);
|
|
|
1857 C : Count_Type;
|
|
|
1858
|
|
|
1859 begin
|
|
|
1860 -- This is a helper function to recursively iterate over all the nodes
|
|
|
1861 -- in a subtree, in depth-first fashion. This particular helper just
|
|
|
1862 -- visits the children of this subtree, not the root of the subtree
|
|
|
1863 -- itself. This is useful when starting from the ultimate root of the
|
|
|
1864 -- entire tree (see Iterate), as that root does not have an element.
|
|
|
1865
|
|
|
1866 C := N.Children.First;
|
|
|
1867 while C > 0 loop
|
|
|
1868 Iterate_Subtree (Container, C, Process);
|
|
|
1869 C := NN (C).Next;
|
|
|
1870 end loop;
|
|
|
1871 end Iterate_Children;
|
|
|
1872
|
|
|
1873 function Iterate_Children
|
|
|
1874 (Container : Tree;
|
|
|
1875 Parent : Cursor)
|
|
|
1876 return Tree_Iterator_Interfaces.Reversible_Iterator'Class
|
|
|
1877 is
|
|
|
1878 C : constant Tree_Access := Container'Unrestricted_Access;
|
|
|
1879 begin
|
|
|
1880 if Checks and then Parent = No_Element then
|
|
|
1881 raise Constraint_Error with "Parent cursor has no element";
|
|
|
1882 end if;
|
|
|
1883
|
|
|
1884 if Checks and then Parent.Container /= C then
|
|
|
1885 raise Program_Error with "Parent cursor not in container";
|
|
|
1886 end if;
|
|
|
1887
|
|
|
1888 return It : constant Child_Iterator :=
|
|
|
1889 Child_Iterator'(Limited_Controlled with
|
|
|
1890 Container => C,
|
|
|
1891 Subtree => Parent.Node)
|
|
|
1892 do
|
|
|
1893 Busy (C.TC);
|
|
|
1894 end return;
|
|
|
1895 end Iterate_Children;
|
|
|
1896
|
|
|
1897 ---------------------
|
|
|
1898 -- Iterate_Subtree --
|
|
|
1899 ---------------------
|
|
|
1900
|
|
|
1901 function Iterate_Subtree
|
|
|
1902 (Position : Cursor)
|
|
|
1903 return Tree_Iterator_Interfaces.Forward_Iterator'Class
|
|
|
1904 is
|
|
|
1905 C : constant Tree_Access := Position.Container;
|
|
|
1906 begin
|
|
|
1907 if Checks and then Position = No_Element then
|
|
|
1908 raise Constraint_Error with "Position cursor has no element";
|
|
|
1909 end if;
|
|
|
1910
|
|
|
1911 -- Implement Vet for multiway trees???
|
|
|
1912 -- pragma Assert (Vet (Position), "bad subtree cursor");
|
|
|
1913
|
|
|
1914 return It : constant Subtree_Iterator :=
|
|
|
1915 (Limited_Controlled with
|
|
|
1916 Container => C,
|
|
|
1917 Subtree => Position.Node)
|
|
|
1918 do
|
|
|
1919 Busy (C.TC);
|
|
|
1920 end return;
|
|
|
1921 end Iterate_Subtree;
|
|
|
1922
|
|
|
1923 procedure Iterate_Subtree
|
|
|
1924 (Position : Cursor;
|
|
|
1925 Process : not null access procedure (Position : Cursor))
|
|
|
1926 is
|
|
|
1927 begin
|
|
|
1928 if Checks and then Position = No_Element then
|
|
|
1929 raise Constraint_Error with "Position cursor has no element";
|
|
|
1930 end if;
|
|
|
1931
|
|
|
1932 if Position.Container.Count = 0 then
|
|
|
1933 pragma Assert (Is_Root (Position));
|
|
|
1934 return;
|
|
|
1935 end if;
|
|
|
1936
|
|
|
1937 declare
|
|
|
1938 T : Tree renames Position.Container.all;
|
|
|
1939 Busy : With_Busy (T.TC'Unrestricted_Access);
|
|
|
1940 begin
|
|
|
1941 if Is_Root (Position) then
|
|
|
1942 Iterate_Children (T, Position.Node, Process);
|
|
|
1943 else
|
|
|
1944 Iterate_Subtree (T, Position.Node, Process);
|
|
|
1945 end if;
|
|
|
1946 end;
|
|
|
1947 end Iterate_Subtree;
|
|
|
1948
|
|
|
1949 procedure Iterate_Subtree
|
|
|
1950 (Container : Tree;
|
|
|
1951 Subtree : Count_Type;
|
|
|
1952 Process : not null access procedure (Position : Cursor))
|
|
|
1953 is
|
|
|
1954 begin
|
|
|
1955 -- This is a helper function to recursively iterate over all the nodes
|
|
|
1956 -- in a subtree, in depth-first fashion. It first visits the root of the
|
|
|
1957 -- subtree, then visits its children.
|
|
|
1958
|
|
|
1959 Process (Cursor'(Container'Unrestricted_Access, Subtree));
|
|
|
1960 Iterate_Children (Container, Subtree, Process);
|
|
|
1961 end Iterate_Subtree;
|
|
|
1962
|
|
|
1963 ----------
|
|
|
1964 -- Last --
|
|
|
1965 ----------
|
|
|
1966
|
|
|
1967 overriding function Last (Object : Child_Iterator) return Cursor is
|
|
|
1968 begin
|
|
|
1969 return Last_Child (Cursor'(Object.Container, Object.Subtree));
|
|
|
1970 end Last;
|
|
|
1971
|
|
|
1972 ----------------
|
|
|
1973 -- Last_Child --
|
|
|
1974 ----------------
|
|
|
1975
|
|
|
1976 function Last_Child (Parent : Cursor) return Cursor is
|
|
|
1977 Node : Count_Type'Base;
|
|
|
1978
|
|
|
1979 begin
|
|
|
1980 if Checks and then Parent = No_Element then
|
|
|
1981 raise Constraint_Error with "Parent cursor has no element";
|
|
|
1982 end if;
|
|
|
1983
|
|
|
1984 if Parent.Container.Count = 0 then
|
|
|
1985 pragma Assert (Is_Root (Parent));
|
|
|
1986 return No_Element;
|
|
|
1987 end if;
|
|
|
1988
|
|
|
1989 Node := Parent.Container.Nodes (Parent.Node).Children.Last;
|
|
|
1990
|
|
|
1991 if Node <= 0 then
|
|
|
1992 return No_Element;
|
|
|
1993 end if;
|
|
|
1994
|
|
|
1995 return Cursor'(Parent.Container, Node);
|
|
|
1996 end Last_Child;
|
|
|
1997
|
|
|
1998 ------------------------
|
|
|
1999 -- Last_Child_Element --
|
|
|
2000 ------------------------
|
|
|
2001
|
|
|
2002 function Last_Child_Element (Parent : Cursor) return Element_Type is
|
|
|
2003 begin
|
|
|
2004 return Element (Last_Child (Parent));
|
|
|
2005 end Last_Child_Element;
|
|
|
2006
|
|
|
2007 ----------
|
|
|
2008 -- Move --
|
|
|
2009 ----------
|
|
|
2010
|
|
|
2011 procedure Move (Target : in out Tree; Source : in out Tree) is
|
|
|
2012 begin
|
|
|
2013 if Target'Address = Source'Address then
|
|
|
2014 return;
|
|
|
2015 end if;
|
|
|
2016
|
|
|
2017 TC_Check (Source.TC);
|
|
|
2018
|
|
|
2019 Target.Assign (Source);
|
|
|
2020 Source.Clear;
|
|
|
2021 end Move;
|
|
|
2022
|
|
|
2023 ----------
|
|
|
2024 -- Next --
|
|
|
2025 ----------
|
|
|
2026
|
|
|
2027 overriding function Next
|
|
|
2028 (Object : Subtree_Iterator;
|
|
|
2029 Position : Cursor) return Cursor
|
|
|
2030 is
|
|
|
2031 begin
|
|
|
2032 if Position.Container = null then
|
|
|
2033 return No_Element;
|
|
|
2034 end if;
|
|
|
2035
|
|
|
2036 if Checks and then Position.Container /= Object.Container then
|
|
|
2037 raise Program_Error with
|
|
|
2038 "Position cursor of Next designates wrong tree";
|
|
|
2039 end if;
|
|
|
2040
|
|
|
2041 pragma Assert (Object.Container.Count > 0);
|
|
|
2042 pragma Assert (Position.Node /= Root_Node (Object.Container.all));
|
|
|
2043
|
|
|
2044 declare
|
|
|
2045 Nodes : Tree_Node_Array renames Object.Container.Nodes;
|
|
|
2046 Node : Count_Type;
|
|
|
2047
|
|
|
2048 begin
|
|
|
2049 Node := Position.Node;
|
|
|
2050
|
|
|
2051 if Nodes (Node).Children.First > 0 then
|
|
|
2052 return Cursor'(Object.Container, Nodes (Node).Children.First);
|
|
|
2053 end if;
|
|
|
2054
|
|
|
2055 while Node /= Object.Subtree loop
|
|
|
2056 if Nodes (Node).Next > 0 then
|
|
|
2057 return Cursor'(Object.Container, Nodes (Node).Next);
|
|
|
2058 end if;
|
|
|
2059
|
|
|
2060 Node := Nodes (Node).Parent;
|
|
|
2061 end loop;
|
|
|
2062
|
|
|
2063 return No_Element;
|
|
|
2064 end;
|
|
|
2065 end Next;
|
|
|
2066
|
|
|
2067 overriding function Next
|
|
|
2068 (Object : Child_Iterator;
|
|
|
2069 Position : Cursor) return Cursor
|
|
|
2070 is
|
|
|
2071 begin
|
|
|
2072 if Position.Container = null then
|
|
|
2073 return No_Element;
|
|
|
2074 end if;
|
|
|
2075
|
|
|
2076 if Checks and then Position.Container /= Object.Container then
|
|
|
2077 raise Program_Error with
|
|
|
2078 "Position cursor of Next designates wrong tree";
|
|
|
2079 end if;
|
|
|
2080
|
|
|
2081 pragma Assert (Object.Container.Count > 0);
|
|
|
2082 pragma Assert (Position.Node /= Root_Node (Object.Container.all));
|
|
|
2083
|
|
|
2084 return Next_Sibling (Position);
|
|
|
2085 end Next;
|
|
|
2086
|
|
|
2087 ------------------
|
|
|
2088 -- Next_Sibling --
|
|
|
2089 ------------------
|
|
|
2090
|
|
|
2091 function Next_Sibling (Position : Cursor) return Cursor is
|
|
|
2092 begin
|
|
|
2093 if Position = No_Element then
|
|
|
2094 return No_Element;
|
|
|
2095 end if;
|
|
|
2096
|
|
|
2097 if Position.Container.Count = 0 then
|
|
|
2098 pragma Assert (Is_Root (Position));
|
|
|
2099 return No_Element;
|
|
|
2100 end if;
|
|
|
2101
|
|
|
2102 declare
|
|
|
2103 T : Tree renames Position.Container.all;
|
|
|
2104 NN : Tree_Node_Array renames T.Nodes;
|
|
|
2105 N : Tree_Node_Type renames NN (Position.Node);
|
|
|
2106
|
|
|
2107 begin
|
|
|
2108 if N.Next <= 0 then
|
|
|
2109 return No_Element;
|
|
|
2110 end if;
|
|
|
2111
|
|
|
2112 return Cursor'(Position.Container, N.Next);
|
|
|
2113 end;
|
|
|
2114 end Next_Sibling;
|
|
|
2115
|
|
|
2116 procedure Next_Sibling (Position : in out Cursor) is
|
|
|
2117 begin
|
|
|
2118 Position := Next_Sibling (Position);
|
|
|
2119 end Next_Sibling;
|
|
|
2120
|
|
|
2121 ----------------
|
|
|
2122 -- Node_Count --
|
|
|
2123 ----------------
|
|
|
2124
|
|
|
2125 function Node_Count (Container : Tree) return Count_Type is
|
|
|
2126 begin
|
|
|
2127 -- Container.Count is the number of nodes we have actually allocated. We
|
|
|
2128 -- cache the value specifically so this Node_Count operation can execute
|
|
|
2129 -- in O(1) time, which makes it behave similarly to how the Length
|
|
|
2130 -- selector function behaves for other containers.
|
|
|
2131 --
|
|
|
2132 -- The cached node count value only describes the nodes we have
|
|
|
2133 -- allocated; the root node itself is not included in that count. The
|
|
|
2134 -- Node_Count operation returns a value that includes the root node
|
|
|
2135 -- (because the RM says so), so we must add 1 to our cached value.
|
|
|
2136
|
|
|
2137 return 1 + Container.Count;
|
|
|
2138 end Node_Count;
|
|
|
2139
|
|
|
2140 ------------
|
|
|
2141 -- Parent --
|
|
|
2142 ------------
|
|
|
2143
|
|
|
2144 function Parent (Position : Cursor) return Cursor is
|
|
|
2145 begin
|
|
|
2146 if Position = No_Element then
|
|
|
2147 return No_Element;
|
|
|
2148 end if;
|
|
|
2149
|
|
|
2150 if Position.Container.Count = 0 then
|
|
|
2151 pragma Assert (Is_Root (Position));
|
|
|
2152 return No_Element;
|
|
|
2153 end if;
|
|
|
2154
|
|
|
2155 declare
|
|
|
2156 T : Tree renames Position.Container.all;
|
|
|
2157 NN : Tree_Node_Array renames T.Nodes;
|
|
|
2158 N : Tree_Node_Type renames NN (Position.Node);
|
|
|
2159
|
|
|
2160 begin
|
|
|
2161 if N.Parent < 0 then
|
|
|
2162 pragma Assert (Position.Node = Root_Node (T));
|
|
|
2163 return No_Element;
|
|
|
2164 end if;
|
|
|
2165
|
|
|
2166 return Cursor'(Position.Container, N.Parent);
|
|
|
2167 end;
|
|
|
2168 end Parent;
|
|
|
2169
|
|
|
2170 -------------------
|
|
|
2171 -- Prepend_Child --
|
|
|
2172 -------------------
|
|
|
2173
|
|
|
2174 procedure Prepend_Child
|
|
|
2175 (Container : in out Tree;
|
|
|
2176 Parent : Cursor;
|
|
|
2177 New_Item : Element_Type;
|
|
|
2178 Count : Count_Type := 1)
|
|
|
2179 is
|
|
|
2180 Nodes : Tree_Node_Array renames Container.Nodes;
|
|
|
2181 First, Last : Count_Type;
|
|
|
2182
|
|
|
2183 begin
|
|
|
2184 if Checks and then Parent = No_Element then
|
|
|
2185 raise Constraint_Error with "Parent cursor has no element";
|
|
|
2186 end if;
|
|
|
2187
|
|
|
2188 if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
|
2189 raise Program_Error with "Parent cursor not in container";
|
|
|
2190 end if;
|
|
|
2191
|
|
|
2192 if Count = 0 then
|
|
|
2193 return;
|
|
|
2194 end if;
|
|
|
2195
|
|
|
2196 if Checks and then Container.Count > Container.Capacity - Count then
|
|
|
2197 raise Capacity_Error
|
|
|
2198 with "requested count exceeds available storage";
|
|
|
2199 end if;
|
|
|
2200
|
|
|
2201 TC_Check (Container.TC);
|
|
|
2202
|
|
|
2203 if Container.Count = 0 then
|
|
|
2204 Initialize_Root (Container);
|
|
|
2205 end if;
|
|
|
2206
|
|
|
2207 Allocate_Node (Container, New_Item, First);
|
|
|
2208 Nodes (First).Parent := Parent.Node;
|
|
|
2209
|
|
|
2210 Last := First;
|
|
|
2211 for J in Count_Type'(2) .. Count loop
|
|
|
2212 Allocate_Node (Container, New_Item, Nodes (Last).Next);
|
|
|
2213 Nodes (Nodes (Last).Next).Parent := Parent.Node;
|
|
|
2214 Nodes (Nodes (Last).Next).Prev := Last;
|
|
|
2215
|
|
|
2216 Last := Nodes (Last).Next;
|
|
|
2217 end loop;
|
|
|
2218
|
|
|
2219 Insert_Subtree_List
|
|
|
2220 (Container => Container,
|
|
|
2221 First => First,
|
|
|
2222 Last => Last,
|
|
|
2223 Parent => Parent.Node,
|
|
|
2224 Before => Nodes (Parent.Node).Children.First);
|
|
|
2225
|
|
|
2226 Container.Count := Container.Count + Count;
|
|
|
2227 end Prepend_Child;
|
|
|
2228
|
|
|
2229 --------------
|
|
|
2230 -- Previous --
|
|
|
2231 --------------
|
|
|
2232
|
|
|
2233 overriding function Previous
|
|
|
2234 (Object : Child_Iterator;
|
|
|
2235 Position : Cursor) return Cursor
|
|
|
2236 is
|
|
|
2237 begin
|
|
|
2238 if Position.Container = null then
|
|
|
2239 return No_Element;
|
|
|
2240 end if;
|
|
|
2241
|
|
|
2242 if Checks and then Position.Container /= Object.Container then
|
|
|
2243 raise Program_Error with
|
|
|
2244 "Position cursor of Previous designates wrong tree";
|
|
|
2245 end if;
|
|
|
2246
|
|
|
2247 return Previous_Sibling (Position);
|
|
|
2248 end Previous;
|
|
|
2249
|
|
|
2250 ----------------------
|
|
|
2251 -- Previous_Sibling --
|
|
|
2252 ----------------------
|
|
|
2253
|
|
|
2254 function Previous_Sibling (Position : Cursor) return Cursor is
|
|
|
2255 begin
|
|
|
2256 if Position = No_Element then
|
|
|
2257 return No_Element;
|
|
|
2258 end if;
|
|
|
2259
|
|
|
2260 if Position.Container.Count = 0 then
|
|
|
2261 pragma Assert (Is_Root (Position));
|
|
|
2262 return No_Element;
|
|
|
2263 end if;
|
|
|
2264
|
|
|
2265 declare
|
|
|
2266 T : Tree renames Position.Container.all;
|
|
|
2267 NN : Tree_Node_Array renames T.Nodes;
|
|
|
2268 N : Tree_Node_Type renames NN (Position.Node);
|
|
|
2269
|
|
|
2270 begin
|
|
|
2271 if N.Prev <= 0 then
|
|
|
2272 return No_Element;
|
|
|
2273 end if;
|
|
|
2274
|
|
|
2275 return Cursor'(Position.Container, N.Prev);
|
|
|
2276 end;
|
|
|
2277 end Previous_Sibling;
|
|
|
2278
|
|
|
2279 procedure Previous_Sibling (Position : in out Cursor) is
|
|
|
2280 begin
|
|
|
2281 Position := Previous_Sibling (Position);
|
|
|
2282 end Previous_Sibling;
|
|
|
2283
|
|
|
2284 ----------------------
|
|
|
2285 -- Pseudo_Reference --
|
|
|
2286 ----------------------
|
|
|
2287
|
|
|
2288 function Pseudo_Reference
|
|
|
2289 (Container : aliased Tree'Class) return Reference_Control_Type
|
|
|
2290 is
|
|
|
2291 TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
|
|
|
2292 begin
|
|
|
2293 return R : constant Reference_Control_Type := (Controlled with TC) do
|
|
145
|
2294 Busy (TC.all);
|
|
111
|
2295 end return;
|
|
|
2296 end Pseudo_Reference;
|
|
|
2297
|
|
|
2298 -------------------
|
|
|
2299 -- Query_Element --
|
|
|
2300 -------------------
|
|
|
2301
|
|
|
2302 procedure Query_Element
|
|
|
2303 (Position : Cursor;
|
|
|
2304 Process : not null access procedure (Element : Element_Type))
|
|
|
2305 is
|
|
|
2306 begin
|
|
|
2307 if Checks and then Position = No_Element then
|
|
|
2308 raise Constraint_Error with "Position cursor has no element";
|
|
|
2309 end if;
|
|
|
2310
|
|
|
2311 if Checks and then Is_Root (Position) then
|
|
|
2312 raise Program_Error with "Position cursor designates root";
|
|
|
2313 end if;
|
|
|
2314
|
|
|
2315 declare
|
|
|
2316 T : Tree renames Position.Container.all'Unrestricted_Access.all;
|
|
|
2317 Lock : With_Lock (T.TC'Unrestricted_Access);
|
|
|
2318 begin
|
|
|
2319 Process (Element => T.Elements (Position.Node));
|
|
|
2320 end;
|
|
|
2321 end Query_Element;
|
|
|
2322
|
|
|
2323 ----------
|
|
|
2324 -- Read --
|
|
|
2325 ----------
|
|
|
2326
|
|
|
2327 procedure Read
|
|
|
2328 (Stream : not null access Root_Stream_Type'Class;
|
|
|
2329 Container : out Tree)
|
|
|
2330 is
|
|
|
2331 procedure Read_Children (Subtree : Count_Type);
|
|
|
2332
|
|
|
2333 function Read_Subtree
|
|
|
2334 (Parent : Count_Type) return Count_Type;
|
|
|
2335
|
|
|
2336 NN : Tree_Node_Array renames Container.Nodes;
|
|
|
2337
|
|
|
2338 Total_Count : Count_Type'Base;
|
|
|
2339 -- Value read from the stream that says how many elements follow
|
|
|
2340
|
|
|
2341 Read_Count : Count_Type'Base;
|
|
|
2342 -- Actual number of elements read from the stream
|
|
|
2343
|
|
|
2344 -------------------
|
|
|
2345 -- Read_Children --
|
|
|
2346 -------------------
|
|
|
2347
|
|
|
2348 procedure Read_Children (Subtree : Count_Type) is
|
|
|
2349 Count : Count_Type'Base;
|
|
|
2350 -- number of child subtrees
|
|
|
2351
|
|
|
2352 CC : Children_Type;
|
|
|
2353
|
|
|
2354 begin
|
|
|
2355 Count_Type'Read (Stream, Count);
|
|
|
2356
|
|
|
2357 if Checks and then Count < 0 then
|
|
|
2358 raise Program_Error with "attempt to read from corrupt stream";
|
|
|
2359 end if;
|
|
|
2360
|
|
|
2361 if Count = 0 then
|
|
|
2362 return;
|
|
|
2363 end if;
|
|
|
2364
|
|
|
2365 CC.First := Read_Subtree (Parent => Subtree);
|
|
|
2366 CC.Last := CC.First;
|
|
|
2367
|
|
|
2368 for J in Count_Type'(2) .. Count loop
|
|
|
2369 NN (CC.Last).Next := Read_Subtree (Parent => Subtree);
|
|
|
2370 NN (NN (CC.Last).Next).Prev := CC.Last;
|
|
|
2371 CC.Last := NN (CC.Last).Next;
|
|
|
2372 end loop;
|
|
|
2373
|
|
|
2374 -- Now that the allocation and reads have completed successfully, it
|
|
|
2375 -- is safe to link the children to their parent.
|
|
|
2376
|
|
|
2377 NN (Subtree).Children := CC;
|
|
|
2378 end Read_Children;
|
|
|
2379
|
|
|
2380 ------------------
|
|
|
2381 -- Read_Subtree --
|
|
|
2382 ------------------
|
|
|
2383
|
|
|
2384 function Read_Subtree
|
|
|
2385 (Parent : Count_Type) return Count_Type
|
|
|
2386 is
|
|
|
2387 Subtree : Count_Type;
|
|
|
2388
|
|
|
2389 begin
|
|
|
2390 Allocate_Node (Container, Stream, Subtree);
|
|
|
2391 Container.Nodes (Subtree).Parent := Parent;
|
|
|
2392
|
|
|
2393 Read_Count := Read_Count + 1;
|
|
|
2394
|
|
|
2395 Read_Children (Subtree);
|
|
|
2396
|
|
|
2397 return Subtree;
|
|
|
2398 end Read_Subtree;
|
|
|
2399
|
|
|
2400 -- Start of processing for Read
|
|
|
2401
|
|
|
2402 begin
|
|
|
2403 Container.Clear; -- checks busy bit
|
|
|
2404
|
|
|
2405 Count_Type'Read (Stream, Total_Count);
|
|
|
2406
|
|
|
2407 if Checks and then Total_Count < 0 then
|
|
|
2408 raise Program_Error with "attempt to read from corrupt stream";
|
|
|
2409 end if;
|
|
|
2410
|
|
|
2411 if Total_Count = 0 then
|
|
|
2412 return;
|
|
|
2413 end if;
|
|
|
2414
|
|
|
2415 if Checks and then Total_Count > Container.Capacity then
|
|
|
2416 raise Capacity_Error -- ???
|
|
|
2417 with "node count in stream exceeds container capacity";
|
|
|
2418 end if;
|
|
|
2419
|
|
|
2420 Initialize_Root (Container);
|
|
|
2421
|
|
|
2422 Read_Count := 0;
|
|
|
2423
|
|
|
2424 Read_Children (Root_Node (Container));
|
|
|
2425
|
|
|
2426 if Checks and then Read_Count /= Total_Count then
|
|
|
2427 raise Program_Error with "attempt to read from corrupt stream";
|
|
|
2428 end if;
|
|
|
2429
|
|
|
2430 Container.Count := Total_Count;
|
|
|
2431 end Read;
|
|
|
2432
|
|
|
2433 procedure Read
|
|
|
2434 (Stream : not null access Root_Stream_Type'Class;
|
|
|
2435 Position : out Cursor)
|
|
|
2436 is
|
|
|
2437 begin
|
|
|
2438 raise Program_Error with "attempt to read tree cursor from stream";
|
|
|
2439 end Read;
|
|
|
2440
|
|
|
2441 procedure Read
|
|
|
2442 (Stream : not null access Root_Stream_Type'Class;
|
|
|
2443 Item : out Reference_Type)
|
|
|
2444 is
|
|
|
2445 begin
|
|
|
2446 raise Program_Error with "attempt to stream reference";
|
|
|
2447 end Read;
|
|
|
2448
|
|
|
2449 procedure Read
|
|
|
2450 (Stream : not null access Root_Stream_Type'Class;
|
|
|
2451 Item : out Constant_Reference_Type)
|
|
|
2452 is
|
|
|
2453 begin
|
|
|
2454 raise Program_Error with "attempt to stream reference";
|
|
|
2455 end Read;
|
|
|
2456
|
|
|
2457 ---------------
|
|
|
2458 -- Reference --
|
|
|
2459 ---------------
|
|
|
2460
|
|
|
2461 function Reference
|
|
|
2462 (Container : aliased in out Tree;
|
|
|
2463 Position : Cursor) return Reference_Type
|
|
|
2464 is
|
|
|
2465 begin
|
|
|
2466 if Checks and then Position.Container = null then
|
|
|
2467 raise Constraint_Error with
|
|
|
2468 "Position cursor has no element";
|
|
|
2469 end if;
|
|
|
2470
|
|
|
2471 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
2472 then
|
|
|
2473 raise Program_Error with
|
|
|
2474 "Position cursor designates wrong container";
|
|
|
2475 end if;
|
|
|
2476
|
|
|
2477 if Checks and then Position.Node = Root_Node (Container) then
|
|
|
2478 raise Program_Error with "Position cursor designates root";
|
|
|
2479 end if;
|
|
|
2480
|
|
|
2481 -- Implement Vet for multiway tree???
|
|
|
2482 -- pragma Assert (Vet (Position),
|
|
|
2483 -- "Position cursor in Constant_Reference is bad");
|
|
|
2484
|
|
|
2485 declare
|
|
|
2486 TC : constant Tamper_Counts_Access :=
|
|
|
2487 Container.TC'Unrestricted_Access;
|
|
|
2488 begin
|
|
|
2489 return R : constant Reference_Type :=
|
|
|
2490 (Element => Container.Elements (Position.Node)'Access,
|
|
|
2491 Control => (Controlled with TC))
|
|
|
2492 do
|
|
145
|
2493 Busy (TC.all);
|
|
111
|
2494 end return;
|
|
|
2495 end;
|
|
|
2496 end Reference;
|
|
|
2497
|
|
|
2498 --------------------
|
|
|
2499 -- Remove_Subtree --
|
|
|
2500 --------------------
|
|
|
2501
|
|
|
2502 procedure Remove_Subtree
|
|
|
2503 (Container : in out Tree;
|
|
|
2504 Subtree : Count_Type)
|
|
|
2505 is
|
|
|
2506 NN : Tree_Node_Array renames Container.Nodes;
|
|
|
2507 N : Tree_Node_Type renames NN (Subtree);
|
|
|
2508 CC : Children_Type renames NN (N.Parent).Children;
|
|
|
2509
|
|
|
2510 begin
|
|
|
2511 -- This is a utility operation to remove a subtree node from its
|
|
|
2512 -- parent's list of children.
|
|
|
2513
|
|
|
2514 if CC.First = Subtree then
|
|
|
2515 pragma Assert (N.Prev <= 0);
|
|
|
2516
|
|
|
2517 if CC.Last = Subtree then
|
|
|
2518 pragma Assert (N.Next <= 0);
|
|
|
2519 CC.First := 0;
|
|
|
2520 CC.Last := 0;
|
|
|
2521
|
|
|
2522 else
|
|
|
2523 CC.First := N.Next;
|
|
|
2524 NN (CC.First).Prev := 0;
|
|
|
2525 end if;
|
|
|
2526
|
|
|
2527 elsif CC.Last = Subtree then
|
|
|
2528 pragma Assert (N.Next <= 0);
|
|
|
2529 CC.Last := N.Prev;
|
|
|
2530 NN (CC.Last).Next := 0;
|
|
|
2531
|
|
|
2532 else
|
|
|
2533 NN (N.Prev).Next := N.Next;
|
|
|
2534 NN (N.Next).Prev := N.Prev;
|
|
|
2535 end if;
|
|
|
2536 end Remove_Subtree;
|
|
|
2537
|
|
|
2538 ----------------------
|
|
|
2539 -- Replace_Element --
|
|
|
2540 ----------------------
|
|
|
2541
|
|
|
2542 procedure Replace_Element
|
|
|
2543 (Container : in out Tree;
|
|
|
2544 Position : Cursor;
|
|
|
2545 New_Item : Element_Type)
|
|
|
2546 is
|
|
|
2547 begin
|
|
|
2548 if Checks and then Position = No_Element then
|
|
|
2549 raise Constraint_Error with "Position cursor has no element";
|
|
|
2550 end if;
|
|
|
2551
|
|
|
2552 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
2553 then
|
|
|
2554 raise Program_Error with "Position cursor not in container";
|
|
|
2555 end if;
|
|
|
2556
|
|
|
2557 if Checks and then Is_Root (Position) then
|
|
|
2558 raise Program_Error with "Position cursor designates root";
|
|
|
2559 end if;
|
|
|
2560
|
|
|
2561 TE_Check (Container.TC);
|
|
|
2562
|
|
|
2563 Container.Elements (Position.Node) := New_Item;
|
|
|
2564 end Replace_Element;
|
|
|
2565
|
|
|
2566 ------------------------------
|
|
|
2567 -- Reverse_Iterate_Children --
|
|
|
2568 ------------------------------
|
|
|
2569
|
|
|
2570 procedure Reverse_Iterate_Children
|
|
|
2571 (Parent : Cursor;
|
|
|
2572 Process : not null access procedure (Position : Cursor))
|
|
|
2573 is
|
|
|
2574 begin
|
|
|
2575 if Checks and then Parent = No_Element then
|
|
|
2576 raise Constraint_Error with "Parent cursor has no element";
|
|
|
2577 end if;
|
|
|
2578
|
|
|
2579 if Parent.Container.Count = 0 then
|
|
|
2580 pragma Assert (Is_Root (Parent));
|
|
|
2581 return;
|
|
|
2582 end if;
|
|
|
2583
|
|
|
2584 declare
|
|
|
2585 NN : Tree_Node_Array renames Parent.Container.Nodes;
|
|
|
2586 Busy : With_Busy (Parent.Container.TC'Unrestricted_Access);
|
|
|
2587 C : Count_Type;
|
|
|
2588
|
|
|
2589 begin
|
|
|
2590 C := NN (Parent.Node).Children.Last;
|
|
|
2591 while C > 0 loop
|
|
|
2592 Process (Cursor'(Parent.Container, Node => C));
|
|
|
2593 C := NN (C).Prev;
|
|
|
2594 end loop;
|
|
|
2595 end;
|
|
|
2596 end Reverse_Iterate_Children;
|
|
|
2597
|
|
|
2598 ----------
|
|
|
2599 -- Root --
|
|
|
2600 ----------
|
|
|
2601
|
|
|
2602 function Root (Container : Tree) return Cursor is
|
|
|
2603 begin
|
|
|
2604 return (Container'Unrestricted_Access, Root_Node (Container));
|
|
|
2605 end Root;
|
|
|
2606
|
|
|
2607 ---------------
|
|
|
2608 -- Root_Node --
|
|
|
2609 ---------------
|
|
|
2610
|
|
|
2611 function Root_Node (Container : Tree) return Count_Type is
|
|
|
2612 pragma Unreferenced (Container);
|
|
|
2613
|
|
|
2614 begin
|
|
|
2615 return 0;
|
|
|
2616 end Root_Node;
|
|
|
2617
|
|
|
2618 ---------------------
|
|
|
2619 -- Splice_Children --
|
|
|
2620 ---------------------
|
|
|
2621
|
|
|
2622 procedure Splice_Children
|
|
|
2623 (Target : in out Tree;
|
|
|
2624 Target_Parent : Cursor;
|
|
|
2625 Before : Cursor;
|
|
|
2626 Source : in out Tree;
|
|
|
2627 Source_Parent : Cursor)
|
|
|
2628 is
|
|
|
2629 begin
|
|
|
2630 if Checks and then Target_Parent = No_Element then
|
|
|
2631 raise Constraint_Error with "Target_Parent cursor has no element";
|
|
|
2632 end if;
|
|
|
2633
|
|
|
2634 if Checks and then Target_Parent.Container /= Target'Unrestricted_Access
|
|
|
2635 then
|
|
|
2636 raise Program_Error
|
|
|
2637 with "Target_Parent cursor not in Target container";
|
|
|
2638 end if;
|
|
|
2639
|
|
|
2640 if Before /= No_Element then
|
|
|
2641 if Checks and then Before.Container /= Target'Unrestricted_Access then
|
|
|
2642 raise Program_Error
|
|
|
2643 with "Before cursor not in Target container";
|
|
|
2644 end if;
|
|
|
2645
|
|
|
2646 if Checks and then
|
|
|
2647 Target.Nodes (Before.Node).Parent /= Target_Parent.Node
|
|
|
2648 then
|
|
|
2649 raise Constraint_Error
|
|
|
2650 with "Before cursor not child of Target_Parent";
|
|
|
2651 end if;
|
|
|
2652 end if;
|
|
|
2653
|
|
|
2654 if Checks and then Source_Parent = No_Element then
|
|
|
2655 raise Constraint_Error with "Source_Parent cursor has no element";
|
|
|
2656 end if;
|
|
|
2657
|
|
|
2658 if Checks and then Source_Parent.Container /= Source'Unrestricted_Access
|
|
|
2659 then
|
|
|
2660 raise Program_Error
|
|
|
2661 with "Source_Parent cursor not in Source container";
|
|
|
2662 end if;
|
|
|
2663
|
|
|
2664 if Source.Count = 0 then
|
|
|
2665 pragma Assert (Is_Root (Source_Parent));
|
|
|
2666 return;
|
|
|
2667 end if;
|
|
|
2668
|
|
|
2669 if Target'Address = Source'Address then
|
|
|
2670 if Target_Parent = Source_Parent then
|
|
|
2671 return;
|
|
|
2672 end if;
|
|
|
2673
|
|
|
2674 TC_Check (Target.TC);
|
|
|
2675
|
|
|
2676 if Checks and then Is_Reachable (Container => Target,
|
|
|
2677 From => Target_Parent.Node,
|
|
|
2678 To => Source_Parent.Node)
|
|
|
2679 then
|
|
|
2680 raise Constraint_Error
|
|
|
2681 with "Source_Parent is ancestor of Target_Parent";
|
|
|
2682 end if;
|
|
|
2683
|
|
|
2684 Splice_Children
|
|
|
2685 (Container => Target,
|
|
|
2686 Target_Parent => Target_Parent.Node,
|
|
|
2687 Before => Before.Node,
|
|
|
2688 Source_Parent => Source_Parent.Node);
|
|
|
2689
|
|
|
2690 return;
|
|
|
2691 end if;
|
|
|
2692
|
|
|
2693 TC_Check (Target.TC);
|
|
|
2694 TC_Check (Source.TC);
|
|
|
2695
|
|
|
2696 if Target.Count = 0 then
|
|
|
2697 Initialize_Root (Target);
|
|
|
2698 end if;
|
|
|
2699
|
|
|
2700 Splice_Children
|
|
|
2701 (Target => Target,
|
|
|
2702 Target_Parent => Target_Parent.Node,
|
|
|
2703 Before => Before.Node,
|
|
|
2704 Source => Source,
|
|
|
2705 Source_Parent => Source_Parent.Node);
|
|
|
2706 end Splice_Children;
|
|
|
2707
|
|
|
2708 procedure Splice_Children
|
|
|
2709 (Container : in out Tree;
|
|
|
2710 Target_Parent : Cursor;
|
|
|
2711 Before : Cursor;
|
|
|
2712 Source_Parent : Cursor)
|
|
|
2713 is
|
|
|
2714 begin
|
|
|
2715 if Checks and then Target_Parent = No_Element then
|
|
|
2716 raise Constraint_Error with "Target_Parent cursor has no element";
|
|
|
2717 end if;
|
|
|
2718
|
|
|
2719 if Checks and then
|
|
|
2720 Target_Parent.Container /= Container'Unrestricted_Access
|
|
|
2721 then
|
|
|
2722 raise Program_Error
|
|
|
2723 with "Target_Parent cursor not in container";
|
|
|
2724 end if;
|
|
|
2725
|
|
|
2726 if Before /= No_Element then
|
|
|
2727 if Checks and then Before.Container /= Container'Unrestricted_Access
|
|
|
2728 then
|
|
|
2729 raise Program_Error
|
|
|
2730 with "Before cursor not in container";
|
|
|
2731 end if;
|
|
|
2732
|
|
|
2733 if Checks and then
|
|
|
2734 Container.Nodes (Before.Node).Parent /= Target_Parent.Node
|
|
|
2735 then
|
|
|
2736 raise Constraint_Error
|
|
|
2737 with "Before cursor not child of Target_Parent";
|
|
|
2738 end if;
|
|
|
2739 end if;
|
|
|
2740
|
|
|
2741 if Checks and then Source_Parent = No_Element then
|
|
|
2742 raise Constraint_Error with "Source_Parent cursor has no element";
|
|
|
2743 end if;
|
|
|
2744
|
|
|
2745 if Checks and then
|
|
|
2746 Source_Parent.Container /= Container'Unrestricted_Access
|
|
|
2747 then
|
|
|
2748 raise Program_Error
|
|
|
2749 with "Source_Parent cursor not in container";
|
|
|
2750 end if;
|
|
|
2751
|
|
|
2752 if Target_Parent = Source_Parent then
|
|
|
2753 return;
|
|
|
2754 end if;
|
|
|
2755
|
|
|
2756 pragma Assert (Container.Count > 0);
|
|
|
2757
|
|
|
2758 TC_Check (Container.TC);
|
|
|
2759
|
|
|
2760 if Checks and then Is_Reachable (Container => Container,
|
|
|
2761 From => Target_Parent.Node,
|
|
|
2762 To => Source_Parent.Node)
|
|
|
2763 then
|
|
|
2764 raise Constraint_Error
|
|
|
2765 with "Source_Parent is ancestor of Target_Parent";
|
|
|
2766 end if;
|
|
|
2767
|
|
|
2768 Splice_Children
|
|
|
2769 (Container => Container,
|
|
|
2770 Target_Parent => Target_Parent.Node,
|
|
|
2771 Before => Before.Node,
|
|
|
2772 Source_Parent => Source_Parent.Node);
|
|
|
2773 end Splice_Children;
|
|
|
2774
|
|
|
2775 procedure Splice_Children
|
|
|
2776 (Container : in out Tree;
|
|
|
2777 Target_Parent : Count_Type;
|
|
|
2778 Before : Count_Type'Base;
|
|
|
2779 Source_Parent : Count_Type)
|
|
|
2780 is
|
|
|
2781 NN : Tree_Node_Array renames Container.Nodes;
|
|
|
2782 CC : constant Children_Type := NN (Source_Parent).Children;
|
|
|
2783 C : Count_Type'Base;
|
|
|
2784
|
|
|
2785 begin
|
|
|
2786 -- This is a utility operation to remove the children from Source parent
|
|
|
2787 -- and insert them into Target parent.
|
|
|
2788
|
|
|
2789 NN (Source_Parent).Children := Children_Type'(others => 0);
|
|
|
2790
|
|
|
2791 -- Fix up the Parent pointers of each child to designate its new Target
|
|
|
2792 -- parent.
|
|
|
2793
|
|
|
2794 C := CC.First;
|
|
|
2795 while C > 0 loop
|
|
|
2796 NN (C).Parent := Target_Parent;
|
|
|
2797 C := NN (C).Next;
|
|
|
2798 end loop;
|
|
|
2799
|
|
|
2800 Insert_Subtree_List
|
|
|
2801 (Container => Container,
|
|
|
2802 First => CC.First,
|
|
|
2803 Last => CC.Last,
|
|
|
2804 Parent => Target_Parent,
|
|
|
2805 Before => Before);
|
|
|
2806 end Splice_Children;
|
|
|
2807
|
|
|
2808 procedure Splice_Children
|
|
|
2809 (Target : in out Tree;
|
|
|
2810 Target_Parent : Count_Type;
|
|
|
2811 Before : Count_Type'Base;
|
|
|
2812 Source : in out Tree;
|
|
|
2813 Source_Parent : Count_Type)
|
|
|
2814 is
|
|
|
2815 S_NN : Tree_Node_Array renames Source.Nodes;
|
|
|
2816 S_CC : Children_Type renames S_NN (Source_Parent).Children;
|
|
|
2817
|
|
|
2818 Target_Count, Source_Count : Count_Type;
|
|
|
2819 T, S : Count_Type'Base;
|
|
|
2820
|
|
|
2821 begin
|
|
|
2822 -- This is a utility operation to copy the children from the Source
|
|
|
2823 -- parent and insert them as children of the Target parent, and then
|
|
|
2824 -- delete them from the Source. (This is not a true splice operation,
|
|
|
2825 -- but it is the best we can do in a bounded form.) The Before position
|
|
|
2826 -- specifies where among the Target parent's exising children the new
|
|
|
2827 -- children are inserted.
|
|
|
2828
|
|
|
2829 -- Before we attempt the insertion, we must count the sources nodes in
|
|
|
2830 -- order to determine whether the target have enough storage
|
|
|
2831 -- available. Note that calculating this value is an O(n) operation.
|
|
|
2832
|
|
|
2833 -- Here is an optimization opportunity: iterate of each children the
|
|
|
2834 -- source explicitly, and keep a running count of the total number of
|
|
|
2835 -- nodes. Compare the running total to the capacity of the target each
|
|
|
2836 -- pass through the loop. This is more efficient than summing the counts
|
|
|
2837 -- of child subtree (which is what Subtree_Node_Count does) and then
|
|
|
2838 -- comparing that total sum to the target's capacity. ???
|
|
|
2839
|
|
|
2840 -- Here is another possibility. We currently treat the splice as an
|
|
|
2841 -- all-or-nothing proposition: either we can insert all of children of
|
|
|
2842 -- the source, or we raise exception with modifying the target. The
|
|
|
2843 -- price for not causing side-effect is an O(n) determination of the
|
|
|
2844 -- source count. If we are willing to tolerate side-effect, then we
|
|
|
2845 -- could loop over the children of the source, counting that subtree and
|
|
|
2846 -- then immediately inserting it in the target. The issue here is that
|
|
|
2847 -- the test for available storage could fail during some later pass,
|
|
|
2848 -- after children have already been inserted into target. ???
|
|
|
2849
|
|
|
2850 Source_Count := Subtree_Node_Count (Source, Source_Parent) - 1;
|
|
|
2851
|
|
|
2852 if Source_Count = 0 then
|
|
|
2853 return;
|
|
|
2854 end if;
|
|
|
2855
|
|
|
2856 if Checks and then Target.Count > Target.Capacity - Source_Count then
|
|
|
2857 raise Capacity_Error -- ???
|
|
|
2858 with "Source count exceeds available storage on Target";
|
|
|
2859 end if;
|
|
|
2860
|
|
|
2861 -- Copy_Subtree returns a count of the number of nodes it inserts, but
|
|
|
2862 -- it does this by incrementing the value passed in. Therefore we must
|
|
|
2863 -- initialize the count before calling Copy_Subtree.
|
|
|
2864
|
|
|
2865 Target_Count := 0;
|
|
|
2866
|
|
|
2867 S := S_CC.First;
|
|
|
2868 while S > 0 loop
|
|
|
2869 Copy_Subtree
|
|
|
2870 (Source => Source,
|
|
|
2871 Source_Subtree => S,
|
|
|
2872 Target => Target,
|
|
|
2873 Target_Parent => Target_Parent,
|
|
|
2874 Target_Subtree => T,
|
|
|
2875 Count => Target_Count);
|
|
|
2876
|
|
|
2877 Insert_Subtree_Node
|
|
|
2878 (Container => Target,
|
|
|
2879 Subtree => T,
|
|
|
2880 Parent => Target_Parent,
|
|
|
2881 Before => Before);
|
|
|
2882
|
|
|
2883 S := S_NN (S).Next;
|
|
|
2884 end loop;
|
|
|
2885
|
|
|
2886 pragma Assert (Target_Count = Source_Count);
|
|
|
2887 Target.Count := Target.Count + Target_Count;
|
|
|
2888
|
|
|
2889 -- As with Copy_Subtree, operation Deallocate_Children returns a count
|
|
|
2890 -- of the number of nodes it deallocates, but it works by incrementing
|
|
|
2891 -- the value passed in. We must therefore initialize the count before
|
|
|
2892 -- calling it.
|
|
|
2893
|
|
|
2894 Source_Count := 0;
|
|
|
2895
|
|
|
2896 Deallocate_Children (Source, Source_Parent, Source_Count);
|
|
|
2897 pragma Assert (Source_Count = Target_Count);
|
|
|
2898
|
|
|
2899 Source.Count := Source.Count - Source_Count;
|
|
|
2900 end Splice_Children;
|
|
|
2901
|
|
|
2902 --------------------
|
|
|
2903 -- Splice_Subtree --
|
|
|
2904 --------------------
|
|
|
2905
|
|
|
2906 procedure Splice_Subtree
|
|
|
2907 (Target : in out Tree;
|
|
|
2908 Parent : Cursor;
|
|
|
2909 Before : Cursor;
|
|
|
2910 Source : in out Tree;
|
|
|
2911 Position : in out Cursor)
|
|
|
2912 is
|
|
|
2913 begin
|
|
|
2914 if Checks and then Parent = No_Element then
|
|
|
2915 raise Constraint_Error with "Parent cursor has no element";
|
|
|
2916 end if;
|
|
|
2917
|
|
|
2918 if Checks and then Parent.Container /= Target'Unrestricted_Access then
|
|
|
2919 raise Program_Error with "Parent cursor not in Target container";
|
|
|
2920 end if;
|
|
|
2921
|
|
|
2922 if Before /= No_Element then
|
|
|
2923 if Checks and then Before.Container /= Target'Unrestricted_Access then
|
|
|
2924 raise Program_Error with "Before cursor not in Target container";
|
|
|
2925 end if;
|
|
|
2926
|
|
|
2927 if Checks and then Target.Nodes (Before.Node).Parent /= Parent.Node
|
|
|
2928 then
|
|
|
2929 raise Constraint_Error with "Before cursor not child of Parent";
|
|
|
2930 end if;
|
|
|
2931 end if;
|
|
|
2932
|
|
|
2933 if Checks and then Position = No_Element then
|
|
|
2934 raise Constraint_Error with "Position cursor has no element";
|
|
|
2935 end if;
|
|
|
2936
|
|
|
2937 if Checks and then Position.Container /= Source'Unrestricted_Access then
|
|
|
2938 raise Program_Error with "Position cursor not in Source container";
|
|
|
2939 end if;
|
|
|
2940
|
|
|
2941 if Checks and then Is_Root (Position) then
|
|
|
2942 raise Program_Error with "Position cursor designates root";
|
|
|
2943 end if;
|
|
|
2944
|
|
|
2945 if Target'Address = Source'Address then
|
|
|
2946 if Target.Nodes (Position.Node).Parent = Parent.Node then
|
|
|
2947 if Before = No_Element then
|
|
|
2948 if Target.Nodes (Position.Node).Next <= 0 then -- last child
|
|
|
2949 return;
|
|
|
2950 end if;
|
|
|
2951
|
|
|
2952 elsif Position.Node = Before.Node then
|
|
|
2953 return;
|
|
|
2954
|
|
|
2955 elsif Target.Nodes (Position.Node).Next = Before.Node then
|
|
|
2956 return;
|
|
|
2957 end if;
|
|
|
2958 end if;
|
|
|
2959
|
|
|
2960 TC_Check (Target.TC);
|
|
|
2961
|
|
|
2962 if Checks and then Is_Reachable (Container => Target,
|
|
|
2963 From => Parent.Node,
|
|
|
2964 To => Position.Node)
|
|
|
2965 then
|
|
|
2966 raise Constraint_Error with "Position is ancestor of Parent";
|
|
|
2967 end if;
|
|
|
2968
|
|
|
2969 Remove_Subtree (Target, Position.Node);
|
|
|
2970
|
|
|
2971 Target.Nodes (Position.Node).Parent := Parent.Node;
|
|
|
2972 Insert_Subtree_Node (Target, Position.Node, Parent.Node, Before.Node);
|
|
|
2973
|
|
|
2974 return;
|
|
|
2975 end if;
|
|
|
2976
|
|
|
2977 TC_Check (Target.TC);
|
|
|
2978 TC_Check (Source.TC);
|
|
|
2979
|
|
|
2980 if Target.Count = 0 then
|
|
|
2981 Initialize_Root (Target);
|
|
|
2982 end if;
|
|
|
2983
|
|
|
2984 Splice_Subtree
|
|
|
2985 (Target => Target,
|
|
|
2986 Parent => Parent.Node,
|
|
|
2987 Before => Before.Node,
|
|
|
2988 Source => Source,
|
|
|
2989 Position => Position.Node); -- modified during call
|
|
|
2990
|
|
|
2991 Position.Container := Target'Unrestricted_Access;
|
|
|
2992 end Splice_Subtree;
|
|
|
2993
|
|
|
2994 procedure Splice_Subtree
|
|
|
2995 (Container : in out Tree;
|
|
|
2996 Parent : Cursor;
|
|
|
2997 Before : Cursor;
|
|
|
2998 Position : Cursor)
|
|
|
2999 is
|
|
|
3000 begin
|
|
|
3001 if Checks and then Parent = No_Element then
|
|
|
3002 raise Constraint_Error with "Parent cursor has no element";
|
|
|
3003 end if;
|
|
|
3004
|
|
|
3005 if Checks and then Parent.Container /= Container'Unrestricted_Access then
|
|
|
3006 raise Program_Error with "Parent cursor not in container";
|
|
|
3007 end if;
|
|
|
3008
|
|
|
3009 if Before /= No_Element then
|
|
|
3010 if Checks and then Before.Container /= Container'Unrestricted_Access
|
|
|
3011 then
|
|
|
3012 raise Program_Error with "Before cursor not in container";
|
|
|
3013 end if;
|
|
|
3014
|
|
|
3015 if Checks and then Container.Nodes (Before.Node).Parent /= Parent.Node
|
|
|
3016 then
|
|
|
3017 raise Constraint_Error with "Before cursor not child of Parent";
|
|
|
3018 end if;
|
|
|
3019 end if;
|
|
|
3020
|
|
|
3021 if Checks and then Position = No_Element then
|
|
|
3022 raise Constraint_Error with "Position cursor has no element";
|
|
|
3023 end if;
|
|
|
3024
|
|
|
3025 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
3026 then
|
|
|
3027 raise Program_Error with "Position cursor not in container";
|
|
|
3028 end if;
|
|
|
3029
|
|
|
3030 if Checks and then Is_Root (Position) then
|
|
|
3031
|
|
|
3032 -- Should this be PE instead? Need ARG confirmation. ???
|
|
|
3033
|
|
|
3034 raise Constraint_Error with "Position cursor designates root";
|
|
|
3035 end if;
|
|
|
3036
|
|
|
3037 if Container.Nodes (Position.Node).Parent = Parent.Node then
|
|
|
3038 if Before = No_Element then
|
|
|
3039 if Container.Nodes (Position.Node).Next <= 0 then -- last child
|
|
|
3040 return;
|
|
|
3041 end if;
|
|
|
3042
|
|
|
3043 elsif Position.Node = Before.Node then
|
|
|
3044 return;
|
|
|
3045
|
|
|
3046 elsif Container.Nodes (Position.Node).Next = Before.Node then
|
|
|
3047 return;
|
|
|
3048 end if;
|
|
|
3049 end if;
|
|
|
3050
|
|
|
3051 TC_Check (Container.TC);
|
|
|
3052
|
|
|
3053 if Checks and then Is_Reachable (Container => Container,
|
|
|
3054 From => Parent.Node,
|
|
|
3055 To => Position.Node)
|
|
|
3056 then
|
|
|
3057 raise Constraint_Error with "Position is ancestor of Parent";
|
|
|
3058 end if;
|
|
|
3059
|
|
|
3060 Remove_Subtree (Container, Position.Node);
|
|
|
3061 Container.Nodes (Position.Node).Parent := Parent.Node;
|
|
|
3062 Insert_Subtree_Node (Container, Position.Node, Parent.Node, Before.Node);
|
|
|
3063 end Splice_Subtree;
|
|
|
3064
|
|
|
3065 procedure Splice_Subtree
|
|
|
3066 (Target : in out Tree;
|
|
|
3067 Parent : Count_Type;
|
|
|
3068 Before : Count_Type'Base;
|
|
|
3069 Source : in out Tree;
|
|
|
3070 Position : in out Count_Type) -- Source on input, Target on output
|
|
|
3071 is
|
|
|
3072 Source_Count : Count_Type := Subtree_Node_Count (Source, Position);
|
|
|
3073 pragma Assert (Source_Count >= 1);
|
|
|
3074
|
|
|
3075 Target_Subtree : Count_Type;
|
|
|
3076 Target_Count : Count_Type;
|
|
|
3077
|
|
|
3078 begin
|
|
|
3079 -- This is a utility operation to do the heavy lifting associated with
|
|
|
3080 -- splicing a subtree from one tree to another. Note that "splicing"
|
|
|
3081 -- is a bit of a misnomer here in the case of a bounded tree, because
|
|
|
3082 -- the elements must be copied from the source to the target.
|
|
|
3083
|
|
|
3084 if Checks and then Target.Count > Target.Capacity - Source_Count then
|
|
|
3085 raise Capacity_Error -- ???
|
|
|
3086 with "Source count exceeds available storage on Target";
|
|
|
3087 end if;
|
|
|
3088
|
|
|
3089 -- Copy_Subtree returns a count of the number of nodes it inserts, but
|
|
|
3090 -- it does this by incrementing the value passed in. Therefore we must
|
|
|
3091 -- initialize the count before calling Copy_Subtree.
|
|
|
3092
|
|
|
3093 Target_Count := 0;
|
|
|
3094
|
|
|
3095 Copy_Subtree
|
|
|
3096 (Source => Source,
|
|
|
3097 Source_Subtree => Position,
|
|
|
3098 Target => Target,
|
|
|
3099 Target_Parent => Parent,
|
|
|
3100 Target_Subtree => Target_Subtree,
|
|
|
3101 Count => Target_Count);
|
|
|
3102
|
|
|
3103 pragma Assert (Target_Count = Source_Count);
|
|
|
3104
|
|
|
3105 -- Now link the newly-allocated subtree into the target.
|
|
|
3106
|
|
|
3107 Insert_Subtree_Node
|
|
|
3108 (Container => Target,
|
|
|
3109 Subtree => Target_Subtree,
|
|
|
3110 Parent => Parent,
|
|
|
3111 Before => Before);
|
|
|
3112
|
|
|
3113 Target.Count := Target.Count + Target_Count;
|
|
|
3114
|
|
|
3115 -- The manipulation of the Target container is complete. Now we remove
|
|
|
3116 -- the subtree from the Source container.
|
|
|
3117
|
|
|
3118 Remove_Subtree (Source, Position); -- unlink the subtree
|
|
|
3119
|
|
|
3120 -- As with Copy_Subtree, operation Deallocate_Subtree returns a count of
|
|
|
3121 -- the number of nodes it deallocates, but it works by incrementing the
|
|
|
3122 -- value passed in. We must therefore initialize the count before
|
|
|
3123 -- calling it.
|
|
|
3124
|
|
|
3125 Source_Count := 0;
|
|
|
3126
|
|
|
3127 Deallocate_Subtree (Source, Position, Source_Count);
|
|
|
3128 pragma Assert (Source_Count = Target_Count);
|
|
|
3129
|
|
|
3130 Source.Count := Source.Count - Source_Count;
|
|
|
3131
|
|
|
3132 Position := Target_Subtree;
|
|
|
3133 end Splice_Subtree;
|
|
|
3134
|
|
|
3135 ------------------------
|
|
|
3136 -- Subtree_Node_Count --
|
|
|
3137 ------------------------
|
|
|
3138
|
|
|
3139 function Subtree_Node_Count (Position : Cursor) return Count_Type is
|
|
|
3140 begin
|
|
|
3141 if Position = No_Element then
|
|
|
3142 return 0;
|
|
|
3143 end if;
|
|
|
3144
|
|
|
3145 if Position.Container.Count = 0 then
|
|
|
3146 pragma Assert (Is_Root (Position));
|
|
|
3147 return 1;
|
|
|
3148 end if;
|
|
|
3149
|
|
|
3150 return Subtree_Node_Count (Position.Container.all, Position.Node);
|
|
|
3151 end Subtree_Node_Count;
|
|
|
3152
|
|
|
3153 function Subtree_Node_Count
|
|
|
3154 (Container : Tree;
|
|
|
3155 Subtree : Count_Type) return Count_Type
|
|
|
3156 is
|
|
|
3157 Result : Count_Type;
|
|
|
3158 Node : Count_Type'Base;
|
|
|
3159
|
|
|
3160 begin
|
|
|
3161 Result := 1;
|
|
|
3162 Node := Container.Nodes (Subtree).Children.First;
|
|
|
3163 while Node > 0 loop
|
|
|
3164 Result := Result + Subtree_Node_Count (Container, Node);
|
|
|
3165 Node := Container.Nodes (Node).Next;
|
|
|
3166 end loop;
|
|
|
3167 return Result;
|
|
|
3168 end Subtree_Node_Count;
|
|
|
3169
|
|
|
3170 ----------
|
|
|
3171 -- Swap --
|
|
|
3172 ----------
|
|
|
3173
|
|
|
3174 procedure Swap
|
|
|
3175 (Container : in out Tree;
|
|
|
3176 I, J : Cursor)
|
|
|
3177 is
|
|
|
3178 begin
|
|
|
3179 if Checks and then I = No_Element then
|
|
|
3180 raise Constraint_Error with "I cursor has no element";
|
|
|
3181 end if;
|
|
|
3182
|
|
|
3183 if Checks and then I.Container /= Container'Unrestricted_Access then
|
|
|
3184 raise Program_Error with "I cursor not in container";
|
|
|
3185 end if;
|
|
|
3186
|
|
|
3187 if Checks and then Is_Root (I) then
|
|
|
3188 raise Program_Error with "I cursor designates root";
|
|
|
3189 end if;
|
|
|
3190
|
|
|
3191 if I = J then -- make this test sooner???
|
|
|
3192 return;
|
|
|
3193 end if;
|
|
|
3194
|
|
|
3195 if Checks and then J = No_Element then
|
|
|
3196 raise Constraint_Error with "J cursor has no element";
|
|
|
3197 end if;
|
|
|
3198
|
|
|
3199 if Checks and then J.Container /= Container'Unrestricted_Access then
|
|
|
3200 raise Program_Error with "J cursor not in container";
|
|
|
3201 end if;
|
|
|
3202
|
|
|
3203 if Checks and then Is_Root (J) then
|
|
|
3204 raise Program_Error with "J cursor designates root";
|
|
|
3205 end if;
|
|
|
3206
|
|
|
3207 TE_Check (Container.TC);
|
|
|
3208
|
|
|
3209 declare
|
|
|
3210 EE : Element_Array renames Container.Elements;
|
|
|
3211 EI : constant Element_Type := EE (I.Node);
|
|
|
3212
|
|
|
3213 begin
|
|
|
3214 EE (I.Node) := EE (J.Node);
|
|
|
3215 EE (J.Node) := EI;
|
|
|
3216 end;
|
|
|
3217 end Swap;
|
|
|
3218
|
|
|
3219 --------------------
|
|
|
3220 -- Update_Element --
|
|
|
3221 --------------------
|
|
|
3222
|
|
|
3223 procedure Update_Element
|
|
|
3224 (Container : in out Tree;
|
|
|
3225 Position : Cursor;
|
|
|
3226 Process : not null access procedure (Element : in out Element_Type))
|
|
|
3227 is
|
|
|
3228 begin
|
|
|
3229 if Checks and then Position = No_Element then
|
|
|
3230 raise Constraint_Error with "Position cursor has no element";
|
|
|
3231 end if;
|
|
|
3232
|
|
|
3233 if Checks and then Position.Container /= Container'Unrestricted_Access
|
|
|
3234 then
|
|
|
3235 raise Program_Error with "Position cursor not in container";
|
|
|
3236 end if;
|
|
|
3237
|
|
|
3238 if Checks and then Is_Root (Position) then
|
|
|
3239 raise Program_Error with "Position cursor designates root";
|
|
|
3240 end if;
|
|
|
3241
|
|
|
3242 declare
|
|
|
3243 T : Tree renames Position.Container.all'Unrestricted_Access.all;
|
|
|
3244 Lock : With_Lock (T.TC'Unrestricted_Access);
|
|
|
3245 begin
|
|
|
3246 Process (Element => T.Elements (Position.Node));
|
|
|
3247 end;
|
|
|
3248 end Update_Element;
|
|
|
3249
|
|
|
3250 -----------
|
|
|
3251 -- Write --
|
|
|
3252 -----------
|
|
|
3253
|
|
|
3254 procedure Write
|
|
|
3255 (Stream : not null access Root_Stream_Type'Class;
|
|
|
3256 Container : Tree)
|
|
|
3257 is
|
|
|
3258 procedure Write_Children (Subtree : Count_Type);
|
|
|
3259 procedure Write_Subtree (Subtree : Count_Type);
|
|
|
3260
|
|
|
3261 --------------------
|
|
|
3262 -- Write_Children --
|
|
|
3263 --------------------
|
|
|
3264
|
|
|
3265 procedure Write_Children (Subtree : Count_Type) is
|
|
|
3266 CC : Children_Type renames Container.Nodes (Subtree).Children;
|
|
|
3267 C : Count_Type'Base;
|
|
|
3268
|
|
|
3269 begin
|
|
|
3270 Count_Type'Write (Stream, Child_Count (Container, Subtree));
|
|
|
3271
|
|
|
3272 C := CC.First;
|
|
|
3273 while C > 0 loop
|
|
|
3274 Write_Subtree (C);
|
|
|
3275 C := Container.Nodes (C).Next;
|
|
|
3276 end loop;
|
|
|
3277 end Write_Children;
|
|
|
3278
|
|
|
3279 -------------------
|
|
|
3280 -- Write_Subtree --
|
|
|
3281 -------------------
|
|
|
3282
|
|
|
3283 procedure Write_Subtree (Subtree : Count_Type) is
|
|
|
3284 begin
|
|
|
3285 Element_Type'Write (Stream, Container.Elements (Subtree));
|
|
|
3286 Write_Children (Subtree);
|
|
|
3287 end Write_Subtree;
|
|
|
3288
|
|
|
3289 -- Start of processing for Write
|
|
|
3290
|
|
|
3291 begin
|
|
|
3292 Count_Type'Write (Stream, Container.Count);
|
|
|
3293
|
|
|
3294 if Container.Count = 0 then
|
|
|
3295 return;
|
|
|
3296 end if;
|
|
|
3297
|
|
|
3298 Write_Children (Root_Node (Container));
|
|
|
3299 end Write;
|
|
|
3300
|
|
|
3301 procedure Write
|
|
|
3302 (Stream : not null access Root_Stream_Type'Class;
|
|
|
3303 Position : Cursor)
|
|
|
3304 is
|
|
|
3305 begin
|
|
|
3306 raise Program_Error with "attempt to write tree cursor to stream";
|
|
|
3307 end Write;
|
|
|
3308
|
|
|
3309 procedure Write
|
|
|
3310 (Stream : not null access Root_Stream_Type'Class;
|
|
|
3311 Item : Reference_Type)
|
|
|
3312 is
|
|
|
3313 begin
|
|
|
3314 raise Program_Error with "attempt to stream reference";
|
|
|
3315 end Write;
|
|
|
3316
|
|
|
3317 procedure Write
|
|
|
3318 (Stream : not null access Root_Stream_Type'Class;
|
|
|
3319 Item : Constant_Reference_Type)
|
|
|
3320 is
|
|
|
3321 begin
|
|
|
3322 raise Program_Error with "attempt to stream reference";
|
|
|
3323 end Write;
|
|
|
3324
|
|
|
3325 end Ada.Containers.Bounded_Multiway_Trees;
|
