OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-cbmutr.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.