1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS --
9 -- Copyright (C) 2004-2023, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Containers
.Stable_Sorting
; use Ada
.Containers
.Stable_Sorting
;
32 with System
; use type System
.Address
;
33 with System
.Put_Images
;
35 package body Ada
.Containers
.Bounded_Doubly_Linked_Lists
with
39 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
40 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
41 -- See comment in Ada.Containers.Helpers
43 -----------------------
44 -- Local Subprograms --
45 -----------------------
48 (Container
: in out List
;
49 New_Item
: Element_Type
;
50 New_Node
: out Count_Type
);
53 (Container
: in out List
;
54 Stream
: not null access Root_Stream_Type
'Class;
55 New_Node
: out Count_Type
);
58 (Container
: in out List
;
61 procedure Insert_Internal
62 (Container
: in out List
;
64 New_Node
: Count_Type
);
66 procedure Splice_Internal
67 (Target
: in out List
;
69 Source
: in out List
);
71 procedure Splice_Internal
72 (Target
: in out List
;
76 Tgt_Pos
: out Count_Type
);
78 function Vet
(Position
: Cursor
) return Boolean with Inline
;
79 -- Checks invariants of the cursor and its designated container, as a
80 -- simple way of detecting dangling references (see operation Free for a
81 -- description of the detection mechanism), returning True if all checks
82 -- pass. Invocations of Vet are used here as the argument of pragma Assert,
83 -- so the checks are performed only when assertions are enabled.
89 function "=" (Left
, Right
: List
) return Boolean is
91 if Left
.Length
/= Right
.Length
then
95 if Left
.Length
= 0 then
100 -- Per AI05-0022, the container implementation is required to detect
101 -- element tampering by a generic actual subprogram.
103 Lock_Left
: With_Lock
(Left
.TC
'Unrestricted_Access);
104 Lock_Right
: With_Lock
(Right
.TC
'Unrestricted_Access);
106 LN
: Node_Array
renames Left
.Nodes
;
107 RN
: Node_Array
renames Right
.Nodes
;
109 LI
: Count_Type
:= Left
.First
;
110 RI
: Count_Type
:= Right
.First
;
112 for J
in 1 .. Left
.Length
loop
113 if LN
(LI
).Element
/= RN
(RI
).Element
then
130 (Container
: in out List
;
131 New_Item
: Element_Type
;
132 New_Node
: out Count_Type
)
134 N
: Node_Array
renames Container
.Nodes
;
137 if Container
.Free
>= 0 then
138 New_Node
:= Container
.Free
;
140 -- We always perform the assignment first, before we change container
141 -- state, in order to defend against exceptions duration assignment.
143 N
(New_Node
).Element
:= New_Item
;
144 Container
.Free
:= N
(New_Node
).Next
;
147 -- A negative free store value means that the links of the nodes in
148 -- the free store have not been initialized. In this case, the nodes
149 -- are physically contiguous in the array, starting at the index that
150 -- is the absolute value of the Container.Free, and continuing until
151 -- the end of the array (Nodes'Last).
153 New_Node
:= abs Container
.Free
;
155 -- As above, we perform this assignment first, before modifying any
158 N
(New_Node
).Element
:= New_Item
;
159 Container
.Free
:= Container
.Free
- 1;
164 (Container
: in out List
;
165 Stream
: not null access Root_Stream_Type
'Class;
166 New_Node
: out Count_Type
)
168 N
: Node_Array
renames Container
.Nodes
;
171 if Container
.Free
>= 0 then
172 New_Node
:= Container
.Free
;
174 -- We always perform the assignment first, before we change container
175 -- state, in order to defend against exceptions duration assignment.
177 Element_Type
'Read (Stream
, N
(New_Node
).Element
);
178 Container
.Free
:= N
(New_Node
).Next
;
181 -- A negative free store value means that the links of the nodes in
182 -- the free store have not been initialized. In this case, the nodes
183 -- are physically contiguous in the array, starting at the index that
184 -- is the absolute value of the Container.Free, and continuing until
185 -- the end of the array (Nodes'Last).
187 New_Node
:= abs Container
.Free
;
189 -- As above, we perform this assignment first, before modifying any
192 Element_Type
'Read (Stream
, N
(New_Node
).Element
);
193 Container
.Free
:= Container
.Free
- 1;
202 (Container
: in out List
;
203 New_Item
: Element_Type
;
207 Insert
(Container
, No_Element
, New_Item
, Count
);
211 (Container
: in out List
;
212 New_Item
: Element_Type
)
215 Insert
(Container
, No_Element
, New_Item
, 1);
222 procedure Assign
(Target
: in out List
; Source
: List
) is
223 SN
: Node_Array
renames Source
.Nodes
;
227 if Target
'Address = Source
'Address then
231 if Checks
and then Target
.Capacity
< Source
.Length
then
232 raise Capacity_Error
-- ???
233 with "Target capacity is less than Source length";
240 Target
.Append
(SN
(J
).Element
);
249 procedure Clear
(Container
: in out List
) is
250 N
: Node_Array
renames Container
.Nodes
;
254 if Container
.Length
= 0 then
255 pragma Assert
(Container
.First
= 0);
256 pragma Assert
(Container
.Last
= 0);
257 pragma Assert
(Container
.TC
= (Busy
=> 0, Lock
=> 0));
261 pragma Assert
(Container
.First
>= 1);
262 pragma Assert
(Container
.Last
>= 1);
263 pragma Assert
(N
(Container
.First
).Prev
= 0);
264 pragma Assert
(N
(Container
.Last
).Next
= 0);
266 TC_Check
(Container
.TC
);
268 while Container
.Length
> 1 loop
269 X
:= Container
.First
;
270 pragma Assert
(N
(N
(X
).Next
).Prev
= Container
.First
);
272 Container
.First
:= N
(X
).Next
;
273 N
(Container
.First
).Prev
:= 0;
275 Container
.Length
:= Container
.Length
- 1;
280 X
:= Container
.First
;
281 pragma Assert
(X
= Container
.Last
);
283 Container
.First
:= 0;
285 Container
.Length
:= 0;
290 ------------------------
291 -- Constant_Reference --
292 ------------------------
294 function Constant_Reference
295 (Container
: aliased List
;
296 Position
: Cursor
) return Constant_Reference_Type
299 if Checks
and then Position
.Container
= null then
300 raise Constraint_Error
with "Position cursor has no element";
303 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
305 raise Program_Error
with
306 "Position cursor designates wrong container";
309 pragma Assert
(Vet
(Position
), "bad cursor in Constant_Reference");
312 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
313 TC
: constant Tamper_Counts_Access
:=
314 Container
.TC
'Unrestricted_Access;
316 return R
: constant Constant_Reference_Type
:=
317 (Element
=> N
.Element
'Unchecked_Access,
318 Control
=> (Controlled
with TC
))
323 end Constant_Reference
;
331 Item
: Element_Type
) return Boolean
334 return Find
(Container
, Item
) /= No_Element
;
341 function Copy
(Source
: List
; Capacity
: Count_Type
:= 0) return List
is
345 if Capacity
< Source
.Length
then
346 if Checks
and then Capacity
/= 0 then
348 with "Requested capacity is less than Source length";
356 return Target
: List
(Capacity
=> C
) do
357 Assign
(Target
=> Target
, Source
=> Source
);
366 (Container
: in out List
;
367 Position
: in out Cursor
;
368 Count
: Count_Type
:= 1)
370 N
: Node_Array
renames Container
.Nodes
;
374 TC_Check
(Container
.TC
);
376 if Checks
and then Position
.Node
= 0 then
377 raise Constraint_Error
with
378 "Position cursor has no element";
381 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
383 raise Program_Error
with
384 "Position cursor designates wrong container";
387 pragma Assert
(Vet
(Position
), "bad cursor in Delete");
388 pragma Assert
(Container
.First
>= 1);
389 pragma Assert
(Container
.Last
>= 1);
390 pragma Assert
(N
(Container
.First
).Prev
= 0);
391 pragma Assert
(N
(Container
.Last
).Next
= 0);
393 if Position
.Node
= Container
.First
then
394 Delete_First
(Container
, Count
);
395 Position
:= No_Element
;
400 Position
:= No_Element
;
404 for Index
in 1 .. Count
loop
405 pragma Assert
(Container
.Length
>= 2);
408 Container
.Length
:= Container
.Length
- 1;
410 if X
= Container
.Last
then
411 Position
:= No_Element
;
413 Container
.Last
:= N
(X
).Prev
;
414 N
(Container
.Last
).Next
:= 0;
420 Position
.Node
:= N
(X
).Next
;
422 N
(N
(X
).Next
).Prev
:= N
(X
).Prev
;
423 N
(N
(X
).Prev
).Next
:= N
(X
).Next
;
428 Position
:= No_Element
;
435 procedure Delete_First
436 (Container
: in out List
;
437 Count
: Count_Type
:= 1)
439 N
: Node_Array
renames Container
.Nodes
;
443 TC_Check
(Container
.TC
);
445 if Count
>= Container
.Length
then
454 for J
in 1 .. Count
loop
455 X
:= Container
.First
;
456 pragma Assert
(N
(N
(X
).Next
).Prev
= Container
.First
);
458 Container
.First
:= N
(X
).Next
;
459 N
(Container
.First
).Prev
:= 0;
461 Container
.Length
:= Container
.Length
- 1;
471 procedure Delete_Last
472 (Container
: in out List
;
473 Count
: Count_Type
:= 1)
475 N
: Node_Array
renames Container
.Nodes
;
479 TC_Check
(Container
.TC
);
481 if Count
>= Container
.Length
then
490 for J
in 1 .. Count
loop
492 pragma Assert
(N
(N
(X
).Prev
).Next
= Container
.Last
);
494 Container
.Last
:= N
(X
).Prev
;
495 N
(Container
.Last
).Next
:= 0;
497 Container
.Length
:= Container
.Length
- 1;
507 function Element
(Position
: Cursor
) return Element_Type
is
509 if Checks
and then Position
.Node
= 0 then
510 raise Constraint_Error
with
511 "Position cursor has no element";
514 pragma Assert
(Vet
(Position
), "bad cursor in Element");
516 return Position
.Container
.Nodes
(Position
.Node
).Element
;
523 function Empty
(Capacity
: Count_Type
:= 10) return List
is
525 return Result
: List
(Capacity
) do
534 procedure Finalize
(Object
: in out Iterator
) is
536 if Object
.Container
/= null then
537 Unbusy
(Object
.Container
.TC
);
548 Position
: Cursor
:= No_Element
) return Cursor
550 Nodes
: Node_Array
renames Container
.Nodes
;
551 Node
: Count_Type
:= Position
.Node
;
555 Node
:= Container
.First
;
558 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
560 raise Program_Error
with
561 "Position cursor designates wrong container";
564 pragma Assert
(Vet
(Position
), "bad cursor in Find");
567 -- Per AI05-0022, the container implementation is required to detect
568 -- element tampering by a generic actual subprogram.
571 Lock
: With_Lock
(Container
.TC
'Unrestricted_Access);
574 if Nodes
(Node
).Element
= Item
then
575 return Cursor
'(Container'Unrestricted_Access, Node);
578 Node := Nodes (Node).Next;
589 function First (Container : List) return Cursor is
591 if Container.First = 0 then
594 return Cursor'(Container
'Unrestricted_Access, Container
.First
);
598 function First
(Object
: Iterator
) return Cursor
is
600 -- The value of the iterator object's Node component influences the
601 -- behavior of the First (and Last) selector function.
603 -- When the Node component is 0, this means the iterator object was
604 -- constructed without a start expression, in which case the (forward)
605 -- iteration starts from the (logical) beginning of the entire sequence
606 -- of items (corresponding to Container.First, for a forward iterator).
608 -- Otherwise, this is iteration over a partial sequence of items. When
609 -- the Node component is positive, the iterator object was constructed
610 -- with a start expression, that specifies the position from which the
611 -- (forward) partial iteration begins.
613 if Object
.Node
= 0 then
614 return Bounded_Doubly_Linked_Lists
.First
(Object
.Container
.all);
616 return Cursor
'(Object.Container, Object.Node);
624 function First_Element (Container : List) return Element_Type is
626 if Checks and then Container.First = 0 then
627 raise Constraint_Error with "list is empty";
630 return Container.Nodes (Container.First).Element;
638 (Container : in out List;
641 pragma Assert (X > 0);
642 pragma Assert (X <= Container.Capacity);
644 N : Node_Array renames Container.Nodes;
645 pragma Assert (N (X).Prev >= 0); -- node is active
648 -- The list container actually contains two lists: one for the "active"
649 -- nodes that contain elements that have been inserted onto the list,
650 -- and another for the "inactive" nodes for the free store.
652 -- We desire that merely declaring an object should have only minimal
653 -- cost; specially, we want to avoid having to initialize the free
654 -- store (to fill in the links), especially if the capacity is large.
656 -- The head of the free list is indicated by Container.Free. If its
657 -- value is non-negative, then the free store has been initialized in
658 -- the "normal" way: Container.Free points to the head of the list of
659 -- free (inactive) nodes, and the value 0 means the free list is empty.
660 -- Each node on the free list has been initialized to point to the next
661 -- free node (via its Next component), and the value 0 means that this
662 -- is the last free node.
664 -- If Container.Free is negative, then the links on the free store have
665 -- not been initialized. In this case the link values are implied: the
666 -- free store comprises the components of the node array started with
667 -- the absolute value of Container.Free, and continuing until the end of
668 -- the array (Nodes'Last).
670 -- If the list container is manipulated on one end only (for example if
671 -- the container were being used as a stack), then there is no need to
672 -- initialize the free store, since the inactive nodes are physically
673 -- contiguous (in fact, they lie immediately beyond the logical end
674 -- being manipulated). The only time we need to actually initialize the
675 -- nodes in the free store is if the node that becomes inactive is not
676 -- at the end of the list. The free store would then be discontiguous
677 -- and so its nodes would need to be linked in the traditional way.
680 -- It might be possible to perform an optimization here. Suppose that
681 -- the free store can be represented as having two parts: one comprising
682 -- the non-contiguous inactive nodes linked together in the normal way,
683 -- and the other comprising the contiguous inactive nodes (that are not
684 -- linked together, at the end of the nodes array). This would allow us
685 -- to never have to initialize the free store, except in a lazy way as
686 -- nodes become inactive.
688 -- When an element is deleted from the list container, its node becomes
689 -- inactive, and so we set its Prev component to a negative value, to
690 -- indicate that it is now inactive. This provides a useful way to
691 -- detect a dangling cursor reference (and which is used in Vet).
693 N (X).Prev := -1; -- Node is deallocated (not on active list)
695 if Container.Free >= 0 then
697 -- The free store has previously been initialized. All we need to
698 -- do here is link the newly-free'd node onto the free list.
700 N (X).Next := Container.Free;
703 elsif X + 1 = abs Container.Free then
705 -- The free store has not been initialized, and the node becoming
706 -- inactive immediately precedes the start of the free store. All
707 -- we need to do is move the start of the free store back by one.
709 -- Note: initializing Next to zero is not strictly necessary but
710 -- seems cleaner and marginally safer.
713 Container.Free := Container.Free + 1;
716 -- The free store has not been initialized, and the node becoming
717 -- inactive does not immediately precede the free store. Here we
718 -- first initialize the free store (meaning the links are given
719 -- values in the traditional way), and then link the newly-free'd
720 -- node onto the head of the free store.
723 -- See the comments above for an optimization opportunity. If the
724 -- next link for a node on the free store is negative, then this
725 -- means the remaining nodes on the free store are physically
726 -- contiguous, starting as the absolute value of that index value.
728 Container.Free := abs Container.Free;
730 if Container.Free > Container.Capacity then
734 for I in Container.Free .. Container.Capacity - 1 loop
738 N (Container.Capacity).Next := 0;
741 N (X).Next := Container.Free;
746 ---------------------
747 -- Generic_Sorting --
748 ---------------------
750 package body Generic_Sorting is
756 function Is_Sorted (Container : List) return Boolean is
757 -- Per AI05-0022, the container implementation is required to detect
758 -- element tampering by a generic actual subprogram.
760 Lock : With_Lock (Container.TC'Unrestricted_Access);
762 Nodes : Node_Array renames Container.Nodes;
765 Node := Container.First;
766 for J in 2 .. Container.Length loop
767 if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
771 Node := Nodes (Node).Next;
782 (Target : in out List;
783 Source : in out List)
786 TC_Check (Target.TC);
787 TC_Check (Source.TC);
789 -- The semantics of Merge changed slightly per AI05-0021. It was
790 -- originally the case that if Target and Source denoted the same
791 -- container object, then the GNAT implementation of Merge did
792 -- nothing. However, it was argued that RM05 did not precisely
793 -- specify the semantics for this corner case. The decision of the
794 -- ARG was that if Target and Source denote the same non-empty
795 -- container object, then Program_Error is raised.
797 if Source.Is_Empty then
801 if Checks and then Target'Address = Source'Address then
802 raise Program_Error with
803 "Target and Source denote same non-empty container";
806 if Checks and then Target.Length > Count_Type'Last - Source.Length
808 raise Constraint_Error with "new length exceeds maximum";
811 if Checks and then Target.Length + Source.Length > Target.Capacity
813 raise Capacity_Error with "new length exceeds target capacity";
816 -- Per AI05-0022, the container implementation is required to detect
817 -- element tampering by a generic actual subprogram.
820 Lock_Target : With_Lock (Target.TC'Unchecked_Access);
821 Lock_Source : With_Lock (Source.TC'Unchecked_Access);
823 LN : Node_Array renames Target.Nodes;
824 RN : Node_Array renames Source.Nodes;
826 LI, LJ, RI, RJ : Count_Type;
832 pragma Assert (RN (RI).Next = 0
833 or else not (RN (RN (RI).Next).Element <
837 Splice_Internal (Target, 0, Source);
841 pragma Assert (LN (LI).Next = 0
842 or else not (LN (LN (LI).Next).Element <
845 if RN (RI).Element < LN (LI).Element then
848 Splice_Internal (Target, LI, Source, RJ, LJ);
861 procedure Sort (Container : in out List) is
862 N : Node_Array renames Container.Nodes;
864 if Container.Length <= 1 then
868 pragma Assert (N (Container.First).Prev = 0);
869 pragma Assert (N (Container.Last).Next = 0);
871 TC_Check (Container.TC);
873 -- Per AI05-0022, the container implementation is required to detect
874 -- element tampering by a generic actual subprogram.
877 Lock : With_Lock (Container.TC'Unchecked_Access);
879 package Descriptors is new List_Descriptors
880 (Node_Ref => Count_Type, Nil => 0);
883 function Next (Idx : Count_Type) return Count_Type is
885 procedure Set_Next (Idx : Count_Type; Next : Count_Type)
887 procedure Set_Prev (Idx : Count_Type; Prev : Count_Type)
889 function "<" (L, R : Count_Type) return Boolean is
890 (N (L).Element < N (R).Element);
891 procedure Update_Container (List : List_Descriptor) with Inline;
893 procedure Set_Next (Idx : Count_Type; Next : Count_Type) is
895 N (Idx).Next := Next;
898 procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is
900 N (Idx).Prev := Prev;
903 procedure Update_Container (List : List_Descriptor) is
905 Container.First := List.First;
906 Container.Last := List.Last;
907 Container.Length := List.Length;
908 end Update_Container;
910 procedure Sort_List is new Doubly_Linked_List_Sort;
912 Sort_List (List_Descriptor'(First
=> Container
.First
,
913 Last
=> Container
.Last
,
914 Length
=> Container
.Length
));
917 pragma Assert
(N
(Container
.First
).Prev
= 0);
918 pragma Assert
(N
(Container
.Last
).Next
= 0);
923 ------------------------
924 -- Get_Element_Access --
925 ------------------------
927 function Get_Element_Access
928 (Position
: Cursor
) return not null Element_Access
is
930 return Position
.Container
.Nodes
(Position
.Node
).Element
'Access;
931 end Get_Element_Access
;
937 function Has_Element
(Position
: Cursor
) return Boolean is
939 pragma Assert
(Vet
(Position
), "bad cursor in Has_Element");
940 return Position
.Node
/= 0;
948 (Container
: in out List
;
950 New_Item
: Element_Type
;
951 Position
: out Cursor
;
952 Count
: Count_Type
:= 1)
954 First_Node
: Count_Type
;
955 New_Node
: Count_Type
;
958 TC_Check
(Container
.TC
);
960 if Before
.Container
/= null then
961 if Checks
and then Before
.Container
/= Container
'Unrestricted_Access
963 raise Program_Error
with
964 "Before cursor designates wrong list";
967 pragma Assert
(Vet
(Before
), "bad cursor in Insert");
975 if Checks
and then Container
.Length
> Container
.Capacity
- Count
then
976 raise Capacity_Error
with "capacity exceeded";
979 Allocate
(Container
, New_Item
, New_Node
);
980 First_Node
:= New_Node
;
981 Insert_Internal
(Container
, Before
.Node
, New_Node
);
983 for Index
in Count_Type
'(2) .. Count loop
984 Allocate (Container, New_Item, New_Node);
985 Insert_Internal (Container, Before.Node, New_Node);
988 Position := Cursor'(Container
'Unchecked_Access, First_Node
);
992 (Container
: in out List
;
994 New_Item
: Element_Type
;
995 Count
: Count_Type
:= 1)
999 Insert
(Container
, Before
, New_Item
, Position
, Count
);
1003 (Container
: in out List
;
1005 Position
: out Cursor
;
1006 Count
: Count_Type
:= 1)
1008 pragma Warnings
(Off
);
1009 Default_Initialized_Item
: Element_Type
;
1010 pragma Unmodified
(Default_Initialized_Item
);
1011 -- OK to reference, see below. Note that we need to suppress both the
1012 -- front end warning and the back end warning. In addition, pragma
1013 -- Unmodified is needed to suppress the warning ``actual type for
1014 -- "Element_Type" should be fully initialized type'' on certain
1018 -- There is no explicit element provided, but in an instance the element
1019 -- type may be a scalar with a Default_Value aspect, or a composite
1020 -- type with such a scalar component, or components with default
1021 -- initialization, so insert the specified number of possibly
1022 -- initialized elements at the given position.
1024 Insert
(Container
, Before
, Default_Initialized_Item
, Position
, Count
);
1025 pragma Warnings
(On
);
1028 ---------------------
1029 -- Insert_Internal --
1030 ---------------------
1032 procedure Insert_Internal
1033 (Container
: in out List
;
1034 Before
: Count_Type
;
1035 New_Node
: Count_Type
)
1037 N
: Node_Array
renames Container
.Nodes
;
1040 if Container
.Length
= 0 then
1041 pragma Assert
(Before
= 0);
1042 pragma Assert
(Container
.First
= 0);
1043 pragma Assert
(Container
.Last
= 0);
1045 Container
.First
:= New_Node
;
1046 N
(Container
.First
).Prev
:= 0;
1048 Container
.Last
:= New_Node
;
1049 N
(Container
.Last
).Next
:= 0;
1051 -- Before = zero means append
1053 elsif Before
= 0 then
1054 pragma Assert
(N
(Container
.Last
).Next
= 0);
1056 N
(Container
.Last
).Next
:= New_Node
;
1057 N
(New_Node
).Prev
:= Container
.Last
;
1059 Container
.Last
:= New_Node
;
1060 N
(Container
.Last
).Next
:= 0;
1062 -- Before = Container.First means prepend
1064 elsif Before
= Container
.First
then
1065 pragma Assert
(N
(Container
.First
).Prev
= 0);
1067 N
(Container
.First
).Prev
:= New_Node
;
1068 N
(New_Node
).Next
:= Container
.First
;
1070 Container
.First
:= New_Node
;
1071 N
(Container
.First
).Prev
:= 0;
1074 pragma Assert
(N
(Container
.First
).Prev
= 0);
1075 pragma Assert
(N
(Container
.Last
).Next
= 0);
1077 N
(New_Node
).Next
:= Before
;
1078 N
(New_Node
).Prev
:= N
(Before
).Prev
;
1080 N
(N
(Before
).Prev
).Next
:= New_Node
;
1081 N
(Before
).Prev
:= New_Node
;
1084 Container
.Length
:= Container
.Length
+ 1;
1085 end Insert_Internal
;
1091 function Is_Empty
(Container
: List
) return Boolean is
1093 return Container
.Length
= 0;
1102 Process
: not null access procedure (Position
: Cursor
))
1104 Busy
: With_Busy
(Container
.TC
'Unrestricted_Access);
1105 Node
: Count_Type
:= Container
.First
;
1108 while Node
/= 0 loop
1109 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1110 Node := Container.Nodes (Node).Next;
1116 return List_Iterator_Interfaces.Reversible_Iterator'Class
1119 -- The value of the Node component influences the behavior of the First
1120 -- and Last selector functions of the iterator object. When the Node
1121 -- component is 0 (as is the case here), this means the iterator
1122 -- object was constructed without a start expression. This is a
1123 -- complete iterator, meaning that the iteration starts from the
1124 -- (logical) beginning of the sequence of items.
1126 -- Note: For a forward iterator, Container.First is the beginning, and
1127 -- for a reverse iterator, Container.Last is the beginning.
1129 return It : constant Iterator :=
1130 Iterator'(Limited_Controlled
with
1131 Container
=> Container
'Unrestricted_Access,
1134 Busy
(Container
.TC
'Unrestricted_Access.all);
1141 return List_Iterator_Interfaces
.Reversible_Iterator
'class
1144 -- It was formerly the case that when Start = No_Element, the partial
1145 -- iterator was defined to behave the same as for a complete iterator,
1146 -- and iterate over the entire sequence of items. However, those
1147 -- semantics were unintuitive and arguably error-prone (it is too easy
1148 -- to accidentally create an endless loop), and so they were changed,
1149 -- per the ARG meeting in Denver on 2011/11. However, there was no
1150 -- consensus about what positive meaning this corner case should have,
1151 -- and so it was decided to simply raise an exception. This does imply,
1152 -- however, that it is not possible to use a partial iterator to specify
1153 -- an empty sequence of items.
1155 if Checks
and then Start
= No_Element
then
1156 raise Constraint_Error
with
1157 "Start position for iterator equals No_Element";
1160 if Checks
and then Start
.Container
/= Container
'Unrestricted_Access then
1161 raise Program_Error
with
1162 "Start cursor of Iterate designates wrong list";
1165 pragma Assert
(Vet
(Start
), "Start cursor of Iterate is bad");
1167 -- The value of the Node component influences the behavior of the First
1168 -- and Last selector functions of the iterator object. When the Node
1169 -- component is positive (as is the case here), it means that this
1170 -- is a partial iteration, over a subset of the complete sequence of
1171 -- items. The iterator object was constructed with a start expression,
1172 -- indicating the position from which the iteration begins. Note that
1173 -- the start position has the same value irrespective of whether this
1174 -- is a forward or reverse iteration.
1176 return It
: constant Iterator
:=
1177 Iterator
'(Limited_Controlled with
1178 Container => Container'Unrestricted_Access,
1181 Busy (Container.TC'Unrestricted_Access.all);
1189 function Last (Container : List) return Cursor is
1191 if Container.Last = 0 then
1194 return Cursor'(Container
'Unrestricted_Access, Container
.Last
);
1198 function Last
(Object
: Iterator
) return Cursor
is
1200 -- The value of the iterator object's Node component influences the
1201 -- behavior of the Last (and First) selector function.
1203 -- When the Node component is 0, this means the iterator object was
1204 -- constructed without a start expression, in which case the (reverse)
1205 -- iteration starts from the (logical) beginning of the entire sequence
1206 -- (corresponding to Container.Last, for a reverse iterator).
1208 -- Otherwise, this is iteration over a partial sequence of items. When
1209 -- the Node component is positive, the iterator object was constructed
1210 -- with a start expression, that specifies the position from which the
1211 -- (reverse) partial iteration begins.
1213 if Object
.Node
= 0 then
1214 return Bounded_Doubly_Linked_Lists
.Last
(Object
.Container
.all);
1216 return Cursor
'(Object.Container, Object.Node);
1224 function Last_Element (Container : List) return Element_Type is
1226 if Checks and then Container.Last = 0 then
1227 raise Constraint_Error with "list is empty";
1230 return Container.Nodes (Container.Last).Element;
1237 function Length (Container : List) return Count_Type is
1239 return Container.Length;
1247 (Target : in out List;
1248 Source : in out List)
1250 N : Node_Array renames Source.Nodes;
1254 TC_Check (Source.TC);
1256 if Target'Address = Source'Address then
1260 if Checks and then Target.Capacity < Source.Length then
1261 raise Capacity_Error with "Source length exceeds Target capacity";
1264 -- Clear target, note that this checks busy bits of Target
1268 while Source.Length > 1 loop
1269 pragma Assert (Source.First in 1 .. Source.Capacity);
1270 pragma Assert (Source.Last /= Source.First);
1271 pragma Assert (N (Source.First).Prev = 0);
1272 pragma Assert (N (Source.Last).Next = 0);
1274 -- Copy first element from Source to Target
1277 Append (Target, N (X).Element);
1279 -- Unlink first node of Source
1281 Source.First := N (X).Next;
1282 N (Source.First).Prev := 0;
1284 Source.Length := Source.Length - 1;
1286 -- The representation invariants for Source have been restored. It is
1287 -- now safe to free the unlinked node, without fear of corrupting the
1288 -- active links of Source.
1290 -- Note that the algorithm we use here models similar algorithms used
1291 -- in the unbounded form of the doubly-linked list container. In that
1292 -- case, Free is an instantation of Unchecked_Deallocation, which can
1293 -- fail (because PE will be raised if controlled Finalize fails), so
1294 -- we must defer the call until the last step. Here in the bounded
1295 -- form, Free merely links the node we have just "deallocated" onto a
1296 -- list of inactive nodes, so technically Free cannot fail. However,
1297 -- for consistency, we handle Free the same way here as we do for the
1298 -- unbounded form, with the pessimistic assumption that it can fail.
1303 if Source.Length = 1 then
1304 pragma Assert (Source.First in 1 .. Source.Capacity);
1305 pragma Assert (Source.Last = Source.First);
1306 pragma Assert (N (Source.First).Prev = 0);
1307 pragma Assert (N (Source.Last).Next = 0);
1309 -- Copy element from Source to Target
1312 Append (Target, N (X).Element);
1314 -- Unlink node of Source
1320 -- Return the unlinked node to the free store
1330 procedure Next (Position : in out Cursor) is
1332 Position := Next (Position);
1335 function Next (Position : Cursor) return Cursor is
1337 if Position.Node = 0 then
1341 pragma Assert (Vet (Position), "bad cursor in Next");
1344 Nodes : Node_Array renames Position.Container.Nodes;
1345 Node : constant Count_Type := Nodes (Position.Node).Next;
1350 return Cursor'(Position
.Container
, Node
);
1357 Position
: Cursor
) return Cursor
1360 if Position
.Container
= null then
1364 if Checks
and then Position
.Container
/= Object
.Container
then
1365 raise Program_Error
with
1366 "Position cursor of Next designates wrong list";
1369 return Next
(Position
);
1377 (Container
: in out List
;
1378 New_Item
: Element_Type
;
1379 Count
: Count_Type
:= 1)
1382 Insert
(Container
, First
(Container
), New_Item
, Count
);
1389 procedure Previous
(Position
: in out Cursor
) is
1391 Position
:= Previous
(Position
);
1394 function Previous
(Position
: Cursor
) return Cursor
is
1396 if Position
.Node
= 0 then
1400 pragma Assert
(Vet
(Position
), "bad cursor in Previous");
1403 Nodes
: Node_Array
renames Position
.Container
.Nodes
;
1404 Node
: constant Count_Type
:= Nodes
(Position
.Node
).Prev
;
1409 return Cursor
'(Position.Container, Node);
1416 Position : Cursor) return Cursor
1419 if Position.Container = null then
1423 if Checks and then Position.Container /= Object.Container then
1424 raise Program_Error with
1425 "Position cursor of Previous designates wrong list";
1428 return Previous (Position);
1431 ----------------------
1432 -- Pseudo_Reference --
1433 ----------------------
1435 function Pseudo_Reference
1436 (Container : aliased List'Class) return Reference_Control_Type
1438 TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
1440 return R : constant Reference_Control_Type := (Controlled with TC) do
1443 end Pseudo_Reference;
1449 procedure Query_Element
1451 Process : not null access procedure (Element : Element_Type))
1454 if Checks and then Position.Node = 0 then
1455 raise Constraint_Error with
1456 "Position cursor has no element";
1459 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1462 Lock : With_Lock (Position.Container.TC'Unrestricted_Access);
1463 C : List renames Position.Container.all'Unrestricted_Access.all;
1464 N : Node_Type renames C.Nodes (Position.Node);
1466 Process (N.Element);
1475 (S : in out Ada.Strings.Text_Buffers.Root_Buffer_Type'Class; V : List)
1477 First_Time : Boolean := True;
1478 use System.Put_Images;
1484 First_Time := False;
1486 Simple_Array_Between (S);
1489 Element_Type'Put_Image (S, X);
1500 (Stream : not null access Root_Stream_Type'Class;
1503 N : Count_Type'Base;
1508 Count_Type'Base'Read
(Stream
, N
);
1510 if Checks
and then N
< 0 then
1511 raise Program_Error
with "bad list length (corrupt stream)";
1518 if Checks
and then N
> Item
.Capacity
then
1519 raise Constraint_Error
with "length exceeds capacity";
1522 for Idx
in 1 .. N
loop
1523 Allocate
(Item
, Stream
, New_Node
=> X
);
1524 Insert_Internal
(Item
, Before
=> 0, New_Node
=> X
);
1529 (Stream
: not null access Root_Stream_Type
'Class;
1533 raise Program_Error
with "attempt to stream list cursor";
1537 (Stream
: not null access Root_Stream_Type
'Class;
1538 Item
: out Reference_Type
)
1541 raise Program_Error
with "attempt to stream reference";
1545 (Stream
: not null access Root_Stream_Type
'Class;
1546 Item
: out Constant_Reference_Type
)
1549 raise Program_Error
with "attempt to stream reference";
1557 (Container
: aliased in out List
;
1558 Position
: Cursor
) return Reference_Type
1561 if Checks
and then Position
.Container
= null then
1562 raise Constraint_Error
with "Position cursor has no element";
1565 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
1567 raise Program_Error
with
1568 "Position cursor designates wrong container";
1571 pragma Assert
(Vet
(Position
), "bad cursor in function Reference");
1574 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
1575 TC
: constant Tamper_Counts_Access
:=
1576 Container
.TC
'Unrestricted_Access;
1578 return R
: constant Reference_Type
:=
1579 (Element
=> N
.Element
'Unchecked_Access,
1580 Control
=> (Controlled
with TC
))
1587 ---------------------
1588 -- Replace_Element --
1589 ---------------------
1591 procedure Replace_Element
1592 (Container
: in out List
;
1594 New_Item
: Element_Type
)
1597 TE_Check
(Container
.TC
);
1599 if Checks
and then Position
.Container
= null then
1600 raise Constraint_Error
with "Position cursor has no element";
1603 if Checks
and then Position
.Container
/= Container
'Unchecked_Access then
1604 raise Program_Error
with
1605 "Position cursor designates wrong container";
1608 pragma Assert
(Vet
(Position
), "bad cursor in Replace_Element");
1610 Container
.Nodes
(Position
.Node
).Element
:= New_Item
;
1611 end Replace_Element
;
1613 ----------------------
1614 -- Reverse_Elements --
1615 ----------------------
1617 procedure Reverse_Elements
(Container
: in out List
) is
1618 N
: Node_Array
renames Container
.Nodes
;
1619 I
: Count_Type
:= Container
.First
;
1620 J
: Count_Type
:= Container
.Last
;
1622 procedure Swap
(L
, R
: Count_Type
);
1628 procedure Swap
(L
, R
: Count_Type
) is
1629 LN
: constant Count_Type
:= N
(L
).Next
;
1630 LP
: constant Count_Type
:= N
(L
).Prev
;
1632 RN
: constant Count_Type
:= N
(R
).Next
;
1633 RP
: constant Count_Type
:= N
(R
).Prev
;
1648 pragma Assert
(RP
= L
);
1662 -- Start of processing for Reverse_Elements
1665 if Container
.Length
<= 1 then
1669 pragma Assert
(N
(Container
.First
).Prev
= 0);
1670 pragma Assert
(N
(Container
.Last
).Next
= 0);
1672 TC_Check
(Container
.TC
);
1674 Container
.First
:= J
;
1675 Container
.Last
:= I
;
1677 Swap
(L
=> I
, R
=> J
);
1685 Swap
(L
=> J
, R
=> I
);
1694 pragma Assert
(N
(Container
.First
).Prev
= 0);
1695 pragma Assert
(N
(Container
.Last
).Next
= 0);
1696 end Reverse_Elements
;
1702 function Reverse_Find
1704 Item
: Element_Type
;
1705 Position
: Cursor
:= No_Element
) return Cursor
1707 Node
: Count_Type
:= Position
.Node
;
1711 Node
:= Container
.Last
;
1714 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
1716 raise Program_Error
with
1717 "Position cursor designates wrong container";
1720 pragma Assert
(Vet
(Position
), "bad cursor in Reverse_Find");
1723 -- Per AI05-0022, the container implementation is required to detect
1724 -- element tampering by a generic actual subprogram.
1727 Lock
: With_Lock
(Container
.TC
'Unrestricted_Access);
1729 while Node
/= 0 loop
1730 if Container
.Nodes
(Node
).Element
= Item
then
1731 return Cursor
'(Container'Unrestricted_Access, Node);
1734 Node := Container.Nodes (Node).Prev;
1741 ---------------------
1742 -- Reverse_Iterate --
1743 ---------------------
1745 procedure Reverse_Iterate
1747 Process : not null access procedure (Position : Cursor))
1749 Busy : With_Busy (Container.TC'Unrestricted_Access);
1750 Node : Count_Type := Container.Last;
1753 while Node /= 0 loop
1754 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1755 Node
:= Container
.Nodes
(Node
).Prev
;
1757 end Reverse_Iterate
;
1764 (Target
: in out List
;
1766 Source
: in out List
)
1769 TC_Check
(Target
.TC
);
1770 TC_Check
(Source
.TC
);
1772 if Before
.Container
/= null then
1773 if Checks
and then Before
.Container
/= Target
'Unrestricted_Access then
1774 raise Program_Error
with
1775 "Before cursor designates wrong container";
1778 pragma Assert
(Vet
(Before
), "bad cursor in Splice");
1781 if Target
'Address = Source
'Address or else Source
.Length
= 0 then
1785 if Checks
and then Target
.Length
> Count_Type
'Last - Source
.Length
then
1786 raise Constraint_Error
with "new length exceeds maximum";
1789 if Checks
and then Target
.Length
+ Source
.Length
> Target
.Capacity
then
1790 raise Capacity_Error
with "new length exceeds target capacity";
1793 Splice_Internal
(Target
, Before
.Node
, Source
);
1797 (Container
: in out List
;
1801 N
: Node_Array
renames Container
.Nodes
;
1804 TC_Check
(Container
.TC
);
1806 if Before
.Container
/= null then
1807 if Checks
and then Before
.Container
/= Container
'Unchecked_Access then
1808 raise Program_Error
with
1809 "Before cursor designates wrong container";
1812 pragma Assert
(Vet
(Before
), "bad Before cursor in Splice");
1815 if Checks
and then Position
.Node
= 0 then
1816 raise Constraint_Error
with "Position cursor has no element";
1819 if Checks
and then Position
.Container
/= Container
'Unrestricted_Access
1821 raise Program_Error
with
1822 "Position cursor designates wrong container";
1825 pragma Assert
(Vet
(Position
), "bad Position cursor in Splice");
1827 if Position
.Node
= Before
.Node
1828 or else N
(Position
.Node
).Next
= Before
.Node
1833 pragma Assert
(Container
.Length
>= 2);
1835 if Before
.Node
= 0 then
1836 pragma Assert
(Position
.Node
/= Container
.Last
);
1838 if Position
.Node
= Container
.First
then
1839 Container
.First
:= N
(Position
.Node
).Next
;
1840 N
(Container
.First
).Prev
:= 0;
1842 N
(N
(Position
.Node
).Prev
).Next
:= N
(Position
.Node
).Next
;
1843 N
(N
(Position
.Node
).Next
).Prev
:= N
(Position
.Node
).Prev
;
1846 N
(Container
.Last
).Next
:= Position
.Node
;
1847 N
(Position
.Node
).Prev
:= Container
.Last
;
1849 Container
.Last
:= Position
.Node
;
1850 N
(Container
.Last
).Next
:= 0;
1855 if Before
.Node
= Container
.First
then
1856 pragma Assert
(Position
.Node
/= Container
.First
);
1858 if Position
.Node
= Container
.Last
then
1859 Container
.Last
:= N
(Position
.Node
).Prev
;
1860 N
(Container
.Last
).Next
:= 0;
1862 N
(N
(Position
.Node
).Prev
).Next
:= N
(Position
.Node
).Next
;
1863 N
(N
(Position
.Node
).Next
).Prev
:= N
(Position
.Node
).Prev
;
1866 N
(Container
.First
).Prev
:= Position
.Node
;
1867 N
(Position
.Node
).Next
:= Container
.First
;
1869 Container
.First
:= Position
.Node
;
1870 N
(Container
.First
).Prev
:= 0;
1875 if Position
.Node
= Container
.First
then
1876 Container
.First
:= N
(Position
.Node
).Next
;
1877 N
(Container
.First
).Prev
:= 0;
1879 elsif Position
.Node
= Container
.Last
then
1880 Container
.Last
:= N
(Position
.Node
).Prev
;
1881 N
(Container
.Last
).Next
:= 0;
1884 N
(N
(Position
.Node
).Prev
).Next
:= N
(Position
.Node
).Next
;
1885 N
(N
(Position
.Node
).Next
).Prev
:= N
(Position
.Node
).Prev
;
1888 N
(N
(Before
.Node
).Prev
).Next
:= Position
.Node
;
1889 N
(Position
.Node
).Prev
:= N
(Before
.Node
).Prev
;
1891 N
(Before
.Node
).Prev
:= Position
.Node
;
1892 N
(Position
.Node
).Next
:= Before
.Node
;
1894 pragma Assert
(N
(Container
.First
).Prev
= 0);
1895 pragma Assert
(N
(Container
.Last
).Next
= 0);
1899 (Target
: in out List
;
1901 Source
: in out List
;
1902 Position
: in out Cursor
)
1904 Target_Position
: Count_Type
;
1907 if Target
'Address = Source
'Address then
1908 Splice
(Target
, Before
, Position
);
1912 TC_Check
(Target
.TC
);
1913 TC_Check
(Source
.TC
);
1915 if Before
.Container
/= null then
1916 if Checks
and then Before
.Container
/= Target
'Unrestricted_Access then
1917 raise Program_Error
with
1918 "Before cursor designates wrong container";
1921 pragma Assert
(Vet
(Before
), "bad Before cursor in Splice");
1924 if Checks
and then Position
.Node
= 0 then
1925 raise Constraint_Error
with "Position cursor has no element";
1928 if Checks
and then Position
.Container
/= Source
'Unrestricted_Access then
1929 raise Program_Error
with
1930 "Position cursor designates wrong container";
1933 pragma Assert
(Vet
(Position
), "bad Position cursor in Splice");
1935 if Checks
and then Target
.Length
>= Target
.Capacity
then
1936 raise Capacity_Error
with "Target is full";
1941 Before
=> Before
.Node
,
1943 Src_Pos
=> Position
.Node
,
1944 Tgt_Pos
=> Target_Position
);
1946 Position
:= Cursor
'(Target'Unrestricted_Access, Target_Position);
1949 ---------------------
1950 -- Splice_Internal --
1951 ---------------------
1953 procedure Splice_Internal
1954 (Target : in out List;
1955 Before : Count_Type;
1956 Source : in out List)
1958 N : Node_Array renames Source.Nodes;
1962 -- This implements the corresponding Splice operation, after the
1963 -- parameters have been vetted, and corner-cases disposed of.
1965 pragma Assert (Target'Address /= Source'Address);
1966 pragma Assert (Source.Length > 0);
1967 pragma Assert (Source.First /= 0);
1968 pragma Assert (N (Source.First).Prev = 0);
1969 pragma Assert (Source.Last /= 0);
1970 pragma Assert (N (Source.Last).Next = 0);
1971 pragma Assert (Target.Length <= Count_Type'Last - Source.Length);
1972 pragma Assert (Target.Length + Source.Length <= Target.Capacity);
1974 while Source.Length > 1 loop
1975 -- Copy first element of Source onto Target
1977 Allocate (Target, N (Source.First).Element, New_Node => X);
1978 Insert_Internal (Target, Before => Before, New_Node => X);
1980 -- Unlink the first node from Source
1983 pragma Assert (N (N (X).Next).Prev = X);
1985 Source.First := N (X).Next;
1986 N (Source.First).Prev := 0;
1988 Source.Length := Source.Length - 1;
1990 -- Return the Source node to its free store
1995 -- Copy first (and only remaining) element of Source onto Target
1997 Allocate (Target, N (Source.First).Element, New_Node => X);
1998 Insert_Internal (Target, Before => Before, New_Node => X);
2000 -- Unlink the node from Source
2003 pragma Assert (X = Source.Last);
2010 -- Return the Source node to its free store
2013 end Splice_Internal;
2015 procedure Splice_Internal
2016 (Target : in out List;
2017 Before : Count_Type; -- node of Target
2018 Source : in out List;
2019 Src_Pos : Count_Type; -- node of Source
2020 Tgt_Pos : out Count_Type)
2022 N : Node_Array renames Source.Nodes;
2025 -- This implements the corresponding Splice operation, after the
2026 -- parameters have been vetted, and corner-cases handled.
2028 pragma Assert (Target'Address /= Source'Address);
2029 pragma Assert (Target.Length < Target.Capacity);
2030 pragma Assert (Source.Length > 0);
2031 pragma Assert (Source.First /= 0);
2032 pragma Assert (N (Source.First).Prev = 0);
2033 pragma Assert (Source.Last /= 0);
2034 pragma Assert (N (Source.Last).Next = 0);
2035 pragma Assert (Src_Pos /= 0);
2037 Allocate (Target, N (Src_Pos).Element, New_Node => Tgt_Pos);
2038 Insert_Internal (Target, Before => Before, New_Node => Tgt_Pos);
2040 if Source.Length = 1 then
2041 pragma Assert (Source.First = Source.Last);
2042 pragma Assert (Src_Pos = Source.First);
2047 elsif Src_Pos = Source.First then
2048 pragma Assert (N (N (Src_Pos).Next).Prev = Src_Pos);
2050 Source.First := N (Src_Pos).Next;
2051 N (Source.First).Prev := 0;
2053 elsif Src_Pos = Source.Last then
2054 pragma Assert (N (N (Src_Pos).Prev).Next = Src_Pos);
2056 Source.Last := N (Src_Pos).Prev;
2057 N (Source.Last).Next := 0;
2060 pragma Assert (Source.Length >= 3);
2061 pragma Assert (N (N (Src_Pos).Next).Prev = Src_Pos);
2062 pragma Assert (N (N (Src_Pos).Prev).Next = Src_Pos);
2064 N (N (Src_Pos).Next).Prev := N (Src_Pos).Prev;
2065 N (N (Src_Pos).Prev).Next := N (Src_Pos).Next;
2068 Source.Length := Source.Length - 1;
2069 Free (Source, Src_Pos);
2070 end Splice_Internal;
2077 (Container : in out List;
2081 TE_Check (Container.TC);
2083 if Checks and then I.Node = 0 then
2084 raise Constraint_Error with "I cursor has no element";
2087 if Checks and then J.Node = 0 then
2088 raise Constraint_Error with "J cursor has no element";
2091 if Checks and then I.Container /= Container'Unchecked_Access then
2092 raise Program_Error with "I cursor designates wrong container";
2095 if Checks and then J.Container /= Container'Unchecked_Access then
2096 raise Program_Error with "J cursor designates wrong container";
2099 if I.Node = J.Node then
2103 pragma Assert (Vet (I), "bad I cursor in Swap");
2104 pragma Assert (Vet (J), "bad J cursor in Swap");
2107 EI : Element_Type renames Container.Nodes (I.Node).Element;
2108 EJ : Element_Type renames Container.Nodes (J.Node).Element;
2110 EI_Copy : constant Element_Type := EI;
2122 procedure Swap_Links
2123 (Container : in out List;
2127 TC_Check (Container.TC);
2129 if Checks and then I.Node = 0 then
2130 raise Constraint_Error with "I cursor has no element";
2133 if Checks and then J.Node = 0 then
2134 raise Constraint_Error with "J cursor has no element";
2137 if Checks and then I.Container /= Container'Unrestricted_Access then
2138 raise Program_Error with "I cursor designates wrong container";
2141 if Checks and then J.Container /= Container'Unrestricted_Access then
2142 raise Program_Error with "J cursor designates wrong container";
2145 if I.Node = J.Node then
2149 pragma Assert (Vet (I), "bad I cursor in Swap_Links");
2150 pragma Assert (Vet (J), "bad J cursor in Swap_Links");
2153 I_Next : constant Cursor := Next (I);
2157 Splice (Container, Before => I, Position => J);
2161 J_Next : constant Cursor := Next (J);
2165 Splice (Container, Before => J, Position => I);
2168 pragma Assert (Container.Length >= 3);
2170 Splice (Container, Before => I_Next, Position => J);
2171 Splice (Container, Before => J_Next, Position => I);
2178 --------------------
2179 -- Update_Element --
2180 --------------------
2182 procedure Update_Element
2183 (Container : in out List;
2185 Process : not null access procedure (Element : in out Element_Type))
2188 if Checks and then Position.Node = 0 then
2189 raise Constraint_Error with "Position cursor has no element";
2192 if Checks and then Position.Container /= Container'Unchecked_Access then
2193 raise Program_Error with
2194 "Position cursor designates wrong container";
2197 pragma Assert (Vet (Position), "bad cursor in Update_Element");
2200 Lock : With_Lock (Container.TC'Unchecked_Access);
2201 N : Node_Type renames Container.Nodes (Position.Node);
2203 Process (N.Element);
2211 function Vet (Position : Cursor) return Boolean is
2213 if not Container_Checks'Enabled then
2217 if Position.Node = 0 then
2218 return Position.Container = null;
2221 if Position.Container = null then
2226 L : List renames Position.Container.all;
2227 N : Node_Array renames L.Nodes;
2230 if L.Length = 0 then
2234 if L.First = 0 or L.First > L.Capacity then
2238 if L.Last = 0 or L.Last > L.Capacity then
2242 if N (L.First).Prev /= 0 then
2246 if N (L.Last).Next /= 0 then
2250 if Position.Node > L.Capacity then
2254 -- An invariant of an active node is that its Previous and Next
2255 -- components are non-negative. Operation Free sets the Previous
2256 -- component of the node to the value -1 before actually deallocating
2257 -- the node, to mark the node as inactive. (By "dellocating" we mean
2258 -- only that the node is linked onto a list of inactive nodes used
2259 -- for storage.) This marker gives us a simple way to detect a
2260 -- dangling reference to a node.
2262 if N (Position.Node).Prev < 0 then -- see Free
2266 if N (Position.Node).Prev > L.Capacity then
2270 if N (Position.Node).Next = Position.Node then
2274 if N (Position.Node).Prev = Position.Node then
2278 if N (Position.Node).Prev = 0
2279 and then Position.Node /= L.First
2284 pragma Assert (N (Position.Node).Prev /= 0
2285 or else Position.Node = L.First);
2287 if N (Position.Node).Next = 0
2288 and then Position.Node /= L.Last
2293 pragma Assert (N (Position.Node).Next /= 0
2294 or else Position.Node = L.Last);
2296 if L.Length = 1 then
2297 return L.First = L.Last;
2300 if L.First = L.Last then
2304 if N (L.First).Next = 0 then
2308 if N (L.Last).Prev = 0 then
2312 if N (N (L.First).Next).Prev /= L.First then
2316 if N (N (L.Last).Prev).Next /= L.Last then
2320 if L.Length = 2 then
2321 if N (L.First).Next /= L.Last then
2325 if N (L.Last).Prev /= L.First then
2332 if N (L.First).Next = L.Last then
2336 if N (L.Last).Prev = L.First then
2340 -- Eliminate earlier possibility
2342 if Position.Node = L.First then
2346 pragma Assert (N (Position.Node).Prev /= 0);
2348 -- Eliminate another possibility
2350 if Position.Node = L.Last then
2354 pragma Assert (N (Position.Node).Next /= 0);
2356 if N (N (Position.Node).Next).Prev /= Position.Node then
2360 if N (N (Position.Node).Prev).Next /= Position.Node then
2364 if L.Length = 3 then
2365 if N (L.First).Next /= Position.Node then
2369 if N (L.Last).Prev /= Position.Node then
2383 (Stream : not null access Root_Stream_Type'Class;
2389 Count_Type'Base'Write
(Stream
, Item
.Length
);
2392 while Node
/= 0 loop
2393 Element_Type
'Write (Stream
, Item
.Nodes
(Node
).Element
);
2394 Node
:= Item
.Nodes
(Node
).Next
;
2399 (Stream
: not null access Root_Stream_Type
'Class;
2403 raise Program_Error
with "attempt to stream list cursor";
2407 (Stream
: not null access Root_Stream_Type
'Class;
2408 Item
: Reference_Type
)
2411 raise Program_Error
with "attempt to stream reference";
2415 (Stream
: not null access Root_Stream_Type
'Class;
2416 Item
: Constant_Reference_Type
)
2419 raise Program_Error
with "attempt to stream reference";
2422 end Ada
.Containers
.Bounded_Doubly_Linked_Lists
;