1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . M U L T I W A Y _ T R E E S --
9 -- Copyright (C) 2004-2023, Free Software Foundation, Inc. --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the contents of the part following the private keyword. --
15 -- GNAT is free software; you can redistribute it and/or modify it under --
16 -- terms of the GNU General Public License as published by the Free Soft- --
17 -- ware Foundation; either version 3, or (at your option) any later ver- --
18 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE. --
22 -- As a special exception under Section 7 of GPL version 3, you are granted --
23 -- additional permissions described in the GCC Runtime Library Exception, --
24 -- version 3.1, as published by the Free Software Foundation. --
26 -- You should have received a copy of the GNU General Public License and --
27 -- a copy of the GCC Runtime Library Exception along with this program; --
28 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
29 -- <http://www.gnu.org/licenses/>. --
31 -- This unit was originally developed by Matthew J Heaney. --
32 ------------------------------------------------------------------------------
34 with Ada
.Iterator_Interfaces
;
36 with Ada
.Containers
.Helpers
;
37 private with Ada
.Finalization
;
38 private with Ada
.Streams
;
39 private with Ada
.Strings
.Text_Buffers
;
42 type Element_Type
is private;
44 with function "=" (Left
, Right
: Element_Type
) return Boolean is <>;
46 package Ada
.Containers
.Multiway_Trees
with
49 pragma Annotate
(CodePeer
, Skip_Analysis
);
53 type Tree
is tagged private
54 with Constant_Indexing
=> Constant_Reference
,
55 Variable_Indexing
=> Reference
,
56 Default_Iterator
=> Iterate
,
57 Iterator_Element
=> Element_Type
;
58 pragma Preelaborable_Initialization
(Tree
);
60 type Cursor
is private;
61 pragma Preelaborable_Initialization
(Cursor
);
63 Empty_Tree
: constant Tree
;
65 No_Element
: constant Cursor
;
66 function Has_Element
(Position
: Cursor
) return Boolean;
68 package Tree_Iterator_Interfaces
is new
69 Ada
.Iterator_Interfaces
(Cursor
, Has_Element
);
71 function Equal_Subtree
72 (Left_Position
: Cursor
;
73 Right_Position
: Cursor
) return Boolean;
75 function "=" (Left
, Right
: Tree
) return Boolean;
77 function Is_Empty
(Container
: Tree
) return Boolean;
79 function Node_Count
(Container
: Tree
) return Count_Type
;
81 function Subtree_Node_Count
(Position
: Cursor
) return Count_Type
;
83 function Depth
(Position
: Cursor
) return Count_Type
;
85 function Is_Root
(Position
: Cursor
) return Boolean;
87 function Is_Leaf
(Position
: Cursor
) return Boolean;
89 function Root
(Container
: Tree
) return Cursor
;
91 procedure Clear
(Container
: in out Tree
);
93 function Element
(Position
: Cursor
) return Element_Type
;
95 procedure Replace_Element
96 (Container
: in out Tree
;
98 New_Item
: Element_Type
);
100 procedure Query_Element
102 Process
: not null access procedure (Element
: Element_Type
));
104 procedure Update_Element
105 (Container
: in out Tree
;
107 Process
: not null access procedure (Element
: in out Element_Type
));
109 type Constant_Reference_Type
110 (Element
: not null access constant Element_Type
) is private
111 with Implicit_Dereference
=> Element
;
114 (Element
: not null access Element_Type
) is private
115 with Implicit_Dereference
=> Element
;
117 function Constant_Reference
118 (Container
: aliased Tree
;
119 Position
: Cursor
) return Constant_Reference_Type
;
120 pragma Inline
(Constant_Reference
);
123 (Container
: aliased in out Tree
;
124 Position
: Cursor
) return Reference_Type
;
125 pragma Inline
(Reference
);
127 procedure Assign
(Target
: in out Tree
; Source
: Tree
);
129 function Copy
(Source
: Tree
) return Tree
;
131 procedure Move
(Target
: in out Tree
; Source
: in out Tree
);
133 procedure Delete_Leaf
134 (Container
: in out Tree
;
135 Position
: in out Cursor
);
137 procedure Delete_Subtree
138 (Container
: in out Tree
;
139 Position
: in out Cursor
);
142 (Container
: in out Tree
;
147 Item
: Element_Type
) return Cursor
;
149 -- This version of the AI:
150 -- 10-06-02 AI05-0136-1/07
151 -- declares Find_In_Subtree this way:
153 -- function Find_In_Subtree
154 -- (Container : Tree;
155 -- Item : Element_Type;
156 -- Position : Cursor) return Cursor;
158 -- It seems that the Container parameter is there by mistake, but we need
159 -- an official ruling from the ARG. ???
161 function Find_In_Subtree
163 Item
: Element_Type
) return Cursor
;
165 -- This version of the AI:
166 -- 10-06-02 AI05-0136-1/07
167 -- declares Ancestor_Find this way:
169 -- function Ancestor_Find
170 -- (Container : Tree;
171 -- Item : Element_Type;
172 -- Position : Cursor) return Cursor;
174 -- It seems that the Container parameter is there by mistake, but we need
175 -- an official ruling from the ARG. ???
177 function Ancestor_Find
179 Item
: Element_Type
) return Cursor
;
183 Item
: Element_Type
) return Boolean;
187 Process
: not null access procedure (Position
: Cursor
));
189 procedure Iterate_Subtree
191 Process
: not null access procedure (Position
: Cursor
));
193 function Iterate
(Container
: Tree
)
194 return Tree_Iterator_Interfaces
.Forward_Iterator
'Class;
196 function Iterate_Subtree
(Position
: Cursor
)
197 return Tree_Iterator_Interfaces
.Forward_Iterator
'Class;
199 function Iterate_Children
202 return Tree_Iterator_Interfaces
.Reversible_Iterator
'Class;
204 function Child_Count
(Parent
: Cursor
) return Count_Type
;
206 function Child_Depth
(Parent
, Child
: Cursor
) return Count_Type
;
208 procedure Insert_Child
209 (Container
: in out Tree
;
212 New_Item
: Element_Type
;
213 Count
: Count_Type
:= 1);
215 procedure Insert_Child
216 (Container
: in out Tree
;
219 New_Item
: Element_Type
;
220 Position
: out Cursor
;
221 Count
: Count_Type
:= 1);
223 procedure Insert_Child
224 (Container
: in out Tree
;
227 Position
: out Cursor
;
228 Count
: Count_Type
:= 1);
230 procedure Prepend_Child
231 (Container
: in out Tree
;
233 New_Item
: Element_Type
;
234 Count
: Count_Type
:= 1);
236 procedure Append_Child
237 (Container
: in out Tree
;
239 New_Item
: Element_Type
;
240 Count
: Count_Type
:= 1);
242 procedure Delete_Children
243 (Container
: in out Tree
;
246 procedure Copy_Subtree
247 (Target
: in out Tree
;
252 procedure Splice_Subtree
253 (Target
: in out Tree
;
256 Source
: in out Tree
;
257 Position
: in out Cursor
);
259 procedure Splice_Subtree
260 (Container
: in out Tree
;
265 procedure Splice_Children
266 (Target
: in out Tree
;
267 Target_Parent
: Cursor
;
269 Source
: in out Tree
;
270 Source_Parent
: Cursor
);
272 procedure Splice_Children
273 (Container
: in out Tree
;
274 Target_Parent
: Cursor
;
276 Source_Parent
: Cursor
);
278 function Parent
(Position
: Cursor
) return Cursor
;
280 function First_Child
(Parent
: Cursor
) return Cursor
;
282 function First_Child_Element
(Parent
: Cursor
) return Element_Type
;
284 function Last_Child
(Parent
: Cursor
) return Cursor
;
286 function Last_Child_Element
(Parent
: Cursor
) return Element_Type
;
288 function Next_Sibling
(Position
: Cursor
) return Cursor
;
290 function Previous_Sibling
(Position
: Cursor
) return Cursor
;
292 procedure Next_Sibling
(Position
: in out Cursor
);
294 procedure Previous_Sibling
(Position
: in out Cursor
);
296 -- This version of the AI:
297 -- 10-06-02 AI05-0136-1/07
298 -- declares Iterate_Children this way:
300 -- procedure Iterate_Children
301 -- (Container : Tree;
303 -- Process : not null access procedure (Position : Cursor));
305 -- It seems that the Container parameter is there by mistake, but we need
306 -- an official ruling from the ARG. ???
308 procedure Iterate_Children
310 Process
: not null access procedure (Position
: Cursor
));
312 procedure Reverse_Iterate_Children
314 Process
: not null access procedure (Position
: Cursor
));
317 -- A node of this multiway tree comprises an element and a list of children
318 -- (that are themselves trees). The root node is distinguished because it
319 -- contains only children: it does not have an element itself.
321 -- This design feature puts two design goals in tension with one another:
322 -- (1) treat the root node the same as any other node
323 -- (2) not declare any objects of type Element_Type unnecessarily
325 -- To satisfy (1), we could simply declare the Root node of the tree
326 -- using the normal Tree_Node_Type, but that would mean that (2) is not
327 -- satisfied. To resolve the tension (in favor of (2)), we declare the
328 -- component Root as having a different node type, without an Element
329 -- component (thus satisfying goal (2)) but otherwise identical to a normal
330 -- node, and then use Unchecked_Conversion to convert an access object
331 -- designating the Root node component to the access type designating a
332 -- normal, non-root node (thus satisfying goal (1)). We make an explicit
333 -- check for Root when there is any attempt to manipulate the Element
334 -- component of the node (a check required by the RM anyway).
336 -- In order to be explicit about node (and pointer) representation, we
337 -- specify that the respective node types have convention C, to ensure
338 -- that the layout of the components of the node records is the same,
339 -- thus guaranteeing that (unchecked) conversions between access types
340 -- designating each kind of node type is a meaningful conversion.
342 use Ada
.Containers
.Helpers
;
343 package Implementation
is new Generic_Implementation
;
347 type Tree_Node_Access
is access all Tree_Node_Type
;
348 pragma Convention
(C
, Tree_Node_Access
);
349 pragma No_Strict_Aliasing
(Tree_Node_Access
);
350 -- The above-mentioned Unchecked_Conversion is a violation of the normal
353 type Children_Type
is record
354 First
: Tree_Node_Access
;
355 Last
: Tree_Node_Access
;
358 -- See the comment above. This declaration must exactly match the
359 -- declaration of Root_Node_Type (except for the Element component).
361 type Tree_Node_Type
is record
362 Parent
: Tree_Node_Access
;
363 Prev
: Tree_Node_Access
;
364 Next
: Tree_Node_Access
;
365 Children
: Children_Type
;
366 Element
: aliased Element_Type
;
368 pragma Convention
(C
, Tree_Node_Type
);
370 -- See the comment above. This declaration must match the declaration of
371 -- Tree_Node_Type (except for the Element component).
373 type Root_Node_Type
is record
374 Parent
: Tree_Node_Access
;
375 Prev
: Tree_Node_Access
;
376 Next
: Tree_Node_Access
;
377 Children
: Children_Type
;
379 pragma Convention
(C
, Root_Node_Type
);
381 for Root_Node_Type
'Alignment use Standard
'Maximum_Alignment;
382 -- The alignment has to be large enough to allow Root_Node to Tree_Node
383 -- access value conversions, and Tree_Node_Type's alignment may be bumped
384 -- up by the Element component.
386 use Ada
.Finalization
;
388 -- The Count component of type Tree represents the number of nodes that
389 -- have been (dynamically) allocated. It does not include the root node
390 -- itself. As implementors, we decide to cache this value, so that the
391 -- selector function Node_Count can execute in O(1) time, in order to be
392 -- consistent with the behavior of the Length selector function for other
393 -- standard container library units. This does mean, however, that the
394 -- two-container forms for Splice_XXX (that move subtrees across tree
395 -- containers) will execute in O(n) time, because we must count the number
396 -- of nodes in the subtree(s) that get moved. (We resolve the tension
397 -- between Node_Count and Splice_XXX in favor of Node_Count, under the
398 -- assumption that Node_Count is the more common operation).
400 type Tree
is new Controlled
with record
401 Root
: aliased Root_Node_Type
;
402 TC
: aliased Tamper_Counts
;
403 Count
: Count_Type
:= 0;
404 end record with Put_Image
=> Put_Image
;
407 (S
: in out Ada
.Strings
.Text_Buffers
.Root_Buffer_Type
'Class; V
: Tree
);
409 overriding
procedure Adjust
(Container
: in out Tree
);
411 overriding
procedure Finalize
(Container
: in out Tree
) renames Clear
;
416 (Stream
: not null access Root_Stream_Type
'Class;
419 for Tree
'Write use Write
;
422 (Stream
: not null access Root_Stream_Type
'Class;
423 Container
: out Tree
);
425 for Tree
'Read use Read
;
427 type Tree_Access
is access all Tree
;
428 for Tree_Access
'Storage_Size use 0;
430 type Cursor
is record
431 Container
: Tree_Access
;
432 Node
: Tree_Node_Access
;
436 (Stream
: not null access Root_Stream_Type
'Class;
439 for Cursor
'Write use Write
;
442 (Stream
: not null access Root_Stream_Type
'Class;
443 Position
: out Cursor
);
445 for Cursor
'Read use Read
;
447 subtype Reference_Control_Type
is Implementation
.Reference_Control_Type
;
448 -- It is necessary to rename this here, so that the compiler can find it
450 type Constant_Reference_Type
451 (Element
: not null access constant Element_Type
) is
453 Control
: Reference_Control_Type
:=
454 raise Program_Error
with "uninitialized reference";
455 -- The RM says, "The default initialization of an object of
456 -- type Constant_Reference_Type or Reference_Type propagates
461 (Stream
: not null access Root_Stream_Type
'Class;
462 Item
: out Constant_Reference_Type
);
464 for Constant_Reference_Type
'Read use Read
;
467 (Stream
: not null access Root_Stream_Type
'Class;
468 Item
: Constant_Reference_Type
);
470 for Constant_Reference_Type
'Write use Write
;
473 (Element
: not null access Element_Type
) is
475 Control
: Reference_Control_Type
:=
476 raise Program_Error
with "uninitialized reference";
477 -- The RM says, "The default initialization of an object of
478 -- type Constant_Reference_Type or Reference_Type propagates
483 (Stream
: not null access Root_Stream_Type
'Class;
484 Item
: out Reference_Type
);
486 for Reference_Type
'Read use Read
;
489 (Stream
: not null access Root_Stream_Type
'Class;
490 Item
: Reference_Type
);
492 for Reference_Type
'Write use Write
;
494 -- See Ada.Containers.Vectors for documentation on the following
496 function Pseudo_Reference
497 (Container
: aliased Tree
'Class) return Reference_Control_Type
;
498 pragma Inline
(Pseudo_Reference
);
499 -- Creates an object of type Reference_Control_Type pointing to the
500 -- container, and increments the Lock. Finalization of this object will
501 -- decrement the Lock.
503 type Element_Access
is access all Element_Type
with
506 function Get_Element_Access
507 (Position
: Cursor
) return not null Element_Access
;
508 -- Returns a pointer to the element designated by Position.
510 Empty_Tree
: constant Tree
:= (Controlled
with others => <>);
512 No_Element
: constant Cursor
:= (others => <>);
514 end Ada
.Containers
.Multiway_Trees
;