1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS --
9 -- Copyright (C) 2004-2010, 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 System
; use type System
.Address
;
32 package body Ada
.Containers
.Bounded_Doubly_Linked_Lists
is
34 -----------------------
35 -- Local Subprograms --
36 -----------------------
39 (Container
: in out List
;
40 New_Item
: Element_Type
;
41 New_Node
: out Count_Type
);
44 (Container
: in out List
;
45 New_Node
: out Count_Type
);
48 (Container
: in out List
;
49 Stream
: not null access Root_Stream_Type
'Class;
50 New_Node
: out Count_Type
);
53 (Container
: in out List
;
56 procedure Insert_Internal
57 (Container
: in out List
;
59 New_Node
: Count_Type
);
61 function Vet
(Position
: Cursor
) return Boolean;
67 function "=" (Left
, Right
: List
) return Boolean is
68 LN
: Node_Array
renames Left
.Nodes
;
69 RN
: Node_Array
renames Right
.Nodes
;
74 if Left
'Address = Right
'Address then
78 if Left
.Length
/= Right
.Length
then
84 for J
in 1 .. Left
.Length
loop
85 if LN
(LI
).Element
/= RN
(RI
).Element
then
101 (Container
: in out List
;
102 New_Item
: Element_Type
;
103 New_Node
: out Count_Type
)
105 N
: Node_Array
renames Container
.Nodes
;
108 if Container
.Free
>= 0 then
109 New_Node
:= Container
.Free
;
111 -- We always perform the assignment first, before we
112 -- change container state, in order to defend against
113 -- exceptions duration assignment.
115 N
(New_Node
).Element
:= New_Item
;
116 Container
.Free
:= N
(New_Node
).Next
;
119 -- A negative free store value means that the links of the nodes
120 -- in the free store have not been initialized. In this case, the
121 -- nodes are physically contiguous in the array, starting at the
122 -- index that is the absolute value of the Container.Free, and
123 -- continuing until the end of the array (Nodes'Last).
125 New_Node
:= abs Container
.Free
;
127 -- As above, we perform this assignment first, before modifying
128 -- any container state.
130 N
(New_Node
).Element
:= New_Item
;
131 Container
.Free
:= Container
.Free
- 1;
136 (Container
: in out List
;
137 Stream
: not null access Root_Stream_Type
'Class;
138 New_Node
: out Count_Type
)
140 N
: Node_Array
renames Container
.Nodes
;
143 if Container
.Free
>= 0 then
144 New_Node
:= Container
.Free
;
146 -- We always perform the assignment first, before we
147 -- change container state, in order to defend against
148 -- exceptions duration assignment.
150 Element_Type
'Read (Stream
, N
(New_Node
).Element
);
151 Container
.Free
:= N
(New_Node
).Next
;
154 -- A negative free store value means that the links of the nodes
155 -- in the free store have not been initialized. In this case, the
156 -- nodes are physically contiguous in the array, starting at the
157 -- index that is the absolute value of the Container.Free, and
158 -- continuing until the end of the array (Nodes'Last).
160 New_Node
:= abs Container
.Free
;
162 -- As above, we perform this assignment first, before modifying
163 -- any container state.
165 Element_Type
'Read (Stream
, N
(New_Node
).Element
);
166 Container
.Free
:= Container
.Free
- 1;
171 (Container
: in out List
;
172 New_Node
: out Count_Type
)
174 N
: Node_Array
renames Container
.Nodes
;
177 if Container
.Free
>= 0 then
178 New_Node
:= Container
.Free
;
179 Container
.Free
:= N
(New_Node
).Next
;
182 -- As explained above, a negative free store value means that the
183 -- links for the nodes in the free store have not been initialized.
185 New_Node
:= abs Container
.Free
;
186 Container
.Free
:= Container
.Free
- 1;
195 (Container
: in out List
;
196 New_Item
: Element_Type
;
197 Count
: Count_Type
:= 1)
200 Insert
(Container
, No_Element
, New_Item
, Count
);
207 procedure Assign
(Target
: in out List
; Source
: List
) is
208 SN
: Node_Array
renames Source
.Nodes
;
212 if Target
'Address = Source
'Address then
216 if Target
.Capacity
< Source
.Length
then
217 raise Capacity_Error
-- ???
218 with "Target capacity is less than Source length";
225 Target
.Append
(SN
(J
).Element
);
234 procedure Clear
(Container
: in out List
) is
235 N
: Node_Array
renames Container
.Nodes
;
239 if Container
.Length
= 0 then
240 pragma Assert
(Container
.First
= 0);
241 pragma Assert
(Container
.Last
= 0);
242 pragma Assert
(Container
.Busy
= 0);
243 pragma Assert
(Container
.Lock
= 0);
247 pragma Assert
(Container
.First
>= 1);
248 pragma Assert
(Container
.Last
>= 1);
249 pragma Assert
(N
(Container
.First
).Prev
= 0);
250 pragma Assert
(N
(Container
.Last
).Next
= 0);
252 if Container
.Busy
> 0 then
253 raise Program_Error
with
254 "attempt to tamper with cursors (list is busy)";
257 while Container
.Length
> 1 loop
258 X
:= Container
.First
;
259 pragma Assert
(N
(N
(X
).Next
).Prev
= Container
.First
);
261 Container
.First
:= N
(X
).Next
;
262 N
(Container
.First
).Prev
:= 0;
264 Container
.Length
:= Container
.Length
- 1;
269 X
:= Container
.First
;
270 pragma Assert
(X
= Container
.Last
);
272 Container
.First
:= 0;
274 Container
.Length
:= 0;
285 Item
: Element_Type
) return Boolean
288 return Find
(Container
, Item
) /= No_Element
;
295 function Copy
(Source
: List
; Capacity
: Count_Type
:= 0) return List
is
302 elsif Capacity
>= Source
.Length
then
306 raise Capacity_Error
with "Capacity value too small";
309 return Target
: List
(Capacity
=> C
) do
310 Assign
(Target
=> Target
, Source
=> Source
);
319 (Container
: in out List
;
320 Position
: in out Cursor
;
321 Count
: Count_Type
:= 1)
323 N
: Node_Array
renames Container
.Nodes
;
327 if Position
.Node
= 0 then
328 raise Constraint_Error
with
329 "Position cursor has no element";
332 if Position
.Container
/= Container
'Unrestricted_Access then
333 raise Program_Error
with
334 "Position cursor designates wrong container";
337 pragma Assert
(Vet
(Position
), "bad cursor in Delete");
338 pragma Assert
(Container
.First
>= 1);
339 pragma Assert
(Container
.Last
>= 1);
340 pragma Assert
(N
(Container
.First
).Prev
= 0);
341 pragma Assert
(N
(Container
.Last
).Next
= 0);
343 if Position
.Node
= Container
.First
then
344 Delete_First
(Container
, Count
);
345 Position
:= No_Element
;
350 Position
:= No_Element
;
354 if Container
.Busy
> 0 then
355 raise Program_Error
with
356 "attempt to tamper with cursors (list is busy)";
359 for Index
in 1 .. Count
loop
360 pragma Assert
(Container
.Length
>= 2);
363 Container
.Length
:= Container
.Length
- 1;
365 if X
= Container
.Last
then
366 Position
:= No_Element
;
368 Container
.Last
:= N
(X
).Prev
;
369 N
(Container
.Last
).Next
:= 0;
375 Position
.Node
:= N
(X
).Next
;
377 N
(N
(X
).Next
).Prev
:= N
(X
).Prev
;
378 N
(N
(X
).Prev
).Next
:= N
(X
).Next
;
383 Position
:= No_Element
;
390 procedure Delete_First
391 (Container
: in out List
;
392 Count
: Count_Type
:= 1)
394 N
: Node_Array
renames Container
.Nodes
;
398 if Count
>= Container
.Length
then
407 if Container
.Busy
> 0 then
408 raise Program_Error
with
409 "attempt to tamper with cursors (list is busy)";
412 for I
in 1 .. Count
loop
413 X
:= Container
.First
;
414 pragma Assert
(N
(N
(X
).Next
).Prev
= Container
.First
);
416 Container
.First
:= N
(X
).Next
;
417 N
(Container
.First
).Prev
:= 0;
419 Container
.Length
:= Container
.Length
- 1;
429 procedure Delete_Last
430 (Container
: in out List
;
431 Count
: Count_Type
:= 1)
433 N
: Node_Array
renames Container
.Nodes
;
437 if Count
>= Container
.Length
then
446 if Container
.Busy
> 0 then
447 raise Program_Error
with
448 "attempt to tamper with cursors (list is busy)";
451 for I
in 1 .. Count
loop
453 pragma Assert
(N
(N
(X
).Prev
).Next
= Container
.Last
);
455 Container
.Last
:= N
(X
).Prev
;
456 N
(Container
.Last
).Next
:= 0;
458 Container
.Length
:= Container
.Length
- 1;
468 function Element
(Position
: Cursor
) return Element_Type
is
470 if Position
.Node
= 0 then
471 raise Constraint_Error
with
472 "Position cursor has no element";
475 pragma Assert
(Vet
(Position
), "bad cursor in Element");
477 return Position
.Container
.Nodes
(Position
.Node
).Element
;
487 Position
: Cursor
:= No_Element
) return Cursor
489 Nodes
: Node_Array
renames Container
.Nodes
;
490 Node
: Count_Type
:= Position
.Node
;
494 Node
:= Container
.First
;
497 if Position
.Container
/= Container
'Unrestricted_Access then
498 raise Program_Error
with
499 "Position cursor designates wrong container";
502 pragma Assert
(Vet
(Position
), "bad cursor in Find");
506 if Nodes
(Node
).Element
= Item
then
507 return Cursor
'(Container'Unrestricted_Access, Node);
510 Node := Nodes (Node).Next;
520 function First (Container : List) return Cursor is
522 if Container.First = 0 then
526 return Cursor'(Container
'Unrestricted_Access, Container
.First
);
533 function First_Element
(Container
: List
) return Element_Type
is
535 if Container
.First
= 0 then
536 raise Constraint_Error
with "list is empty";
539 return Container
.Nodes
(Container
.First
).Element
;
547 (Container
: in out List
;
550 pragma Assert
(X
> 0);
551 pragma Assert
(X
<= Container
.Capacity
);
553 N
: Node_Array
renames Container
.Nodes
;
554 pragma Assert
(N
(X
).Prev
>= 0); -- node is active
557 -- The list container actually contains two lists: one for the "active"
558 -- nodes that contain elements that have been inserted onto the list,
559 -- and another for the "inactive" nodes for the free store.
561 -- We desire that merely declaring an object should have only minimal
562 -- cost; specially, we want to avoid having to initialize the free
563 -- store (to fill in the links), especially if the capacity is large.
565 -- The head of the free list is indicated by Container.Free. If its
566 -- value is non-negative, then the free store has been initialized
567 -- in the "normal" way: Container.Free points to the head of the list
568 -- of free (inactive) nodes, and the value 0 means the free list is
569 -- empty. Each node on the free list has been initialized to point
570 -- to the next free node (via its Next component), and the value 0
571 -- means that this is the last free node.
573 -- If Container.Free is negative, then the links on the free store
574 -- have not been initialized. In this case the link values are
575 -- implied: the free store comprises the components of the node array
576 -- started with the absolute value of Container.Free, and continuing
577 -- until the end of the array (Nodes'Last).
579 -- If the list container is manipulated on one end only (for example
580 -- if the container were being used as a stack), then there is no
581 -- need to initialize the free store, since the inactive nodes are
582 -- physically contiguous (in fact, they lie immediately beyond the
583 -- logical end being manipulated). The only time we need to actually
584 -- initialize the nodes in the free store is if the node that becomes
585 -- inactive is not at the end of the list. The free store would then
586 -- be discontiguous and so its nodes would need to be linked in the
590 -- It might be possible to perform an optimization here. Suppose that
591 -- the free store can be represented as having two parts: one
592 -- comprising the non-contiguous inactive nodes linked together
593 -- in the normal way, and the other comprising the contiguous
594 -- inactive nodes (that are not linked together, at the end of the
595 -- nodes array). This would allow us to never have to initialize
596 -- the free store, except in a lazy way as nodes become inactive.
598 -- When an element is deleted from the list container, its node
599 -- becomes inactive, and so we set its Prev component to a negative
600 -- value, to indicate that it is now inactive. This provides a useful
601 -- way to detect a dangling cursor reference.
603 N
(X
).Prev
:= -1; -- Node is deallocated (not on active list)
605 if Container
.Free
>= 0 then
606 -- The free store has previously been initialized. All we need to
607 -- do here is link the newly-free'd node onto the free list.
609 N
(X
).Next
:= Container
.Free
;
612 elsif X
+ 1 = abs Container
.Free
then
613 -- The free store has not been initialized, and the node becoming
614 -- inactive immediately precedes the start of the free store. All
615 -- we need to do is move the start of the free store back by one.
617 N
(X
).Next
:= 0; -- Not strictly necessary, but marginally safer
618 Container
.Free
:= Container
.Free
+ 1;
621 -- The free store has not been initialized, and the node becoming
622 -- inactive does not immediately precede the free store. Here we
623 -- first initialize the free store (meaning the links are given
624 -- values in the traditional way), and then link the newly-free'd
625 -- node onto the head of the free store.
628 -- See the comments above for an optimization opportunity. If
629 -- the next link for a node on the free store is negative, then
630 -- this means the remaining nodes on the free store are
631 -- physically contiguous, starting as the absolute value of
634 Container
.Free
:= abs Container
.Free
;
636 if Container
.Free
> Container
.Capacity
then
640 for I
in Container
.Free
.. Container
.Capacity
- 1 loop
644 N
(Container
.Capacity
).Next
:= 0;
647 N
(X
).Next
:= Container
.Free
;
652 ---------------------
653 -- Generic_Sorting --
654 ---------------------
656 package body Generic_Sorting
is
662 function Is_Sorted
(Container
: List
) return Boolean is
663 Nodes
: Node_Array
renames Container
.Nodes
;
664 Node
: Count_Type
:= Container
.First
;
667 for I
in 2 .. Container
.Length
loop
668 if Nodes
(Nodes
(Node
).Next
).Element
< Nodes
(Node
).Element
then
672 Node
:= Nodes
(Node
).Next
;
683 (Target
: in out List
;
684 Source
: in out List
)
686 LN
: Node_Array
renames Target
.Nodes
;
687 RN
: Node_Array
renames Source
.Nodes
;
691 if Target
'Address = Source
'Address then
695 if Target
.Busy
> 0 then
696 raise Program_Error
with
697 "attempt to tamper with cursors of Target (list is busy)";
700 if Source
.Busy
> 0 then
701 raise Program_Error
with
702 "attempt to tamper with cursors of Source (list is busy)";
705 LI
:= First
(Target
);
706 RI
:= First
(Source
);
707 while RI
.Node
/= 0 loop
708 pragma Assert
(RN
(RI
.Node
).Next
= 0
709 or else not (RN
(RN
(RI
.Node
).Next
).Element
<
710 RN
(RI
.Node
).Element
));
713 Splice
(Target
, No_Element
, Source
);
717 pragma Assert
(LN
(LI
.Node
).Next
= 0
718 or else not (LN
(LN
(LI
.Node
).Next
).Element
<
719 LN
(LI
.Node
).Element
));
721 if RN
(RI
.Node
).Element
< LN
(LI
.Node
).Element
then
724 pragma Warnings
(Off
, RJ
);
726 RI
.Node
:= RN
(RI
.Node
).Next
;
727 Splice
(Target
, LI
, Source
, RJ
);
731 LI
.Node
:= LN
(LI
.Node
).Next
;
740 procedure Sort
(Container
: in out List
) is
741 N
: Node_Array
renames Container
.Nodes
;
743 procedure Partition
(Pivot
, Back
: Count_Type
);
745 procedure Sort
(Front
, Back
: Count_Type
);
751 procedure Partition
(Pivot
, Back
: Count_Type
) is
752 Node
: Count_Type
:= N
(Pivot
).Next
;
755 while Node
/= Back
loop
756 if N
(Node
).Element
< N
(Pivot
).Element
then
758 Prev
: constant Count_Type
:= N
(Node
).Prev
;
759 Next
: constant Count_Type
:= N
(Node
).Next
;
762 N
(Prev
).Next
:= Next
;
765 Container
.Last
:= Prev
;
767 N
(Next
).Prev
:= Prev
;
770 N
(Node
).Next
:= Pivot
;
771 N
(Node
).Prev
:= N
(Pivot
).Prev
;
773 N
(Pivot
).Prev
:= Node
;
775 if N
(Node
).Prev
= 0 then
776 Container
.First
:= Node
;
778 N
(N
(Node
).Prev
).Next
:= Node
;
785 Node
:= N
(Node
).Next
;
794 procedure Sort
(Front
, Back
: Count_Type
) is
795 Pivot
: constant Count_Type
:=
796 (if Front
= 0 then Container
.First
else N
(Front
).Next
);
798 if Pivot
/= Back
then
799 Partition
(Pivot
, Back
);
805 -- Start of processing for Sort
808 if Container
.Length
<= 1 then
812 pragma Assert
(N
(Container
.First
).Prev
= 0);
813 pragma Assert
(N
(Container
.Last
).Next
= 0);
815 if Container
.Busy
> 0 then
816 raise Program_Error
with
817 "attempt to tamper with cursors (list is busy)";
820 Sort
(Front
=> 0, Back
=> 0);
822 pragma Assert
(N
(Container
.First
).Prev
= 0);
823 pragma Assert
(N
(Container
.Last
).Next
= 0);
832 function Has_Element
(Position
: Cursor
) return Boolean is
834 pragma Assert
(Vet
(Position
), "bad cursor in Has_Element");
835 return Position
.Node
/= 0;
843 (Container
: in out List
;
845 New_Item
: Element_Type
;
846 Position
: out Cursor
;
847 Count
: Count_Type
:= 1)
849 New_Node
: Count_Type
;
852 if Before
.Container
/= null then
853 if Before
.Container
/= Container
'Unrestricted_Access then
854 raise Program_Error
with
855 "Before cursor designates wrong list";
858 pragma Assert
(Vet
(Before
), "bad cursor in Insert");
866 if Container
.Length
> Container
.Capacity
- Count
then
867 raise Constraint_Error
with "new length exceeds capacity";
870 if Container
.Busy
> 0 then
871 raise Program_Error
with
872 "attempt to tamper with cursors (list is busy)";
875 Allocate
(Container
, New_Item
, New_Node
);
876 Insert_Internal
(Container
, Before
.Node
, New_Node
=> New_Node
);
877 Position
:= Cursor
'(Container'Unchecked_Access, Node => New_Node);
879 for Index in Count_Type'(2) .. Count
loop
880 Allocate
(Container
, New_Item
, New_Node
=> New_Node
);
881 Insert_Internal
(Container
, Before
.Node
, New_Node
=> New_Node
);
886 (Container
: in out List
;
888 New_Item
: Element_Type
;
889 Count
: Count_Type
:= 1)
892 pragma Unreferenced
(Position
);
894 Insert
(Container
, Before
, New_Item
, Position
, Count
);
898 (Container
: in out List
;
900 Position
: out Cursor
;
901 Count
: Count_Type
:= 1)
903 New_Node
: Count_Type
;
906 if Before
.Container
/= null then
907 if Before
.Container
/= Container
'Unrestricted_Access then
908 raise Program_Error
with
909 "Before cursor designates wrong list";
912 pragma Assert
(Vet
(Before
), "bad cursor in Insert");
920 if Container
.Length
> Container
.Capacity
- Count
then
921 raise Constraint_Error
with "new length exceeds capacity";
924 if Container
.Busy
> 0 then
925 raise Program_Error
with
926 "attempt to tamper with cursors (list is busy)";
929 Allocate
(Container
, New_Node
=> New_Node
);
930 Insert_Internal
(Container
, Before
.Node
, New_Node
);
931 Position
:= Cursor
'(Container'Unchecked_Access, New_Node);
933 for Index in Count_Type'(2) .. Count
loop
934 Allocate
(Container
, New_Node
=> New_Node
);
935 Insert_Internal
(Container
, Before
.Node
, New_Node
);
939 ---------------------
940 -- Insert_Internal --
941 ---------------------
943 procedure Insert_Internal
944 (Container
: in out List
;
946 New_Node
: Count_Type
)
948 N
: Node_Array
renames Container
.Nodes
;
951 if Container
.Length
= 0 then
952 pragma Assert
(Before
= 0);
953 pragma Assert
(Container
.First
= 0);
954 pragma Assert
(Container
.Last
= 0);
956 Container
.First
:= New_Node
;
957 N
(Container
.First
).Prev
:= 0;
959 Container
.Last
:= New_Node
;
960 N
(Container
.Last
).Next
:= 0;
962 elsif Before
= 0 then -- means append
963 pragma Assert
(N
(Container
.Last
).Next
= 0);
965 N
(Container
.Last
).Next
:= New_Node
;
966 N
(New_Node
).Prev
:= Container
.Last
;
968 Container
.Last
:= New_Node
;
969 N
(Container
.Last
).Next
:= 0;
971 elsif Before
= Container
.First
then -- means prepend
972 pragma Assert
(N
(Container
.First
).Prev
= 0);
974 N
(Container
.First
).Prev
:= New_Node
;
975 N
(New_Node
).Next
:= Container
.First
;
977 Container
.First
:= New_Node
;
978 N
(Container
.First
).Prev
:= 0;
981 pragma Assert
(N
(Container
.First
).Prev
= 0);
982 pragma Assert
(N
(Container
.Last
).Next
= 0);
984 N
(New_Node
).Next
:= Before
;
985 N
(New_Node
).Prev
:= N
(Before
).Prev
;
987 N
(N
(Before
).Prev
).Next
:= New_Node
;
988 N
(Before
).Prev
:= New_Node
;
991 Container
.Length
:= Container
.Length
+ 1;
998 function Is_Empty
(Container
: List
) return Boolean is
1000 return Container
.Length
= 0;
1009 Process
: not null access procedure (Position
: Cursor
))
1011 C
: List
renames Container
'Unrestricted_Access.all;
1012 B
: Natural renames C
.Busy
;
1014 Node
: Count_Type
:= Container
.First
;
1020 while Node
/= 0 loop
1021 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1022 Node := Container.Nodes (Node).Next;
1037 function Last (Container : List) return Cursor is
1039 if Container.Last = 0 then
1043 return Cursor'(Container
'Unrestricted_Access, Container
.Last
);
1050 function Last_Element
(Container
: List
) return Element_Type
is
1052 if Container
.Last
= 0 then
1053 raise Constraint_Error
with "list is empty";
1056 return Container
.Nodes
(Container
.Last
).Element
;
1063 function Length
(Container
: List
) return Count_Type
is
1065 return Container
.Length
;
1073 (Target
: in out List
;
1074 Source
: in out List
)
1076 N
: Node_Array
renames Source
.Nodes
;
1080 if Target
'Address = Source
'Address then
1084 if Target
.Capacity
< Source
.Length
then
1085 raise Capacity_Error
with "Source length exceeds Target capacity";
1088 if Source
.Busy
> 0 then
1089 raise Program_Error
with
1090 "attempt to tamper with cursors of Source (list is busy)";
1095 while Source
.Length
> 0 loop
1097 Append
(Target
, N
(X
).Element
);
1099 Source
.First
:= N
(X
).Next
;
1100 N
(Source
.First
).Prev
:= 0;
1102 Source
.Length
:= Source
.Length
- 1;
1111 procedure Next
(Position
: in out Cursor
) is
1113 Position
:= Next
(Position
);
1116 function Next
(Position
: Cursor
) return Cursor
is
1118 if Position
.Node
= 0 then
1122 pragma Assert
(Vet
(Position
), "bad cursor in Next");
1125 Nodes
: Node_Array
renames Position
.Container
.Nodes
;
1126 Node
: constant Count_Type
:= Nodes
(Position
.Node
).Next
;
1132 return Cursor
'(Position.Container, Node);
1141 (Container : in out List;
1142 New_Item : Element_Type;
1143 Count : Count_Type := 1)
1146 Insert (Container, First (Container), New_Item, Count);
1153 procedure Previous (Position : in out Cursor) is
1155 Position := Previous (Position);
1158 function Previous (Position : Cursor) return Cursor is
1160 if Position.Node = 0 then
1164 pragma Assert (Vet (Position), "bad cursor in Previous");
1167 Nodes : Node_Array renames Position.Container.Nodes;
1168 Node : constant Count_Type := Nodes (Position.Node).Prev;
1174 return Cursor'(Position
.Container
, Node
);
1182 procedure Query_Element
1184 Process
: not null access procedure (Element
: Element_Type
))
1187 if Position
.Node
= 0 then
1188 raise Constraint_Error
with
1189 "Position cursor has no element";
1192 pragma Assert
(Vet
(Position
), "bad cursor in Query_Element");
1195 C
: List
renames Position
.Container
.all'Unrestricted_Access.all;
1196 B
: Natural renames C
.Busy
;
1197 L
: Natural renames C
.Lock
;
1204 N
: Node_Type
renames C
.Nodes
(Position
.Node
);
1206 Process
(N
.Element
);
1224 (Stream
: not null access Root_Stream_Type
'Class;
1227 N
: Count_Type
'Base;
1232 Count_Type
'Base'Read (Stream, N);
1235 raise Program_Error with "bad list length (corrupt stream)";
1242 if N > Item.Capacity then
1243 raise Constraint_Error with "length exceeds capacity";
1246 for Idx in 1 .. N loop
1247 Allocate (Item, Stream, New_Node => X);
1248 Insert_Internal (Item, Before => 0, New_Node => X);
1253 (Stream : not null access Root_Stream_Type'Class;
1257 raise Program_Error with "attempt to stream list cursor";
1260 ---------------------
1261 -- Replace_Element --
1262 ---------------------
1264 procedure Replace_Element
1265 (Container : in out List;
1267 New_Item : Element_Type)
1270 if Position.Container = null then
1271 raise Constraint_Error with "Position cursor has no element";
1274 if Position.Container /= Container'Unchecked_Access then
1275 raise Program_Error with
1276 "Position cursor designates wrong container";
1279 if Container.Lock > 0 then
1280 raise Program_Error with
1281 "attempt to tamper with elements (list is locked)";
1284 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1286 Container.Nodes (Position.Node).Element := New_Item;
1287 end Replace_Element;
1289 ----------------------
1290 -- Reverse_Elements --
1291 ----------------------
1293 procedure Reverse_Elements (Container : in out List) is
1294 N : Node_Array renames Container.Nodes;
1295 I : Count_Type := Container.First;
1296 J : Count_Type := Container.Last;
1298 procedure Swap (L, R : Count_Type);
1304 procedure Swap (L, R : Count_Type) is
1305 LN : constant Count_Type := N (L).Next;
1306 LP : constant Count_Type := N (L).Prev;
1308 RN : constant Count_Type := N (R).Next;
1309 RP : constant Count_Type := N (R).Prev;
1324 pragma Assert (RP = L);
1338 -- Start of processing for Reverse_Elements
1341 if Container.Length <= 1 then
1345 pragma Assert (N (Container.First).Prev = 0);
1346 pragma Assert (N (Container.Last).Next = 0);
1348 if Container.Busy > 0 then
1349 raise Program_Error with
1350 "attempt to tamper with cursors (list is busy)";
1353 Container.First := J;
1354 Container.Last := I;
1356 Swap (L => I, R => J);
1364 Swap (L => J, R => I);
1373 pragma Assert (N (Container.First).Prev = 0);
1374 pragma Assert (N (Container.Last).Next = 0);
1375 end Reverse_Elements;
1381 function Reverse_Find
1383 Item : Element_Type;
1384 Position : Cursor := No_Element) return Cursor
1386 Node : Count_Type := Position.Node;
1390 Node := Container.Last;
1393 if Position.Container /= Container'Unrestricted_Access then
1394 raise Program_Error with
1395 "Position cursor designates wrong container";
1398 pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1401 while Node /= 0 loop
1402 if Container.Nodes (Node).Element = Item then
1403 return Cursor'(Container
'Unrestricted_Access, Node
);
1406 Node
:= Container
.Nodes
(Node
).Prev
;
1412 ---------------------
1413 -- Reverse_Iterate --
1414 ---------------------
1416 procedure Reverse_Iterate
1418 Process
: not null access procedure (Position
: Cursor
))
1420 C
: List
renames Container
'Unrestricted_Access.all;
1421 B
: Natural renames C
.Busy
;
1423 Node
: Count_Type
:= Container
.Last
;
1429 while Node
/= 0 loop
1430 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1431 Node := Container.Nodes (Node).Prev;
1441 end Reverse_Iterate;
1448 (Target : in out List;
1450 Source : in out List)
1453 if Before.Container /= null then
1454 if Before.Container /= Target'Unrestricted_Access then
1455 raise Program_Error with
1456 "Before cursor designates wrong container";
1459 pragma Assert (Vet (Before), "bad cursor in Splice");
1462 if Target'Address = Source'Address
1463 or else Source.Length = 0
1468 pragma Assert (Source.Nodes (Source.First).Prev = 0);
1469 pragma Assert (Source.Nodes (Source.Last).Next = 0);
1471 if Target.Length > Count_Type'Last - Source.Length then
1472 raise Constraint_Error with "new length exceeds maximum";
1475 if Target.Length + Source.Length > Target.Capacity then
1476 raise Capacity_Error with "new length exceeds target capacity";
1479 if Target.Busy > 0 then
1480 raise Program_Error with
1481 "attempt to tamper with cursors of Target (list is busy)";
1484 if Source.Busy > 0 then
1485 raise Program_Error with
1486 "attempt to tamper with cursors of Source (list is busy)";
1490 Insert (Target, Before, Source.Nodes (Source.Last).Element);
1491 Delete_Last (Source);
1492 exit when Is_Empty (Source);
1497 (Container : in out List;
1501 N : Node_Array renames Container.Nodes;
1504 if Before.Container /= null then
1505 if Before.Container /= Container'Unchecked_Access then
1506 raise Program_Error with
1507 "Before cursor designates wrong container";
1510 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1513 if Position.Node = 0 then
1514 raise Constraint_Error with "Position cursor has no element";
1517 if Position.Container /= Container'Unrestricted_Access then
1518 raise Program_Error with
1519 "Position cursor designates wrong container";
1522 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1524 if Position.Node = Before.Node
1525 or else N (Position.Node).Next = Before.Node
1530 pragma Assert (Container.Length >= 2);
1532 if Container.Busy > 0 then
1533 raise Program_Error with
1534 "attempt to tamper with cursors (list is busy)";
1537 if Before.Node = 0 then
1538 pragma Assert (Position.Node /= Container.Last);
1540 if Position.Node = Container.First then
1541 Container.First := N (Position.Node).Next;
1542 N (Container.First).Prev := 0;
1544 N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1545 N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1548 N (Container.Last).Next := Position.Node;
1549 N (Position.Node).Prev := Container.Last;
1551 Container.Last := Position.Node;
1552 N (Container.Last).Next := 0;
1557 if Before.Node = Container.First then
1558 pragma Assert (Position.Node /= Container.First);
1560 if Position.Node = Container.Last then
1561 Container.Last := N (Position.Node).Prev;
1562 N (Container.Last).Next := 0;
1564 N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1565 N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1568 N (Container.First).Prev := Position.Node;
1569 N (Position.Node).Next := Container.First;
1571 Container.First := Position.Node;
1572 N (Container.First).Prev := 0;
1577 if Position.Node = Container.First then
1578 Container.First := N (Position.Node).Next;
1579 N (Container.First).Prev := 0;
1581 elsif Position.Node = Container.Last then
1582 Container.Last := N (Position.Node).Prev;
1583 N (Container.Last).Next := 0;
1586 N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1587 N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1590 N (N (Before.Node).Prev).Next := Position.Node;
1591 N (Position.Node).Prev := N (Before.Node).Prev;
1593 N (Before.Node).Prev := Position.Node;
1594 N (Position.Node).Next := Before.Node;
1596 pragma Assert (N (Container.First).Prev = 0);
1597 pragma Assert (N (Container.Last).Next = 0);
1601 (Target : in out List;
1603 Source : in out List;
1604 Position : in out Cursor)
1606 Target_Position : Cursor;
1609 if Target'Address = Source'Address then
1610 Splice (Target, Before, Position);
1614 if Before.Container /= null then
1615 if Before.Container /= Target'Unrestricted_Access then
1616 raise Program_Error with
1617 "Before cursor designates wrong container";
1620 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1623 if Position.Node = 0 then
1624 raise Constraint_Error with "Position cursor has no element";
1627 if Position.Container /= Source'Unrestricted_Access then
1628 raise Program_Error with
1629 "Position cursor designates wrong container";
1632 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1634 if Target.Length >= Target.Capacity then
1635 raise Capacity_Error with "Target is full";
1638 if Target.Busy > 0 then
1639 raise Program_Error with
1640 "attempt to tamper with cursors of Target (list is busy)";
1643 if Source.Busy > 0 then
1644 raise Program_Error with
1645 "attempt to tamper with cursors of Source (list is busy)";
1649 (Container => Target,
1651 New_Item => Source.Nodes (Position.Node).Element,
1652 Position => Target_Position);
1654 Delete (Source, Position);
1655 Position := Target_Position;
1663 (Container : in out List;
1668 raise Constraint_Error with "I cursor has no element";
1672 raise Constraint_Error with "J cursor has no element";
1675 if I.Container /= Container'Unchecked_Access then
1676 raise Program_Error with "I cursor designates wrong container";
1679 if J.Container /= Container'Unchecked_Access then
1680 raise Program_Error with "J cursor designates wrong container";
1683 if I.Node = J.Node then
1687 if Container.Lock > 0 then
1688 raise Program_Error with
1689 "attempt to tamper with elements (list is locked)";
1692 pragma Assert (Vet (I), "bad I cursor in Swap");
1693 pragma Assert (Vet (J), "bad J cursor in Swap");
1696 EI : Element_Type renames Container.Nodes (I.Node).Element;
1697 EJ : Element_Type renames Container.Nodes (J.Node).Element;
1699 EI_Copy : constant Element_Type := EI;
1711 procedure Swap_Links
1712 (Container : in out List;
1717 raise Constraint_Error with "I cursor has no element";
1721 raise Constraint_Error with "J cursor has no element";
1724 if I.Container /= Container'Unrestricted_Access then
1725 raise Program_Error with "I cursor designates wrong container";
1728 if J.Container /= Container'Unrestricted_Access then
1729 raise Program_Error with "J cursor designates wrong container";
1732 if I.Node = J.Node then
1736 if Container.Busy > 0 then
1737 raise Program_Error with
1738 "attempt to tamper with cursors (list is busy)";
1741 pragma Assert (Vet (I), "bad I cursor in Swap_Links");
1742 pragma Assert (Vet (J), "bad J cursor in Swap_Links");
1745 I_Next : constant Cursor := Next (I);
1749 Splice (Container, Before => I, Position => J);
1753 J_Next : constant Cursor := Next (J);
1757 Splice (Container, Before => J, Position => I);
1760 pragma Assert (Container.Length >= 3);
1762 Splice (Container, Before => I_Next, Position => J);
1763 Splice (Container, Before => J_Next, Position => I);
1770 --------------------
1771 -- Update_Element --
1772 --------------------
1774 procedure Update_Element
1775 (Container : in out List;
1777 Process : not null access procedure (Element : in out Element_Type))
1780 if Position.Node = 0 then
1781 raise Constraint_Error with "Position cursor has no element";
1784 if Position.Container /= Container'Unchecked_Access then
1785 raise Program_Error with
1786 "Position cursor designates wrong container";
1789 pragma Assert (Vet (Position), "bad cursor in Update_Element");
1792 B : Natural renames Container.Busy;
1793 L : Natural renames Container.Lock;
1800 N : Node_Type renames Container.Nodes (Position.Node);
1802 Process (N.Element);
1819 function Vet (Position : Cursor) return Boolean is
1821 if Position.Node = 0 then
1822 return Position.Container = null;
1825 if Position.Container = null then
1830 L : List renames Position.Container.all;
1831 N : Node_Array renames L.Nodes;
1833 if L.Length = 0 then
1838 or L.First > L.Capacity
1844 or L.Last > L.Capacity
1849 if N (L.First).Prev /= 0 then
1853 if N (L.Last).Next /= 0 then
1857 if Position.Node > L.Capacity then
1861 if N (Position.Node).Prev < 0 then -- see Free
1865 if N (Position.Node).Prev > L.Capacity then
1869 if N (Position.Node).Next = Position.Node then
1873 if N (Position.Node).Prev = Position.Node then
1877 if N (Position.Node).Prev = 0
1878 and then Position.Node /= L.First
1883 -- If we get here, we know that this disjunction is true:
1884 -- N (Position.Node).Prev /= 0 or else Position.Node = L.First
1886 if N (Position.Node).Next = 0
1887 and then Position.Node /= L.Last
1892 -- If we get here, we know that this disjunction is true:
1893 -- N (Position.Node).Next /= 0 or else Position.Node = L.Last
1895 if L.Length = 1 then
1896 return L.First = L.Last;
1899 if L.First = L.Last then
1903 if N (L.First).Next = 0 then
1907 if N (L.Last).Prev = 0 then
1911 if N (N (L.First).Next).Prev /= L.First then
1915 if N (N (L.Last).Prev).Next /= L.Last then
1919 if L.Length = 2 then
1920 if N (L.First).Next /= L.Last then
1924 if N (L.Last).Prev /= L.First then
1931 if N (L.First).Next = L.Last then
1935 if N (L.Last).Prev = L.First then
1939 if Position.Node = L.First then -- eliminates earlier disjunct
1943 -- If we get here, we know, per disjunctive syllogism (modus
1944 -- tollendo ponens), that this predicate is true:
1945 -- N (Position.Node).Prev /= 0
1947 if Position.Node = L.Last then -- eliminates earlier disjunct
1951 -- If we get here, we know, per disjunctive syllogism (modus
1952 -- tollendo ponens), that this predicate is true:
1953 -- N (Position.Node).Next /= 0
1955 if N (N (Position.Node).Next).Prev /= Position.Node then
1959 if N (N (Position.Node).Prev).Next /= Position.Node then
1963 if L.Length = 3 then
1964 if N (L.First).Next /= Position.Node then
1968 if N (L.Last).Prev /= Position.Node then
1982 (Stream : not null access Root_Stream_Type'Class;
1988 Count_Type'Base'Write
(Stream
, Item
.Length
);
1991 while Node
/= 0 loop
1992 Element_Type
'Write (Stream
, Item
.Nodes
(Node
).Element
);
1993 Node
:= Item
.Nodes
(Node
).Next
;
1998 (Stream
: not null access Root_Stream_Type
'Class;
2002 raise Program_Error
with "attempt to stream list cursor";
2005 end Ada
.Containers
.Bounded_Doubly_Linked_Lists
;