1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS --
9 -- Copyright (C) 2010-2011, 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
;
29 with Ada
.Finalization
;
31 package body Ada
.Containers
.Formal_Doubly_Linked_Lists
is
33 type Iterator
is new Ada
.Finalization
.Limited_Controlled
and
34 List_Iterator_Interfaces
.Reversible_Iterator
with
36 Container
: List_Access
;
40 overriding
procedure Finalize
(Object
: in out Iterator
);
42 overriding
function First
(Object
: Iterator
) return Cursor
;
43 overriding
function Last
(Object
: Iterator
) return Cursor
;
45 overriding
function Next
47 Position
: Cursor
) return Cursor
;
49 overriding
function Previous
51 Position
: Cursor
) return Cursor
;
53 -----------------------
54 -- Local Subprograms --
55 -----------------------
58 (Container
: in out List
;
59 New_Item
: Element_Type
;
60 New_Node
: out Count_Type
);
63 (Container
: in out List
;
64 New_Node
: out Count_Type
);
67 (Container
: in out List
;
70 procedure Insert_Internal
71 (Container
: in out List
;
73 New_Node
: Count_Type
);
75 function Vet
(L
: List
; Position
: Cursor
) return Boolean;
81 function "=" (Left
, Right
: List
) return Boolean is
85 if Left
'Address = Right
'Address then
89 if Left
.Length
/= Right
.Length
then
96 if Left
.Nodes
(LI
).Element
/= Right
.Nodes
(LI
).Element
then
100 LI
:= Left
.Nodes
(LI
).Next
;
101 RI
:= Right
.Nodes
(RI
).Next
;
112 (Container
: in out List
;
113 New_Item
: Element_Type
;
114 New_Node
: out Count_Type
)
116 N
: Node_Array
renames Container
.Nodes
;
119 if Container
.Free
>= 0 then
120 New_Node
:= Container
.Free
;
121 N
(New_Node
).Element
:= New_Item
;
122 Container
.Free
:= N
(New_Node
).Next
;
125 New_Node
:= abs Container
.Free
;
126 N
(New_Node
).Element
:= New_Item
;
127 Container
.Free
:= Container
.Free
- 1;
132 (Container
: in out List
;
133 New_Node
: out Count_Type
)
135 N
: Node_Array
renames Container
.Nodes
;
138 if Container
.Free
>= 0 then
139 New_Node
:= Container
.Free
;
140 Container
.Free
:= N
(New_Node
).Next
;
143 New_Node
:= abs Container
.Free
;
144 Container
.Free
:= Container
.Free
- 1;
153 (Container
: in out List
;
154 New_Item
: Element_Type
;
155 Count
: Count_Type
:= 1)
158 Insert
(Container
, No_Element
, New_Item
, Count
);
165 procedure Assign
(Target
: in out List
; Source
: List
) is
166 N
: Node_Array
renames Source
.Nodes
;
170 if Target
'Address = Source
'Address then
174 if Target
.Capacity
< Source
.Length
then
175 raise Constraint_Error
with -- ???
176 "Source length exceeds Target capacity";
183 Append
(Target
, N
(J
).Element
);
192 procedure Clear
(Container
: in out List
) is
193 N
: Node_Array
renames Container
.Nodes
;
197 if Container
.Length
= 0 then
198 pragma Assert
(Container
.First
= 0);
199 pragma Assert
(Container
.Last
= 0);
200 pragma Assert
(Container
.Busy
= 0);
201 pragma Assert
(Container
.Lock
= 0);
205 pragma Assert
(Container
.First
>= 1);
206 pragma Assert
(Container
.Last
>= 1);
207 pragma Assert
(N
(Container
.First
).Prev
= 0);
208 pragma Assert
(N
(Container
.Last
).Next
= 0);
210 if Container
.Busy
> 0 then
211 raise Program_Error
with
212 "attempt to tamper with elements (list is busy)";
215 while Container
.Length
> 1 loop
216 X
:= Container
.First
;
218 Container
.First
:= N
(X
).Next
;
219 N
(Container
.First
).Prev
:= 0;
221 Container
.Length
:= Container
.Length
- 1;
226 X
:= Container
.First
;
228 Container
.First
:= 0;
230 Container
.Length
:= 0;
241 Item
: Element_Type
) return Boolean
244 return Find
(Container
, Item
) /= No_Element
;
253 Capacity
: Count_Type
:= 0) return List
255 C
: constant Count_Type
:= Count_Type
'Max (Source
.Capacity
, Capacity
);
261 while N
<= Source
.Capacity
loop
262 P
.Nodes
(N
).Prev
:= Source
.Nodes
(N
).Prev
;
263 P
.Nodes
(N
).Next
:= Source
.Nodes
(N
).Next
;
264 P
.Nodes
(N
).Element
:= Source
.Nodes
(N
).Element
;
268 P
.Free
:= Source
.Free
;
269 P
.Length
:= Source
.Length
;
270 P
.First
:= Source
.First
;
271 P
.Last
:= Source
.Last
;
274 N
:= Source
.Capacity
+ 1;
289 (Container
: in out List
;
290 Position
: in out Cursor
;
291 Count
: Count_Type
:= 1)
293 N
: Node_Array
renames Container
.Nodes
;
297 if not Has_Element
(Container
=> Container
,
298 Position
=> Position
)
300 raise Constraint_Error
with
301 "Position cursor has no element";
304 pragma Assert
(Vet
(Container
, Position
), "bad cursor in Delete");
305 pragma Assert
(Container
.First
>= 1);
306 pragma Assert
(Container
.Last
>= 1);
307 pragma Assert
(N
(Container
.First
).Prev
= 0);
308 pragma Assert
(N
(Container
.Last
).Next
= 0);
310 if Position
.Node
= Container
.First
then
311 Delete_First
(Container
, Count
);
312 Position
:= No_Element
;
317 Position
:= No_Element
;
321 if Container
.Busy
> 0 then
322 raise Program_Error
with
323 "attempt to tamper with elements (list is busy)";
326 for Index
in 1 .. Count
loop
327 pragma Assert
(Container
.Length
>= 2);
330 Container
.Length
:= Container
.Length
- 1;
332 if X
= Container
.Last
then
333 Position
:= No_Element
;
335 Container
.Last
:= N
(X
).Prev
;
336 N
(Container
.Last
).Next
:= 0;
342 Position
.Node
:= N
(X
).Next
;
343 pragma Assert
(N
(Position
.Node
).Prev
>= 0);
345 N
(N
(X
).Next
).Prev
:= N
(X
).Prev
;
346 N
(N
(X
).Prev
).Next
:= N
(X
).Next
;
350 Position
:= No_Element
;
357 procedure Delete_First
358 (Container
: in out List
;
359 Count
: Count_Type
:= 1)
361 N
: Node_Array
renames Container
.Nodes
;
365 if Count
>= Container
.Length
then
374 if Container
.Busy
> 0 then
375 raise Program_Error
with
376 "attempt to tamper with elements (list is busy)";
379 for J
in 1 .. Count
loop
380 X
:= Container
.First
;
381 pragma Assert
(N
(N
(X
).Next
).Prev
= Container
.First
);
383 Container
.First
:= N
(X
).Next
;
384 N
(Container
.First
).Prev
:= 0;
386 Container
.Length
:= Container
.Length
- 1;
396 procedure Delete_Last
397 (Container
: in out List
;
398 Count
: Count_Type
:= 1)
400 N
: Node_Array
renames Container
.Nodes
;
404 if Count
>= Container
.Length
then
413 if Container
.Busy
> 0 then
414 raise Program_Error
with
415 "attempt to tamper with elements (list is busy)";
418 for J
in 1 .. Count
loop
420 pragma Assert
(N
(N
(X
).Prev
).Next
= Container
.Last
);
422 Container
.Last
:= N
(X
).Prev
;
423 N
(Container
.Last
).Next
:= 0;
425 Container
.Length
:= Container
.Length
- 1;
437 Position
: Cursor
) return Element_Type
440 if not Has_Element
(Container
=> Container
, Position
=> Position
) then
441 raise Constraint_Error
with
442 "Position cursor has no element";
445 return Container
.Nodes
(Position
.Node
).Element
;
452 procedure Finalize
(Object
: in out Iterator
) is
454 if Object
.Container
/= null then
456 B
: Natural renames Object
.Container
.all.Busy
;
470 Position
: Cursor
:= No_Element
) return Cursor
472 From
: Count_Type
:= Position
.Node
;
475 if From
= 0 and Container
.Length
= 0 then
480 From
:= Container
.First
;
483 if Position
.Node
/= 0 and then
484 not Has_Element
(Container
, Position
)
486 raise Constraint_Error
with
487 "Position cursor has no element";
491 if Container
.Nodes
(From
).Element
= Item
then
492 return (Node
=> From
);
495 From
:= Container
.Nodes
(From
).Next
;
505 function First
(Container
: List
) return Cursor
is
507 if Container
.First
= 0 then
511 return (Node
=> Container
.First
);
514 function First
(Object
: Iterator
) return Cursor
is
516 -- The value of the iterator object's Node component influences the
517 -- behavior of the First (and Last) selector function.
519 -- When the Node component is null, this means the iterator object was
520 -- constructed without a start expression, in which case the (forward)
521 -- iteration starts from the (logical) beginning of the entire sequence
522 -- of items (corresponding to Container.First, for a forward iterator).
524 -- Otherwise, this is iteration over a partial sequence of items. When
525 -- the Node component is non-null, the iterator object was constructed
526 -- with a start expression, that specifies the position from which the
527 -- (forward) partial iteration begins.
529 if Object
.Node
= 0 then
530 return First
(Object
.Container
.all);
532 return (Node
=> Object
.Node
);
540 function First_Element
(Container
: List
) return Element_Type
is
541 F
: constant Count_Type
:= Container
.First
;
544 raise Constraint_Error
with "list is empty";
546 return Container
.Nodes
(F
).Element
;
555 (Container
: in out List
;
558 pragma Assert
(X
> 0);
559 pragma Assert
(X
<= Container
.Capacity
);
561 N
: Node_Array
renames Container
.Nodes
;
564 N
(X
).Prev
:= -1; -- Node is deallocated (not on active list)
566 if Container
.Free
>= 0 then
567 N
(X
).Next
:= Container
.Free
;
570 elsif X
+ 1 = abs Container
.Free
then
571 N
(X
).Next
:= 0; -- Not strictly necessary, but marginally safer
572 Container
.Free
:= Container
.Free
+ 1;
575 Container
.Free
:= abs Container
.Free
;
577 if Container
.Free
> Container
.Capacity
then
581 for J
in Container
.Free
.. Container
.Capacity
- 1 loop
585 N
(Container
.Capacity
).Next
:= 0;
588 N
(X
).Next
:= Container
.Free
;
593 ---------------------
594 -- Generic_Sorting --
595 ---------------------
597 package body Generic_Sorting
is
603 function Is_Sorted
(Container
: List
) return Boolean is
604 Nodes
: Node_Array
renames Container
.Nodes
;
605 Node
: Count_Type
:= Container
.First
;
608 for J
in 2 .. Container
.Length
loop
609 if Nodes
(Nodes
(Node
).Next
).Element
< Nodes
(Node
).Element
then
612 Node
:= Nodes
(Node
).Next
;
624 (Target
: in out List
;
625 Source
: in out List
)
627 LN
: Node_Array
renames Target
.Nodes
;
628 RN
: Node_Array
renames Source
.Nodes
;
633 if Target
'Address = Source
'Address then
637 if Target
.Busy
> 0 then
638 raise Program_Error
with
639 "attempt to tamper with cursors of Target (list is busy)";
642 if Source
.Busy
> 0 then
643 raise Program_Error
with
644 "attempt to tamper with cursors of Source (list is busy)";
647 LI
:= First
(Target
);
648 RI
:= First
(Source
);
649 while RI
.Node
/= 0 loop
650 pragma Assert
(RN
(RI
.Node
).Next
= 0
651 or else not (RN
(RN
(RI
.Node
).Next
).Element
<
652 RN
(RI
.Node
).Element
));
655 Splice
(Target
, No_Element
, Source
);
659 pragma Assert
(LN
(LI
.Node
).Next
= 0
660 or else not (LN
(LN
(LI
.Node
).Next
).Element
<
661 LN
(LI
.Node
).Element
));
663 if RN
(RI
.Node
).Element
< LN
(LI
.Node
).Element
then
666 pragma Warnings
(Off
, RJ
);
668 RI
.Node
:= RN
(RI
.Node
).Next
;
669 Splice
(Target
, LI
, Source
, RJ
);
673 LI
.Node
:= LN
(LI
.Node
).Next
;
682 procedure Sort
(Container
: in out List
) is
683 N
: Node_Array
renames Container
.Nodes
;
685 procedure Partition
(Pivot
, Back
: Count_Type
);
686 procedure Sort
(Front
, Back
: Count_Type
);
692 procedure Partition
(Pivot
, Back
: Count_Type
) is
696 Node
:= N
(Pivot
).Next
;
697 while Node
/= Back
loop
698 if N
(Node
).Element
< N
(Pivot
).Element
then
700 Prev
: constant Count_Type
:= N
(Node
).Prev
;
701 Next
: constant Count_Type
:= N
(Node
).Next
;
704 N
(Prev
).Next
:= Next
;
707 Container
.Last
:= Prev
;
709 N
(Next
).Prev
:= Prev
;
712 N
(Node
).Next
:= Pivot
;
713 N
(Node
).Prev
:= N
(Pivot
).Prev
;
715 N
(Pivot
).Prev
:= Node
;
717 if N
(Node
).Prev
= 0 then
718 Container
.First
:= Node
;
720 N
(N
(Node
).Prev
).Next
:= Node
;
727 Node
:= N
(Node
).Next
;
736 procedure Sort
(Front
, Back
: Count_Type
) is
741 Pivot
:= Container
.First
;
743 Pivot
:= N
(Front
).Next
;
746 if Pivot
/= Back
then
747 Partition
(Pivot
, Back
);
753 -- Start of processing for Sort
756 if Container
.Length
<= 1 then
760 pragma Assert
(N
(Container
.First
).Prev
= 0);
761 pragma Assert
(N
(Container
.Last
).Next
= 0);
763 if Container
.Busy
> 0 then
764 raise Program_Error
with
765 "attempt to tamper with elements (list is busy)";
768 Sort
(Front
=> 0, Back
=> 0);
770 pragma Assert
(N
(Container
.First
).Prev
= 0);
771 pragma Assert
(N
(Container
.Last
).Next
= 0);
780 function Has_Element
(Container
: List
; Position
: Cursor
) return Boolean is
782 if Position
.Node
= 0 then
786 return Container
.Nodes
(Position
.Node
).Prev
/= -1;
794 (Container
: in out List
;
796 New_Item
: Element_Type
;
797 Position
: out Cursor
;
798 Count
: Count_Type
:= 1)
803 if Before
.Node
/= 0 then
804 pragma Assert
(Vet
(Container
, Before
), "bad cursor in Insert");
812 if Container
.Length
> Container
.Capacity
- Count
then
813 raise Constraint_Error
with "new length exceeds capacity";
816 if Container
.Busy
> 0 then
817 raise Program_Error
with
818 "attempt to tamper with elements (list is busy)";
821 Allocate
(Container
, New_Item
, New_Node
=> J
);
822 Insert_Internal
(Container
, Before
.Node
, New_Node
=> J
);
823 Position
:= (Node
=> J
);
825 for Index
in 2 .. Count
loop
826 Allocate
(Container
, New_Item
, New_Node
=> J
);
827 Insert_Internal
(Container
, Before
.Node
, New_Node
=> J
);
832 (Container
: in out List
;
834 New_Item
: Element_Type
;
835 Count
: Count_Type
:= 1)
839 Insert
(Container
, Before
, New_Item
, Position
, Count
);
843 (Container
: in out List
;
845 Position
: out Cursor
;
846 Count
: Count_Type
:= 1)
851 if Before
.Node
/= 0 then
852 pragma Assert
(Vet
(Container
, Before
), "bad cursor in Insert");
860 if Container
.Length
> Container
.Capacity
- Count
then
861 raise Constraint_Error
with "new length exceeds capacity";
864 if Container
.Busy
> 0 then
865 raise Program_Error
with
866 "attempt to tamper with elements (list is busy)";
869 Allocate
(Container
, New_Node
=> J
);
870 Insert_Internal
(Container
, Before
.Node
, New_Node
=> J
);
871 Position
:= (Node
=> J
);
873 for Index
in 2 .. Count
loop
874 Allocate
(Container
, New_Node
=> J
);
875 Insert_Internal
(Container
, Before
.Node
, New_Node
=> J
);
879 ---------------------
880 -- Insert_Internal --
881 ---------------------
883 procedure Insert_Internal
884 (Container
: in out List
;
886 New_Node
: Count_Type
)
888 N
: Node_Array
renames Container
.Nodes
;
891 if Container
.Length
= 0 then
892 pragma Assert
(Before
= 0);
893 pragma Assert
(Container
.First
= 0);
894 pragma Assert
(Container
.Last
= 0);
896 Container
.First
:= New_Node
;
897 Container
.Last
:= New_Node
;
899 N
(Container
.First
).Prev
:= 0;
900 N
(Container
.Last
).Next
:= 0;
902 elsif Before
= 0 then
903 pragma Assert
(N
(Container
.Last
).Next
= 0);
905 N
(Container
.Last
).Next
:= New_Node
;
906 N
(New_Node
).Prev
:= Container
.Last
;
908 Container
.Last
:= New_Node
;
909 N
(Container
.Last
).Next
:= 0;
911 elsif Before
= Container
.First
then
912 pragma Assert
(N
(Container
.First
).Prev
= 0);
914 N
(Container
.First
).Prev
:= New_Node
;
915 N
(New_Node
).Next
:= Container
.First
;
917 Container
.First
:= New_Node
;
918 N
(Container
.First
).Prev
:= 0;
921 pragma Assert
(N
(Container
.First
).Prev
= 0);
922 pragma Assert
(N
(Container
.Last
).Next
= 0);
924 N
(New_Node
).Next
:= Before
;
925 N
(New_Node
).Prev
:= N
(Before
).Prev
;
927 N
(N
(Before
).Prev
).Next
:= New_Node
;
928 N
(Before
).Prev
:= New_Node
;
931 Container
.Length
:= Container
.Length
+ 1;
938 function Is_Empty
(Container
: List
) return Boolean is
940 return Length
(Container
) = 0;
950 not null access procedure (Container
: List
; Position
: Cursor
))
952 C
: List
renames Container
'Unrestricted_Access.all;
953 B
: Natural renames C
.Busy
;
960 Node
:= Container
.First
;
962 Process
(Container
, (Node
=> Node
));
963 Node
:= Container
.Nodes
(Node
).Next
;
975 function Iterate
(Container
: List
)
976 return List_Iterator_Interfaces
.Reversible_Iterator
'Class
978 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
981 -- The value of the Node component influences the behavior of the First
982 -- and Last selector functions of the iterator object. When the Node
983 -- component is null (as is the case here), this means the iterator
984 -- object was constructed without a start expression. This is a
985 -- complete iterator, meaning that the iteration starts from the
986 -- (logical) beginning of the sequence of items.
988 -- Note: For a forward iterator, Container.First is the beginning, and
989 -- for a reverse iterator, Container.Last is the beginning.
991 return It
: constant Iterator
:=
992 Iterator
'(Ada.Finalization.Limited_Controlled with
993 Container => Container'Unrestricted_Access,
1000 function Iterate (Container : List; Start : Cursor)
1001 return List_Iterator_Interfaces.Reversible_Iterator'Class
1003 B : Natural renames Container'Unrestricted_Access.all.Busy;
1006 -- It was formerly the case that when Start = No_Element, the partial
1007 -- iterator was defined to behave the same as for a complete iterator,
1008 -- and iterate over the entire sequence of items. However, those
1009 -- semantics were unintuitive and arguably error-prone (it is too easy
1010 -- to accidentally create an endless loop), and so they were changed,
1011 -- per the ARG meeting in Denver on 2011/11. However, there was no
1012 -- consensus about what positive meaning this corner case should have,
1013 -- and so it was decided to simply raise an exception. This does imply,
1014 -- however, that it is not possible to use a partial iterator to specify
1015 -- an empty sequence of items.
1017 if not Has_Element (Container, Start) then
1018 raise Constraint_Error with
1019 "Start position for iterator is not a valid cursor";
1022 -- The value of the Node component influences the behavior of the First
1023 -- and Last selector functions of the iterator object. When the Node
1024 -- component is non-null (as is the case here), it means that this
1025 -- is a partial iteration, over a subset of the complete sequence of
1026 -- items. The iterator object was constructed with a start expression,
1027 -- indicating the position from which the iteration begins. Note that
1028 -- the start position has the same value irrespective of whether this
1029 -- is a forward or reverse iteration.
1031 return It : constant Iterator :=
1032 Iterator'(Ada
.Finalization
.Limited_Controlled
with
1033 Container
=> Container
'Unrestricted_Access,
1044 function Last
(Container
: List
) return Cursor
is
1046 if Container
.Last
= 0 then
1049 return (Node
=> Container
.Last
);
1052 function Last
(Object
: Iterator
) return Cursor
is
1054 -- The value of the iterator object's Node component influences the
1055 -- behavior of the Last (and First) selector function.
1057 -- When the Node component is null, this means the iterator object was
1058 -- constructed without a start expression, in which case the (reverse)
1059 -- iteration starts from the (logical) beginning of the entire sequence
1060 -- (corresponding to Container.Last, for a reverse iterator).
1062 -- Otherwise, this is iteration over a partial sequence of items. When
1063 -- the Node component is non-null, the iterator object was constructed
1064 -- with a start expression, that specifies the position from which the
1065 -- (reverse) partial iteration begins.
1067 if Object
.Node
= 0 then
1068 return Last
(Object
.Container
.all);
1070 return (Node
=> Object
.Node
);
1078 function Last_Element
(Container
: List
) return Element_Type
is
1079 L
: constant Count_Type
:= Container
.Last
;
1082 raise Constraint_Error
with "list is empty";
1084 return Container
.Nodes
(L
).Element
;
1092 function Left
(Container
: List
; Position
: Cursor
) return List
is
1093 Curs
: Cursor
:= Position
;
1094 C
: List
(Container
.Capacity
) := Copy
(Container
, Container
.Capacity
);
1098 if Curs
= No_Element
then
1102 if not Has_Element
(Container
, Curs
) then
1103 raise Constraint_Error
;
1106 while Curs
.Node
/= 0 loop
1109 Curs
:= Next
(Container
, (Node
=> Node
));
1119 function Length
(Container
: List
) return Count_Type
is
1121 return Container
.Length
;
1129 (Target
: in out List
;
1130 Source
: in out List
)
1132 N
: Node_Array
renames Source
.Nodes
;
1136 if Target
'Address = Source
'Address then
1140 if Target
.Capacity
< Source
.Length
then
1141 raise Constraint_Error
with -- ???
1142 "Source length exceeds Target capacity";
1145 if Source
.Busy
> 0 then
1146 raise Program_Error
with
1147 "attempt to tamper with cursors of Source (list is busy)";
1152 while Source
.Length
> 1 loop
1153 pragma Assert
(Source
.First
in 1 .. Source
.Capacity
);
1154 pragma Assert
(Source
.Last
/= Source
.First
);
1155 pragma Assert
(N
(Source
.First
).Prev
= 0);
1156 pragma Assert
(N
(Source
.Last
).Next
= 0);
1158 -- Copy first element from Source to Target
1161 Append
(Target
, N
(X
).Element
); -- optimize away???
1163 -- Unlink first node of Source
1165 Source
.First
:= N
(X
).Next
;
1166 N
(Source
.First
).Prev
:= 0;
1168 Source
.Length
:= Source
.Length
- 1;
1170 -- The representation invariants for Source have been restored. It is
1171 -- now safe to free the unlinked node, without fear of corrupting the
1172 -- active links of Source.
1174 -- Note that the algorithm we use here models similar algorithms used
1175 -- in the unbounded form of the doubly-linked list container. In that
1176 -- case, Free is an instantation of Unchecked_Deallocation, which can
1177 -- fail (because PE will be raised if controlled Finalize fails), so
1178 -- we must defer the call until the last step. Here in the bounded
1179 -- form, Free merely links the node we have just "deallocated" onto a
1180 -- list of inactive nodes, so technically Free cannot fail. However,
1181 -- for consistency, we handle Free the same way here as we do for the
1182 -- unbounded form, with the pessimistic assumption that it can fail.
1187 if Source
.Length
= 1 then
1188 pragma Assert
(Source
.First
in 1 .. Source
.Capacity
);
1189 pragma Assert
(Source
.Last
= Source
.First
);
1190 pragma Assert
(N
(Source
.First
).Prev
= 0);
1191 pragma Assert
(N
(Source
.Last
).Next
= 0);
1193 -- Copy element from Source to Target
1196 Append
(Target
, N
(X
).Element
);
1198 -- Unlink node of Source
1204 -- Return the unlinked node to the free store
1214 procedure Next
(Container
: List
; Position
: in out Cursor
) is
1216 Position
:= Next
(Container
, Position
);
1219 function Next
(Container
: List
; Position
: Cursor
) return Cursor
is
1221 if Position
.Node
= 0 then
1225 if not Has_Element
(Container
, Position
) then
1226 raise Program_Error
with "Position cursor has no element";
1229 return (Node
=> Container
.Nodes
(Position
.Node
).Next
);
1234 Position
: Cursor
) return Cursor
1237 return Next
(Object
.Container
.all, Position
);
1240 --------------------
1241 -- Not_No_Element --
1242 --------------------
1244 function Not_No_Element
(Position
: Cursor
) return Boolean is
1246 return Position
/= No_Element
;
1254 (Container
: in out List
;
1255 New_Item
: Element_Type
;
1256 Count
: Count_Type
:= 1)
1259 Insert
(Container
, First
(Container
), New_Item
, Count
);
1266 procedure Previous
(Container
: List
; Position
: in out Cursor
) is
1268 Position
:= Previous
(Container
, Position
);
1271 function Previous
(Container
: List
; Position
: Cursor
) return Cursor
is
1273 if Position
.Node
= 0 then
1277 if not Has_Element
(Container
, Position
) then
1278 raise Program_Error
with "Position cursor has no element";
1281 return (Node
=> Container
.Nodes
(Position
.Node
).Prev
);
1286 Position
: Cursor
) return Cursor
1289 return Previous
(Object
.Container
.all, Position
);
1296 procedure Query_Element
1297 (Container
: List
; Position
: Cursor
;
1298 Process
: not null access procedure (Element
: Element_Type
))
1300 C
: List
renames Container
'Unrestricted_Access.all;
1301 B
: Natural renames C
.Busy
;
1302 L
: Natural renames C
.Lock
;
1305 if not Has_Element
(Container
, Position
) then
1306 raise Constraint_Error
with
1307 "Position cursor has no element";
1314 N
: Node_Type
renames C
.Nodes
(Position
.Node
);
1316 Process
(N
.Element
);
1333 (Stream
: not null access Root_Stream_Type
'Class;
1336 N
: Count_Type
'Base;
1341 Count_Type
'Base'Read (Stream, N);
1344 raise Program_Error with "bad list length";
1351 if N > Item.Capacity then
1352 raise Constraint_Error with "length exceeds capacity";
1355 for J in 1 .. N loop
1356 Item.Append (Element_Type'Input (Stream)); -- ???
1361 (Stream : not null access Root_Stream_Type'Class;
1365 raise Program_Error with "attempt to stream list cursor";
1372 function Constant_Reference
1374 Position : Cursor) return Constant_Reference_Type
1377 if not Has_Element (Container, Position) then
1378 raise Constraint_Error with "Position cursor has no element";
1381 return (Element => Container.Nodes (Position.Node).Element'Access);
1382 end Constant_Reference;
1384 ---------------------
1385 -- Replace_Element --
1386 ---------------------
1388 procedure Replace_Element
1389 (Container : in out List;
1391 New_Item : Element_Type)
1394 if not Has_Element (Container, Position) then
1395 raise Constraint_Error with "Position cursor has no element";
1398 if Container.Lock > 0 then
1399 raise Program_Error with
1400 "attempt to tamper with cursors (list is locked)";
1404 (Vet (Container, Position), "bad cursor in Replace_Element");
1406 Container.Nodes (Position.Node).Element := New_Item;
1407 end Replace_Element;
1409 ----------------------
1410 -- Reverse_Elements --
1411 ----------------------
1413 procedure Reverse_Elements (Container : in out List) is
1414 N : Node_Array renames Container.Nodes;
1415 I : Count_Type := Container.First;
1416 J : Count_Type := Container.Last;
1418 procedure Swap (L, R : Count_Type);
1424 procedure Swap (L, R : Count_Type) is
1425 LN : constant Count_Type := N (L).Next;
1426 LP : constant Count_Type := N (L).Prev;
1428 RN : constant Count_Type := N (R).Next;
1429 RP : constant Count_Type := N (R).Prev;
1444 pragma Assert (RP = L);
1458 -- Start of processing for Reverse_Elements
1461 if Container.Length <= 1 then
1465 pragma Assert (N (Container.First).Prev = 0);
1466 pragma Assert (N (Container.Last).Next = 0);
1468 if Container.Busy > 0 then
1469 raise Program_Error with
1470 "attempt to tamper with elements (list is busy)";
1473 Container.First := J;
1474 Container.Last := I;
1476 Swap (L => I, R => J);
1484 Swap (L => J, R => I);
1493 pragma Assert (N (Container.First).Prev = 0);
1494 pragma Assert (N (Container.Last).Next = 0);
1495 end Reverse_Elements;
1501 function Reverse_Find
1503 Item : Element_Type;
1504 Position : Cursor := No_Element) return Cursor
1506 CFirst : Count_Type := Position.Node;
1510 CFirst := Container.First;
1513 if Container.Length = 0 then
1517 while CFirst /= 0 loop
1518 if Container.Nodes (CFirst).Element = Item then
1519 return (Node => CFirst);
1521 CFirst := Container.Nodes (CFirst).Prev;
1527 ---------------------
1528 -- Reverse_Iterate --
1529 ---------------------
1531 procedure Reverse_Iterate
1534 not null access procedure (Container : List; Position : Cursor))
1536 C : List renames Container'Unrestricted_Access.all;
1537 B : Natural renames C.Busy;
1545 Node := Container.Last;
1546 while Node /= 0 loop
1547 Process (Container, (Node => Node));
1548 Node := Container.Nodes (Node).Prev;
1558 end Reverse_Iterate;
1564 function Right (Container : List; Position : Cursor) return List is
1565 Curs : Cursor := First (Container);
1566 C : List (Container.Capacity) := Copy (Container, Container.Capacity);
1570 if Curs = No_Element then
1575 if Position /= No_Element and not Has_Element (Container, Position) then
1576 raise Constraint_Error;
1579 while Curs.Node /= Position.Node loop
1582 Curs := Next (Container, (Node => Node));
1593 (Target : in out List;
1595 Source : in out List)
1597 SN : Node_Array renames Source.Nodes;
1600 if Before.Node /= 0 then
1601 pragma Assert (Vet (Target, Before), "bad cursor in Splice");
1604 if Target'Address = Source'Address
1605 or else Source.Length = 0
1610 pragma Assert (SN (Source.First).Prev = 0);
1611 pragma Assert (SN (Source.Last).Next = 0);
1613 if Target.Length > Count_Type'Base'Last
- Source
.Length
then
1614 raise Constraint_Error
with "new length exceeds maximum";
1617 if Target
.Length
+ Source
.Length
> Target
.Capacity
then
1618 raise Constraint_Error
;
1621 if Target
.Busy
> 0 then
1622 raise Program_Error
with
1623 "attempt to tamper with cursors of Target (list is busy)";
1626 if Source
.Busy
> 0 then
1627 raise Program_Error
with
1628 "attempt to tamper with cursors of Source (list is busy)";
1632 Insert
(Target
, Before
, SN
(Source
.Last
).Element
);
1633 Delete_Last
(Source
);
1634 exit when Is_Empty
(Source
);
1639 (Target
: in out List
;
1641 Source
: in out List
;
1642 Position
: in out Cursor
)
1644 Target_Position
: Cursor
;
1647 if Target
'Address = Source
'Address then
1648 Splice
(Target
, Before
, Position
);
1652 if Position
.Node
= 0 then
1653 raise Constraint_Error
with "Position cursor has no element";
1656 pragma Assert
(Vet
(Source
, Position
), "bad Position cursor in Splice");
1658 if Target
.Length
>= Target
.Capacity
then
1659 raise Constraint_Error
;
1662 if Target
.Busy
> 0 then
1663 raise Program_Error
with
1664 "attempt to tamper with cursors of Target (list is busy)";
1667 if Source
.Busy
> 0 then
1668 raise Program_Error
with
1669 "attempt to tamper with cursors of Source (list is busy)";
1673 (Container
=> Target
,
1675 New_Item
=> Source
.Nodes
(Position
.Node
).Element
,
1676 Position
=> Target_Position
);
1678 Delete
(Source
, Position
);
1679 Position
:= Target_Position
;
1683 (Container
: in out List
;
1687 N
: Node_Array
renames Container
.Nodes
;
1690 if Before
.Node
/= 0 then
1692 (Vet
(Container
, Before
), "bad Before cursor in Splice");
1695 if Position
.Node
= 0 then
1696 raise Constraint_Error
with "Position cursor has no element";
1700 (Vet
(Container
, Position
), "bad Position cursor in Splice");
1702 if Position
.Node
= Before
.Node
1703 or else N
(Position
.Node
).Next
= Before
.Node
1708 pragma Assert
(Container
.Length
>= 2);
1710 if Container
.Busy
> 0 then
1711 raise Program_Error
with
1712 "attempt to tamper with elements (list is busy)";
1715 if Before
.Node
= 0 then
1716 pragma Assert
(Position
.Node
/= Container
.Last
);
1718 if Position
.Node
= Container
.First
then
1719 Container
.First
:= N
(Position
.Node
).Next
;
1720 N
(Container
.First
).Prev
:= 0;
1723 N
(N
(Position
.Node
).Prev
).Next
:= N
(Position
.Node
).Next
;
1724 N
(N
(Position
.Node
).Next
).Prev
:= N
(Position
.Node
).Prev
;
1727 N
(Container
.Last
).Next
:= Position
.Node
;
1728 N
(Position
.Node
).Prev
:= Container
.Last
;
1730 Container
.Last
:= Position
.Node
;
1731 N
(Container
.Last
).Next
:= 0;
1736 if Before
.Node
= Container
.First
then
1737 pragma Assert
(Position
.Node
/= Container
.First
);
1739 if Position
.Node
= Container
.Last
then
1740 Container
.Last
:= N
(Position
.Node
).Prev
;
1741 N
(Container
.Last
).Next
:= 0;
1744 N
(N
(Position
.Node
).Prev
).Next
:= N
(Position
.Node
).Next
;
1745 N
(N
(Position
.Node
).Next
).Prev
:= N
(Position
.Node
).Prev
;
1748 N
(Container
.First
).Prev
:= Position
.Node
;
1749 N
(Position
.Node
).Next
:= Container
.First
;
1751 Container
.First
:= Position
.Node
;
1752 N
(Container
.First
).Prev
:= 0;
1757 if Position
.Node
= Container
.First
then
1758 Container
.First
:= N
(Position
.Node
).Next
;
1759 N
(Container
.First
).Prev
:= 0;
1761 elsif Position
.Node
= Container
.Last
then
1762 Container
.Last
:= N
(Position
.Node
).Prev
;
1763 N
(Container
.Last
).Next
:= 0;
1766 N
(N
(Position
.Node
).Prev
).Next
:= N
(Position
.Node
).Next
;
1767 N
(N
(Position
.Node
).Next
).Prev
:= N
(Position
.Node
).Prev
;
1770 N
(N
(Before
.Node
).Prev
).Next
:= Position
.Node
;
1771 N
(Position
.Node
).Prev
:= N
(Before
.Node
).Prev
;
1773 N
(Before
.Node
).Prev
:= Position
.Node
;
1774 N
(Position
.Node
).Next
:= Before
.Node
;
1776 pragma Assert
(N
(Container
.First
).Prev
= 0);
1777 pragma Assert
(N
(Container
.Last
).Next
= 0);
1784 function Strict_Equal
(Left
, Right
: List
) return Boolean is
1785 CL
: Count_Type
:= Left
.First
;
1786 CR
: Count_Type
:= Right
.First
;
1789 while CL
/= 0 or CR
/= 0 loop
1791 Left
.Nodes
(CL
).Element
/= Right
.Nodes
(CL
).Element
1796 CL
:= Left
.Nodes
(CL
).Next
;
1797 CR
:= Right
.Nodes
(CR
).Next
;
1808 (Container
: in out List
;
1813 raise Constraint_Error
with "I cursor has no element";
1817 raise Constraint_Error
with "J cursor has no element";
1820 if I
.Node
= J
.Node
then
1824 if Container
.Lock
> 0 then
1825 raise Program_Error
with
1826 "attempt to tamper with cursors (list is locked)";
1829 pragma Assert
(Vet
(Container
, I
), "bad I cursor in Swap");
1830 pragma Assert
(Vet
(Container
, J
), "bad J cursor in Swap");
1833 NN
: Node_Array
renames Container
.Nodes
;
1834 NI
: Node_Type
renames NN
(I
.Node
);
1835 NJ
: Node_Type
renames NN
(J
.Node
);
1837 EI_Copy
: constant Element_Type
:= NI
.Element
;
1840 NI
.Element
:= NJ
.Element
;
1841 NJ
.Element
:= EI_Copy
;
1849 procedure Swap_Links
1850 (Container
: in out List
;
1853 I_Next
, J_Next
: Cursor
;
1857 raise Constraint_Error
with "I cursor has no element";
1861 raise Constraint_Error
with "J cursor has no element";
1864 if I
.Node
= J
.Node
then
1868 if Container
.Busy
> 0 then
1869 raise Program_Error
with
1870 "attempt to tamper with elements (list is busy)";
1873 pragma Assert
(Vet
(Container
, I
), "bad I cursor in Swap_Links");
1874 pragma Assert
(Vet
(Container
, J
), "bad J cursor in Swap_Links");
1876 I_Next
:= Next
(Container
, I
);
1879 Splice
(Container
, Before
=> I
, Position
=> J
);
1882 J_Next
:= Next
(Container
, J
);
1885 Splice
(Container
, Before
=> J
, Position
=> I
);
1888 pragma Assert
(Container
.Length
>= 3);
1889 Splice
(Container
, Before
=> I_Next
, Position
=> J
);
1890 Splice
(Container
, Before
=> J_Next
, Position
=> I
);
1895 --------------------
1896 -- Update_Element --
1897 --------------------
1899 procedure Update_Element
1900 (Container
: in out List
;
1902 Process
: not null access procedure (Element
: in out Element_Type
))
1905 if Position
.Node
= 0 then
1906 raise Constraint_Error
with "Position cursor has no element";
1910 (Vet
(Container
, Position
), "bad cursor in Update_Element");
1913 B
: Natural renames Container
.Busy
;
1914 L
: Natural renames Container
.Lock
;
1921 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
1923 Process
(N
.Element
);
1940 function Vet
(L
: List
; Position
: Cursor
) return Boolean is
1941 N
: Node_Array
renames L
.Nodes
;
1944 if L
.Length
= 0 then
1956 if Position
.Node
> L
.Capacity
then
1960 if N
(Position
.Node
).Prev
< 0
1961 or else N
(Position
.Node
).Prev
> L
.Capacity
1966 if N
(Position
.Node
).Next
> L
.Capacity
then
1970 if N
(L
.First
).Prev
/= 0 then
1974 if N
(L
.Last
).Next
/= 0 then
1978 if N
(Position
.Node
).Prev
= 0
1979 and then Position
.Node
/= L
.First
1984 if N
(Position
.Node
).Next
= 0
1985 and then Position
.Node
/= L
.Last
1990 if L
.Length
= 1 then
1991 return L
.First
= L
.Last
;
1994 if L
.First
= L
.Last
then
1998 if N
(L
.First
).Next
= 0 then
2002 if N
(L
.Last
).Prev
= 0 then
2006 if N
(N
(L
.First
).Next
).Prev
/= L
.First
then
2010 if N
(N
(L
.Last
).Prev
).Next
/= L
.Last
then
2014 if L
.Length
= 2 then
2015 if N
(L
.First
).Next
/= L
.Last
then
2019 if N
(L
.Last
).Prev
/= L
.First
then
2026 if N
(L
.First
).Next
= L
.Last
then
2030 if N
(L
.Last
).Prev
= L
.First
then
2034 if Position
.Node
= L
.First
then
2038 if Position
.Node
= L
.Last
then
2042 if N
(Position
.Node
).Next
= 0 then
2046 if N
(Position
.Node
).Prev
= 0 then
2050 if N
(N
(Position
.Node
).Next
).Prev
/= Position
.Node
then
2054 if N
(N
(Position
.Node
).Prev
).Next
/= Position
.Node
then
2058 if L
.Length
= 3 then
2059 if N
(L
.First
).Next
/= Position
.Node
then
2063 if N
(L
.Last
).Prev
/= Position
.Node
then
2076 (Stream
: not null access Root_Stream_Type
'Class;
2079 N
: Node_Array
renames Item
.Nodes
;
2083 Count_Type
'Base'Write (Stream, Item.Length);
2086 while Node /= 0 loop
2087 Element_Type'Write (Stream, N (Node).Element);
2088 Node := N (Node).Next;
2093 (Stream : not null access Root_Stream_Type'Class;
2097 raise Program_Error with "attempt to stream list cursor";
2100 end Ada.Containers.Formal_Doubly_Linked_Lists;