annotate gcc/ada/libgnat/a-cimutr.adb @ 131:84e7813d76e9

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