1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS --
9 -- Copyright (C) 2010-2014, 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/>. --
26 ------------------------------------------------------------------------------
28 with System
; use type System
.Address
;
30 package body Ada
.Containers
.Formal_Doubly_Linked_Lists
with
33 pragma Annotate
(CodePeer
, Skip_Analysis
);
35 -----------------------
36 -- Local Subprograms --
37 -----------------------
40 (Container
: in out List
;
41 New_Item
: Element_Type
;
42 New_Node
: out Count_Type
);
45 (Container
: in out List
;
46 New_Node
: out Count_Type
);
49 (Container
: in out List
;
52 procedure Insert_Internal
53 (Container
: in out List
;
55 New_Node
: Count_Type
);
57 function Vet
(L
: List
; Position
: Cursor
) return Boolean;
63 function "=" (Left
, Right
: List
) return Boolean is
67 if Left
'Address = Right
'Address then
71 if Left
.Length
/= Right
.Length
then
78 if Left
.Nodes
(LI
).Element
/= Right
.Nodes
(LI
).Element
then
82 LI
:= Left
.Nodes
(LI
).Next
;
83 RI
:= Right
.Nodes
(RI
).Next
;
94 (Container
: in out List
;
95 New_Item
: Element_Type
;
96 New_Node
: out Count_Type
)
98 N
: Node_Array
renames Container
.Nodes
;
101 if Container
.Free
>= 0 then
102 New_Node
:= Container
.Free
;
103 N
(New_Node
).Element
:= New_Item
;
104 Container
.Free
:= N
(New_Node
).Next
;
107 New_Node
:= abs Container
.Free
;
108 N
(New_Node
).Element
:= New_Item
;
109 Container
.Free
:= Container
.Free
- 1;
114 (Container
: in out List
;
115 New_Node
: out Count_Type
)
117 N
: Node_Array
renames Container
.Nodes
;
120 if Container
.Free
>= 0 then
121 New_Node
:= Container
.Free
;
122 Container
.Free
:= N
(New_Node
).Next
;
125 New_Node
:= abs Container
.Free
;
126 Container
.Free
:= Container
.Free
- 1;
135 (Container
: in out List
;
136 New_Item
: Element_Type
;
137 Count
: Count_Type
:= 1)
140 Insert
(Container
, No_Element
, New_Item
, Count
);
147 procedure Assign
(Target
: in out List
; Source
: List
) is
148 N
: Node_Array
renames Source
.Nodes
;
152 if Target
'Address = Source
'Address then
156 if Target
.Capacity
< Source
.Length
then
157 raise Constraint_Error
with -- ???
158 "Source length exceeds Target capacity";
165 Append
(Target
, N
(J
).Element
);
174 procedure Clear
(Container
: in out List
) is
175 N
: Node_Array
renames Container
.Nodes
;
179 if Container
.Length
= 0 then
180 pragma Assert
(Container
.First
= 0);
181 pragma Assert
(Container
.Last
= 0);
185 pragma Assert
(Container
.First
>= 1);
186 pragma Assert
(Container
.Last
>= 1);
187 pragma Assert
(N
(Container
.First
).Prev
= 0);
188 pragma Assert
(N
(Container
.Last
).Next
= 0);
190 while Container
.Length
> 1 loop
191 X
:= Container
.First
;
193 Container
.First
:= N
(X
).Next
;
194 N
(Container
.First
).Prev
:= 0;
196 Container
.Length
:= Container
.Length
- 1;
201 X
:= Container
.First
;
203 Container
.First
:= 0;
205 Container
.Length
:= 0;
216 Item
: Element_Type
) return Boolean
219 return Find
(Container
, Item
) /= No_Element
;
228 Capacity
: Count_Type
:= 0) return List
230 C
: constant Count_Type
:= Count_Type
'Max (Source
.Capacity
, Capacity
);
235 if 0 < Capacity
and then Capacity
< Source
.Capacity
then
236 raise Capacity_Error
;
240 while N
<= Source
.Capacity
loop
241 P
.Nodes
(N
).Prev
:= Source
.Nodes
(N
).Prev
;
242 P
.Nodes
(N
).Next
:= Source
.Nodes
(N
).Next
;
243 P
.Nodes
(N
).Element
:= Source
.Nodes
(N
).Element
;
247 P
.Free
:= Source
.Free
;
248 P
.Length
:= Source
.Length
;
249 P
.First
:= Source
.First
;
250 P
.Last
:= Source
.Last
;
253 N
:= Source
.Capacity
+ 1;
263 ---------------------
264 -- Current_To_Last --
265 ---------------------
267 function Current_To_Last
269 Current
: Cursor
) return List
is
270 Curs
: Cursor
:= First
(Container
);
271 C
: List
(Container
.Capacity
) := Copy
(Container
, Container
.Capacity
);
275 if Curs
= No_Element
then
280 if Current
/= No_Element
and not Has_Element
(Container
, Current
) then
281 raise Constraint_Error
;
284 while Curs
.Node
/= Current
.Node
loop
287 Curs
:= Next
(Container
, (Node
=> Node
));
298 (Container
: in out List
;
299 Position
: in out Cursor
;
300 Count
: Count_Type
:= 1)
302 N
: Node_Array
renames Container
.Nodes
;
306 if not Has_Element
(Container
=> Container
,
307 Position
=> Position
)
309 raise Constraint_Error
with
310 "Position cursor has no element";
313 pragma Assert
(Vet
(Container
, Position
), "bad cursor in Delete");
314 pragma Assert
(Container
.First
>= 1);
315 pragma Assert
(Container
.Last
>= 1);
316 pragma Assert
(N
(Container
.First
).Prev
= 0);
317 pragma Assert
(N
(Container
.Last
).Next
= 0);
319 if Position
.Node
= Container
.First
then
320 Delete_First
(Container
, Count
);
321 Position
:= No_Element
;
326 Position
:= No_Element
;
330 for Index
in 1 .. Count
loop
331 pragma Assert
(Container
.Length
>= 2);
334 Container
.Length
:= Container
.Length
- 1;
336 if X
= Container
.Last
then
337 Position
:= No_Element
;
339 Container
.Last
:= N
(X
).Prev
;
340 N
(Container
.Last
).Next
:= 0;
346 Position
.Node
:= N
(X
).Next
;
347 pragma Assert
(N
(Position
.Node
).Prev
>= 0);
349 N
(N
(X
).Next
).Prev
:= N
(X
).Prev
;
350 N
(N
(X
).Prev
).Next
:= N
(X
).Next
;
354 Position
:= No_Element
;
361 procedure Delete_First
362 (Container
: in out List
;
363 Count
: Count_Type
:= 1)
365 N
: Node_Array
renames Container
.Nodes
;
369 if Count
>= Container
.Length
then
378 for J
in 1 .. Count
loop
379 X
:= Container
.First
;
380 pragma Assert
(N
(N
(X
).Next
).Prev
= Container
.First
);
382 Container
.First
:= N
(X
).Next
;
383 N
(Container
.First
).Prev
:= 0;
385 Container
.Length
:= Container
.Length
- 1;
395 procedure Delete_Last
396 (Container
: in out List
;
397 Count
: Count_Type
:= 1)
399 N
: Node_Array
renames Container
.Nodes
;
403 if Count
>= Container
.Length
then
412 for J
in 1 .. Count
loop
414 pragma Assert
(N
(N
(X
).Prev
).Next
= Container
.Last
);
416 Container
.Last
:= N
(X
).Prev
;
417 N
(Container
.Last
).Next
:= 0;
419 Container
.Length
:= Container
.Length
- 1;
431 Position
: Cursor
) return Element_Type
434 if not Has_Element
(Container
=> Container
, Position
=> Position
) then
435 raise Constraint_Error
with
436 "Position cursor has no element";
439 return Container
.Nodes
(Position
.Node
).Element
;
449 Position
: Cursor
:= No_Element
) return Cursor
451 From
: Count_Type
:= Position
.Node
;
454 if From
= 0 and Container
.Length
= 0 then
459 From
:= Container
.First
;
462 if Position
.Node
/= 0 and then
463 not Has_Element
(Container
, Position
)
465 raise Constraint_Error
with
466 "Position cursor has no element";
470 if Container
.Nodes
(From
).Element
= Item
then
471 return (Node
=> From
);
474 From
:= Container
.Nodes
(From
).Next
;
484 function First
(Container
: List
) return Cursor
is
486 if Container
.First
= 0 then
490 return (Node
=> Container
.First
);
497 function First_Element
(Container
: List
) return Element_Type
is
498 F
: constant Count_Type
:= Container
.First
;
501 raise Constraint_Error
with "list is empty";
503 return Container
.Nodes
(F
).Element
;
507 -----------------------
508 -- First_To_Previous --
509 -----------------------
511 function First_To_Previous
513 Current
: Cursor
) return List
515 Curs
: Cursor
:= Current
;
516 C
: List
(Container
.Capacity
) := Copy
(Container
, Container
.Capacity
);
520 if Curs
= No_Element
then
523 elsif not Has_Element
(Container
, Curs
) then
524 raise Constraint_Error
;
527 while Curs
.Node
/= 0 loop
530 Curs
:= Next
(Container
, (Node
=> Node
));
535 end First_To_Previous
;
542 (Container
: in out List
;
545 pragma Assert
(X
> 0);
546 pragma Assert
(X
<= Container
.Capacity
);
548 N
: Node_Array
renames Container
.Nodes
;
551 N
(X
).Prev
:= -1; -- Node is deallocated (not on active list)
553 if Container
.Free
>= 0 then
554 N
(X
).Next
:= Container
.Free
;
557 elsif X
+ 1 = abs Container
.Free
then
558 N
(X
).Next
:= 0; -- Not strictly necessary, but marginally safer
559 Container
.Free
:= Container
.Free
+ 1;
562 Container
.Free
:= abs Container
.Free
;
564 if Container
.Free
> Container
.Capacity
then
568 for J
in Container
.Free
.. Container
.Capacity
- 1 loop
572 N
(Container
.Capacity
).Next
:= 0;
575 N
(X
).Next
:= Container
.Free
;
580 ---------------------
581 -- Generic_Sorting --
582 ---------------------
584 package body Generic_Sorting
is
590 function Is_Sorted
(Container
: List
) return Boolean is
591 Nodes
: Node_Array
renames Container
.Nodes
;
592 Node
: Count_Type
:= Container
.First
;
595 for J
in 2 .. Container
.Length
loop
596 if Nodes
(Nodes
(Node
).Next
).Element
< Nodes
(Node
).Element
then
599 Node
:= Nodes
(Node
).Next
;
611 (Target
: in out List
;
612 Source
: in out List
)
614 LN
: Node_Array
renames Target
.Nodes
;
615 RN
: Node_Array
renames Source
.Nodes
;
620 if Target
'Address = Source
'Address then
624 LI
:= First
(Target
);
625 RI
:= First
(Source
);
626 while RI
.Node
/= 0 loop
627 pragma Assert
(RN
(RI
.Node
).Next
= 0
628 or else not (RN
(RN
(RI
.Node
).Next
).Element
<
629 RN
(RI
.Node
).Element
));
632 Splice
(Target
, No_Element
, Source
);
636 pragma Assert
(LN
(LI
.Node
).Next
= 0
637 or else not (LN
(LN
(LI
.Node
).Next
).Element
<
638 LN
(LI
.Node
).Element
));
640 if RN
(RI
.Node
).Element
< LN
(LI
.Node
).Element
then
643 pragma Warnings
(Off
, RJ
);
645 RI
.Node
:= RN
(RI
.Node
).Next
;
646 Splice
(Target
, LI
, Source
, RJ
);
650 LI
.Node
:= LN
(LI
.Node
).Next
;
659 procedure Sort
(Container
: in out List
) is
660 N
: Node_Array
renames Container
.Nodes
;
662 procedure Partition
(Pivot
, Back
: Count_Type
);
663 procedure Sort
(Front
, Back
: Count_Type
);
669 procedure Partition
(Pivot
, Back
: Count_Type
) is
673 Node
:= N
(Pivot
).Next
;
674 while Node
/= Back
loop
675 if N
(Node
).Element
< N
(Pivot
).Element
then
677 Prev
: constant Count_Type
:= N
(Node
).Prev
;
678 Next
: constant Count_Type
:= N
(Node
).Next
;
681 N
(Prev
).Next
:= Next
;
684 Container
.Last
:= Prev
;
686 N
(Next
).Prev
:= Prev
;
689 N
(Node
).Next
:= Pivot
;
690 N
(Node
).Prev
:= N
(Pivot
).Prev
;
692 N
(Pivot
).Prev
:= Node
;
694 if N
(Node
).Prev
= 0 then
695 Container
.First
:= Node
;
697 N
(N
(Node
).Prev
).Next
:= Node
;
704 Node
:= N
(Node
).Next
;
713 procedure Sort
(Front
, Back
: Count_Type
) is
718 Pivot
:= Container
.First
;
720 Pivot
:= N
(Front
).Next
;
723 if Pivot
/= Back
then
724 Partition
(Pivot
, Back
);
730 -- Start of processing for Sort
733 if Container
.Length
<= 1 then
737 pragma Assert
(N
(Container
.First
).Prev
= 0);
738 pragma Assert
(N
(Container
.Last
).Next
= 0);
740 Sort
(Front
=> 0, Back
=> 0);
742 pragma Assert
(N
(Container
.First
).Prev
= 0);
743 pragma Assert
(N
(Container
.Last
).Next
= 0);
752 function Has_Element
(Container
: List
; Position
: Cursor
) return Boolean is
754 if Position
.Node
= 0 then
758 return Container
.Nodes
(Position
.Node
).Prev
/= -1;
766 (Container
: in out List
;
768 New_Item
: Element_Type
;
769 Position
: out Cursor
;
770 Count
: Count_Type
:= 1)
775 if Before
.Node
/= 0 then
776 pragma Assert
(Vet
(Container
, Before
), "bad cursor in Insert");
784 if Container
.Length
> Container
.Capacity
- Count
then
785 raise Constraint_Error
with "new length exceeds capacity";
788 Allocate
(Container
, New_Item
, New_Node
=> J
);
789 Insert_Internal
(Container
, Before
.Node
, New_Node
=> J
);
790 Position
:= (Node
=> J
);
792 for Index
in 2 .. Count
loop
793 Allocate
(Container
, New_Item
, New_Node
=> J
);
794 Insert_Internal
(Container
, Before
.Node
, New_Node
=> J
);
799 (Container
: in out List
;
801 New_Item
: Element_Type
;
802 Count
: Count_Type
:= 1)
806 Insert
(Container
, Before
, New_Item
, Position
, Count
);
810 (Container
: in out List
;
812 Position
: out Cursor
;
813 Count
: Count_Type
:= 1)
818 if Before
.Node
/= 0 then
819 pragma Assert
(Vet
(Container
, Before
), "bad cursor in Insert");
827 if Container
.Length
> Container
.Capacity
- Count
then
828 raise Constraint_Error
with "new length exceeds capacity";
831 Allocate
(Container
, New_Node
=> J
);
832 Insert_Internal
(Container
, Before
.Node
, New_Node
=> J
);
833 Position
:= (Node
=> J
);
835 for Index
in 2 .. Count
loop
836 Allocate
(Container
, New_Node
=> J
);
837 Insert_Internal
(Container
, Before
.Node
, New_Node
=> J
);
841 ---------------------
842 -- Insert_Internal --
843 ---------------------
845 procedure Insert_Internal
846 (Container
: in out List
;
848 New_Node
: Count_Type
)
850 N
: Node_Array
renames Container
.Nodes
;
853 if Container
.Length
= 0 then
854 pragma Assert
(Before
= 0);
855 pragma Assert
(Container
.First
= 0);
856 pragma Assert
(Container
.Last
= 0);
858 Container
.First
:= New_Node
;
859 Container
.Last
:= New_Node
;
861 N
(Container
.First
).Prev
:= 0;
862 N
(Container
.Last
).Next
:= 0;
864 elsif Before
= 0 then
865 pragma Assert
(N
(Container
.Last
).Next
= 0);
867 N
(Container
.Last
).Next
:= New_Node
;
868 N
(New_Node
).Prev
:= Container
.Last
;
870 Container
.Last
:= New_Node
;
871 N
(Container
.Last
).Next
:= 0;
873 elsif Before
= Container
.First
then
874 pragma Assert
(N
(Container
.First
).Prev
= 0);
876 N
(Container
.First
).Prev
:= New_Node
;
877 N
(New_Node
).Next
:= Container
.First
;
879 Container
.First
:= New_Node
;
880 N
(Container
.First
).Prev
:= 0;
883 pragma Assert
(N
(Container
.First
).Prev
= 0);
884 pragma Assert
(N
(Container
.Last
).Next
= 0);
886 N
(New_Node
).Next
:= Before
;
887 N
(New_Node
).Prev
:= N
(Before
).Prev
;
889 N
(N
(Before
).Prev
).Next
:= New_Node
;
890 N
(Before
).Prev
:= New_Node
;
893 Container
.Length
:= Container
.Length
+ 1;
900 function Is_Empty
(Container
: List
) return Boolean is
902 return Length
(Container
) = 0;
909 function Last
(Container
: List
) return Cursor
is
911 if Container
.Last
= 0 then
915 return (Node
=> Container
.Last
);
922 function Last_Element
(Container
: List
) return Element_Type
is
923 L
: constant Count_Type
:= Container
.Last
;
926 raise Constraint_Error
with "list is empty";
928 return Container
.Nodes
(L
).Element
;
936 function Length
(Container
: List
) return Count_Type
is
938 return Container
.Length
;
946 (Target
: in out List
;
947 Source
: in out List
)
949 N
: Node_Array
renames Source
.Nodes
;
953 if Target
'Address = Source
'Address then
957 if Target
.Capacity
< Source
.Length
then
958 raise Constraint_Error
with -- ???
959 "Source length exceeds Target capacity";
964 while Source
.Length
> 1 loop
965 pragma Assert
(Source
.First
in 1 .. Source
.Capacity
);
966 pragma Assert
(Source
.Last
/= Source
.First
);
967 pragma Assert
(N
(Source
.First
).Prev
= 0);
968 pragma Assert
(N
(Source
.Last
).Next
= 0);
970 -- Copy first element from Source to Target
973 Append
(Target
, N
(X
).Element
); -- optimize away???
975 -- Unlink first node of Source
977 Source
.First
:= N
(X
).Next
;
978 N
(Source
.First
).Prev
:= 0;
980 Source
.Length
:= Source
.Length
- 1;
982 -- The representation invariants for Source have been restored. It is
983 -- now safe to free the unlinked node, without fear of corrupting the
984 -- active links of Source.
986 -- Note that the algorithm we use here models similar algorithms used
987 -- in the unbounded form of the doubly-linked list container. In that
988 -- case, Free is an instantation of Unchecked_Deallocation, which can
989 -- fail (because PE will be raised if controlled Finalize fails), so
990 -- we must defer the call until the last step. Here in the bounded
991 -- form, Free merely links the node we have just "deallocated" onto a
992 -- list of inactive nodes, so technically Free cannot fail. However,
993 -- for consistency, we handle Free the same way here as we do for the
994 -- unbounded form, with the pessimistic assumption that it can fail.
999 if Source
.Length
= 1 then
1000 pragma Assert
(Source
.First
in 1 .. Source
.Capacity
);
1001 pragma Assert
(Source
.Last
= Source
.First
);
1002 pragma Assert
(N
(Source
.First
).Prev
= 0);
1003 pragma Assert
(N
(Source
.Last
).Next
= 0);
1005 -- Copy element from Source to Target
1008 Append
(Target
, N
(X
).Element
);
1010 -- Unlink node of Source
1016 -- Return the unlinked node to the free store
1026 procedure Next
(Container
: List
; Position
: in out Cursor
) is
1028 Position
:= Next
(Container
, Position
);
1031 function Next
(Container
: List
; Position
: Cursor
) return Cursor
is
1033 if Position
.Node
= 0 then
1037 if not Has_Element
(Container
, Position
) then
1038 raise Program_Error
with "Position cursor has no element";
1041 return (Node
=> Container
.Nodes
(Position
.Node
).Next
);
1049 (Container
: in out List
;
1050 New_Item
: Element_Type
;
1051 Count
: Count_Type
:= 1)
1054 Insert
(Container
, First
(Container
), New_Item
, Count
);
1061 procedure Previous
(Container
: List
; Position
: in out Cursor
) is
1063 Position
:= Previous
(Container
, Position
);
1066 function Previous
(Container
: List
; Position
: Cursor
) return Cursor
is
1068 if Position
.Node
= 0 then
1072 if not Has_Element
(Container
, Position
) then
1073 raise Program_Error
with "Position cursor has no element";
1076 return (Node
=> Container
.Nodes
(Position
.Node
).Prev
);
1079 ---------------------
1080 -- Replace_Element --
1081 ---------------------
1083 procedure Replace_Element
1084 (Container
: in out List
;
1086 New_Item
: Element_Type
)
1089 if not Has_Element
(Container
, Position
) then
1090 raise Constraint_Error
with "Position cursor has no element";
1094 (Vet
(Container
, Position
), "bad cursor in Replace_Element");
1096 Container
.Nodes
(Position
.Node
).Element
:= New_Item
;
1097 end Replace_Element
;
1099 ----------------------
1100 -- Reverse_Elements --
1101 ----------------------
1103 procedure Reverse_Elements
(Container
: in out List
) is
1104 N
: Node_Array
renames Container
.Nodes
;
1105 I
: Count_Type
:= Container
.First
;
1106 J
: Count_Type
:= Container
.Last
;
1108 procedure Swap
(L
, R
: Count_Type
);
1114 procedure Swap
(L
, R
: Count_Type
) is
1115 LN
: constant Count_Type
:= N
(L
).Next
;
1116 LP
: constant Count_Type
:= N
(L
).Prev
;
1118 RN
: constant Count_Type
:= N
(R
).Next
;
1119 RP
: constant Count_Type
:= N
(R
).Prev
;
1134 pragma Assert
(RP
= L
);
1148 -- Start of processing for Reverse_Elements
1151 if Container
.Length
<= 1 then
1155 pragma Assert
(N
(Container
.First
).Prev
= 0);
1156 pragma Assert
(N
(Container
.Last
).Next
= 0);
1158 Container
.First
:= J
;
1159 Container
.Last
:= I
;
1161 Swap
(L
=> I
, R
=> J
);
1169 Swap
(L
=> J
, R
=> I
);
1178 pragma Assert
(N
(Container
.First
).Prev
= 0);
1179 pragma Assert
(N
(Container
.Last
).Next
= 0);
1180 end Reverse_Elements
;
1186 function Reverse_Find
1188 Item
: Element_Type
;
1189 Position
: Cursor
:= No_Element
) return Cursor
1191 CFirst
: Count_Type
:= Position
.Node
;
1195 CFirst
:= Container
.First
;
1198 if Container
.Length
= 0 then
1202 while CFirst
/= 0 loop
1203 if Container
.Nodes
(CFirst
).Element
= Item
then
1204 return (Node
=> CFirst
);
1206 CFirst
:= Container
.Nodes
(CFirst
).Prev
;
1219 (Target
: in out List
;
1221 Source
: in out List
)
1223 SN
: Node_Array
renames Source
.Nodes
;
1226 if Before
.Node
/= 0 then
1227 pragma Assert
(Vet
(Target
, Before
), "bad cursor in Splice");
1230 if Target
'Address = Source
'Address
1231 or else Source
.Length
= 0
1236 pragma Assert
(SN
(Source
.First
).Prev
= 0);
1237 pragma Assert
(SN
(Source
.Last
).Next
= 0);
1239 if Target
.Length
> Count_Type
'Base'Last - Source.Length then
1240 raise Constraint_Error with "new length exceeds maximum";
1243 if Target.Length + Source.Length > Target.Capacity then
1244 raise Constraint_Error;
1248 Insert (Target, Before, SN (Source.Last).Element);
1249 Delete_Last (Source);
1250 exit when Is_Empty (Source);
1255 (Target : in out List;
1257 Source : in out List;
1258 Position : in out Cursor)
1260 Target_Position : Cursor;
1263 if Target'Address = Source'Address then
1264 Splice (Target, Before, Position);
1268 if Position.Node = 0 then
1269 raise Constraint_Error with "Position cursor has no element";
1272 pragma Assert (Vet (Source, Position), "bad Position cursor in Splice");
1274 if Target.Length >= Target.Capacity then
1275 raise Constraint_Error;
1279 (Container => Target,
1281 New_Item => Source.Nodes (Position.Node).Element,
1282 Position => Target_Position);
1284 Delete (Source, Position);
1285 Position := Target_Position;
1289 (Container : in out List;
1293 N : Node_Array renames Container.Nodes;
1296 if Before.Node /= 0 then
1298 (Vet (Container, Before), "bad Before cursor in Splice");
1301 if Position.Node = 0 then
1302 raise Constraint_Error with "Position cursor has no element";
1306 (Vet (Container, Position), "bad Position cursor in Splice");
1308 if Position.Node = Before.Node
1309 or else N (Position.Node).Next = Before.Node
1314 pragma Assert (Container.Length >= 2);
1316 if Before.Node = 0 then
1317 pragma Assert (Position.Node /= Container.Last);
1319 if Position.Node = Container.First then
1320 Container.First := N (Position.Node).Next;
1321 N (Container.First).Prev := 0;
1324 N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1325 N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1328 N (Container.Last).Next := Position.Node;
1329 N (Position.Node).Prev := Container.Last;
1331 Container.Last := Position.Node;
1332 N (Container.Last).Next := 0;
1337 if Before.Node = Container.First then
1338 pragma Assert (Position.Node /= Container.First);
1340 if Position.Node = Container.Last then
1341 Container.Last := N (Position.Node).Prev;
1342 N (Container.Last).Next := 0;
1345 N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1346 N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1349 N (Container.First).Prev := Position.Node;
1350 N (Position.Node).Next := Container.First;
1352 Container.First := Position.Node;
1353 N (Container.First).Prev := 0;
1358 if Position.Node = Container.First then
1359 Container.First := N (Position.Node).Next;
1360 N (Container.First).Prev := 0;
1362 elsif Position.Node = Container.Last then
1363 Container.Last := N (Position.Node).Prev;
1364 N (Container.Last).Next := 0;
1367 N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1368 N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1371 N (N (Before.Node).Prev).Next := Position.Node;
1372 N (Position.Node).Prev := N (Before.Node).Prev;
1374 N (Before.Node).Prev := Position.Node;
1375 N (Position.Node).Next := Before.Node;
1377 pragma Assert (N (Container.First).Prev = 0);
1378 pragma Assert (N (Container.Last).Next = 0);
1385 function Strict_Equal (Left, Right : List) return Boolean is
1386 CL : Count_Type := Left.First;
1387 CR : Count_Type := Right.First;
1390 while CL /= 0 or CR /= 0 loop
1392 Left.Nodes (CL).Element /= Right.Nodes (CL).Element
1397 CL := Left.Nodes (CL).Next;
1398 CR := Right.Nodes (CR).Next;
1409 (Container : in out List;
1414 raise Constraint_Error with "I cursor has no element";
1418 raise Constraint_Error with "J cursor has no element";
1421 if I.Node = J.Node then
1425 pragma Assert (Vet (Container, I), "bad I cursor in Swap");
1426 pragma Assert (Vet (Container, J), "bad J cursor in Swap");
1429 NN : Node_Array renames Container.Nodes;
1430 NI : Node_Type renames NN (I.Node);
1431 NJ : Node_Type renames NN (J.Node);
1433 EI_Copy : constant Element_Type := NI.Element;
1436 NI.Element := NJ.Element;
1437 NJ.Element := EI_Copy;
1445 procedure Swap_Links
1446 (Container : in out List;
1449 I_Next, J_Next : Cursor;
1453 raise Constraint_Error with "I cursor has no element";
1457 raise Constraint_Error with "J cursor has no element";
1460 if I.Node = J.Node then
1464 pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links");
1465 pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links");
1467 I_Next := Next (Container, I);
1470 Splice (Container, Before => I, Position => J);
1473 J_Next := Next (Container, J);
1476 Splice (Container, Before => J, Position => I);
1479 pragma Assert (Container.Length >= 3);
1480 Splice (Container, Before => I_Next, Position => J);
1481 Splice (Container, Before => J_Next, Position => I);
1490 function Vet (L : List; Position : Cursor) return Boolean is
1491 N : Node_Array renames L.Nodes;
1494 if L.Length = 0 then
1506 if Position.Node > L.Capacity then
1510 if N (Position.Node).Prev < 0
1511 or else N (Position.Node).Prev > L.Capacity
1516 if N (Position.Node).Next > L.Capacity then
1520 if N (L.First).Prev /= 0 then
1524 if N (L.Last).Next /= 0 then
1528 if N (Position.Node).Prev = 0
1529 and then Position.Node /= L.First
1534 if N (Position.Node).Next = 0
1535 and then Position.Node /= L.Last
1540 if L.Length = 1 then
1541 return L.First = L.Last;
1544 if L.First = L.Last then
1548 if N (L.First).Next = 0 then
1552 if N (L.Last).Prev = 0 then
1556 if N (N (L.First).Next).Prev /= L.First then
1560 if N (N (L.Last).Prev).Next /= L.Last then
1564 if L.Length = 2 then
1565 if N (L.First).Next /= L.Last then
1569 if N (L.Last).Prev /= L.First then
1576 if N (L.First).Next = L.Last then
1580 if N (L.Last).Prev = L.First then
1584 if Position.Node = L.First then
1588 if Position.Node = L.Last then
1592 if N (Position.Node).Next = 0 then
1596 if N (Position.Node).Prev = 0 then
1600 if N (N (Position.Node).Next).Prev /= Position.Node then
1604 if N (N (Position.Node).Prev).Next /= Position.Node then
1608 if L.Length = 3 then
1609 if N (L.First).Next /= Position.Node then
1613 if N (L.Last).Prev /= Position.Node then
1621 end Ada.Containers.Formal_Doubly_Linked_Lists;