1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S --
9 -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Unchecked_Deallocation
;
32 with System
; use type System
.Address
;
34 package body Ada
.Containers
.Doubly_Linked_Lists
is
36 -----------------------
37 -- Local Subprograms --
38 -----------------------
40 procedure Free
(X
: in out Node_Access
);
42 procedure Insert_Internal
43 (Container
: in out List
;
45 New_Node
: Node_Access
);
47 procedure Splice_Internal
48 (Target
: in out List
;
50 Source
: in out List
);
52 procedure Splice_Internal
53 (Target
: in out List
;
56 Position
: Node_Access
);
58 function Vet
(Position
: Cursor
) return Boolean;
59 -- Checks invariants of the cursor and its designated container, as a
60 -- simple way of detecting dangling references (see operation Free for a
61 -- description of the detection mechanism), returning True if all checks
62 -- pass. Invocations of Vet are used here as the argument of pragma Assert,
63 -- so the checks are performed only when assertions are enabled.
69 function "=" (Left
, Right
: List
) return Boolean is
70 BL
: Natural renames Left
'Unrestricted_Access.Busy
;
71 LL
: Natural renames Left
'Unrestricted_Access.Lock
;
73 BR
: Natural renames Right
'Unrestricted_Access.Busy
;
74 LR
: Natural renames Right
'Unrestricted_Access.Lock
;
81 if Left
'Address = Right
'Address then
85 if Left
.Length
/= Right
.Length
then
89 -- Per AI05-0022, the container implementation is required to detect
90 -- element tampering by a generic actual subprogram.
101 for J
in 1 .. Left
.Length
loop
102 if L
.Element
/= R
.Element
then
134 procedure Adjust
(Container
: in out List
) is
135 Src
: Node_Access
:= Container
.First
;
139 pragma Assert
(Container
.Last
= null);
140 pragma Assert
(Container
.Length
= 0);
141 pragma Assert
(Container
.Busy
= 0);
142 pragma Assert
(Container
.Lock
= 0);
146 pragma Assert
(Container
.First
.Prev
= null);
147 pragma Assert
(Container
.Last
.Next
= null);
148 pragma Assert
(Container
.Length
> 0);
150 Container
.First
:= null;
151 Container
.Last
:= null;
152 Container
.Length
:= 0;
156 Container
.First
:= new Node_Type
'(Src.Element, null, null);
157 Container.Last := Container.First;
158 Container.Length := 1;
161 while Src /= null loop
162 Container.Last.Next := new Node_Type'(Element
=> Src
.Element
,
163 Prev
=> Container
.Last
,
165 Container
.Last
:= Container
.Last
.Next
;
166 Container
.Length
:= Container
.Length
+ 1;
172 procedure Adjust
(Control
: in out Reference_Control_Type
) is
174 if Control
.Container
/= null then
176 C
: List
renames Control
.Container
.all;
177 B
: Natural renames C
.Busy
;
178 L
: Natural renames C
.Lock
;
191 (Container
: in out List
;
192 New_Item
: Element_Type
;
193 Count
: Count_Type
:= 1)
196 Insert
(Container
, No_Element
, New_Item
, Count
);
203 procedure Assign
(Target
: in out List
; Source
: List
) is
207 if Target
'Address = Source
'Address then
213 Node
:= Source
.First
;
214 while Node
/= null loop
215 Target
.Append
(Node
.Element
);
224 procedure Clear
(Container
: in out List
) is
228 if Container
.Length
= 0 then
229 pragma Assert
(Container
.First
= null);
230 pragma Assert
(Container
.Last
= null);
231 pragma Assert
(Container
.Busy
= 0);
232 pragma Assert
(Container
.Lock
= 0);
236 pragma Assert
(Container
.First
.Prev
= null);
237 pragma Assert
(Container
.Last
.Next
= null);
239 if Container
.Busy
> 0 then
240 raise Program_Error
with
241 "attempt to tamper with cursors (list is busy)";
244 while Container
.Length
> 1 loop
245 X
:= Container
.First
;
246 pragma Assert
(X
.Next
.Prev
= Container
.First
);
248 Container
.First
:= X
.Next
;
249 Container
.First
.Prev
:= null;
251 Container
.Length
:= Container
.Length
- 1;
256 X
:= Container
.First
;
257 pragma Assert
(X
= Container
.Last
);
259 Container
.First
:= null;
260 Container
.Last
:= null;
261 Container
.Length
:= 0;
263 pragma Warnings
(Off
);
265 pragma Warnings
(On
);
268 ------------------------
269 -- Constant_Reference --
270 ------------------------
272 function Constant_Reference
273 (Container
: aliased List
;
274 Position
: Cursor
) return Constant_Reference_Type
277 if Position
.Container
= null then
278 raise Constraint_Error
with "Position cursor has no element";
281 if Position
.Container
/= Container
'Unrestricted_Access then
282 raise Program_Error
with
283 "Position cursor designates wrong container";
286 pragma Assert
(Vet
(Position
), "bad cursor in Constant_Reference");
289 C
: List
renames Position
.Container
.all;
290 B
: Natural renames C
.Busy
;
291 L
: Natural renames C
.Lock
;
293 return R
: constant Constant_Reference_Type
:=
294 (Element
=> Position
.Node
.Element
'Access,
295 Control
=> (Controlled
with Container
'Unrestricted_Access))
301 end Constant_Reference
;
309 Item
: Element_Type
) return Boolean
312 return Find
(Container
, Item
) /= No_Element
;
319 function Copy
(Source
: List
) return List
is
321 return Target
: List
do
322 Target
.Assign
(Source
);
331 (Container
: in out List
;
332 Position
: in out Cursor
;
333 Count
: Count_Type
:= 1)
338 if Position
.Node
= null then
339 raise Constraint_Error
with
340 "Position cursor has no element";
343 if Position
.Container
/= Container
'Unrestricted_Access then
344 raise Program_Error
with
345 "Position cursor designates wrong container";
348 pragma Assert
(Vet
(Position
), "bad cursor in Delete");
350 if Position
.Node
= Container
.First
then
351 Delete_First
(Container
, Count
);
352 Position
:= No_Element
; -- Post-York behavior
357 Position
:= No_Element
; -- Post-York behavior
361 if Container
.Busy
> 0 then
362 raise Program_Error
with
363 "attempt to tamper with cursors (list is busy)";
366 for Index
in 1 .. Count
loop
368 Container
.Length
:= Container
.Length
- 1;
370 if X
= Container
.Last
then
371 Position
:= No_Element
;
373 Container
.Last
:= X
.Prev
;
374 Container
.Last
.Next
:= null;
380 Position
.Node
:= X
.Next
;
382 X
.Next
.Prev
:= X
.Prev
;
383 X
.Prev
.Next
:= X
.Next
;
388 -- The following comment is unacceptable, more detail needed ???
390 Position
:= No_Element
; -- Post-York behavior
397 procedure Delete_First
398 (Container
: in out List
;
399 Count
: Count_Type
:= 1)
404 if Count
>= Container
.Length
then
413 if Container
.Busy
> 0 then
414 raise Program_Error
with
415 "attempt to tamper with cursors (list is busy)";
418 for J
in 1 .. Count
loop
419 X
:= Container
.First
;
420 pragma Assert
(X
.Next
.Prev
= Container
.First
);
422 Container
.First
:= X
.Next
;
423 Container
.First
.Prev
:= null;
425 Container
.Length
:= Container
.Length
- 1;
435 procedure Delete_Last
436 (Container
: in out List
;
437 Count
: Count_Type
:= 1)
442 if Count
>= Container
.Length
then
451 if Container
.Busy
> 0 then
452 raise Program_Error
with
453 "attempt to tamper with cursors (list is busy)";
456 for J
in 1 .. Count
loop
458 pragma Assert
(X
.Prev
.Next
= Container
.Last
);
460 Container
.Last
:= X
.Prev
;
461 Container
.Last
.Next
:= null;
463 Container
.Length
:= Container
.Length
- 1;
473 function Element
(Position
: Cursor
) return Element_Type
is
475 if Position
.Node
= null then
476 raise Constraint_Error
with
477 "Position cursor has no element";
479 pragma Assert
(Vet
(Position
), "bad cursor in Element");
481 return Position
.Node
.Element
;
489 procedure Finalize
(Object
: in out Iterator
) is
491 if Object
.Container
/= null then
493 B
: Natural renames Object
.Container
.all.Busy
;
500 procedure Finalize
(Control
: in out Reference_Control_Type
) is
502 if Control
.Container
/= null then
504 C
: List
renames Control
.Container
.all;
505 B
: Natural renames C
.Busy
;
506 L
: Natural renames C
.Lock
;
512 Control
.Container
:= null;
523 Position
: Cursor
:= No_Element
) return Cursor
525 Node
: Node_Access
:= Position
.Node
;
529 Node
:= Container
.First
;
532 if Position
.Container
/= Container
'Unrestricted_Access then
533 raise Program_Error
with
534 "Position cursor designates wrong container";
536 pragma Assert
(Vet
(Position
), "bad cursor in Find");
540 -- Per AI05-0022, the container implementation is required to detect
541 -- element tampering by a generic actual subprogram.
544 B
: Natural renames Container
'Unrestricted_Access.Busy
;
545 L
: Natural renames Container
'Unrestricted_Access.Lock
;
547 Result
: Node_Access
;
553 pragma Warnings
(Off
);
554 -- Deal with junk infinite loop warning from below loop
557 while Node
/= null loop
558 if Node
.Element
= Item
then
566 pragma Warnings
(On
);
567 -- End of section dealing with junk infinite loop warning
572 if Result
= null then
575 return Cursor
'(Container'Unrestricted_Access, Result);
590 function First (Container : List) return Cursor is
592 if Container.First = null then
595 return Cursor'(Container
'Unrestricted_Access, Container
.First
);
599 function First
(Object
: Iterator
) return Cursor
is
601 -- The value of the iterator object's Node component influences the
602 -- behavior of the First (and Last) selector function.
604 -- When the Node component is null, this means the iterator object was
605 -- constructed without a start expression, in which case the (forward)
606 -- iteration starts from the (logical) beginning of the entire sequence
607 -- of items (corresponding to Container.First, for a forward iterator).
609 -- Otherwise, this is iteration over a partial sequence of items. When
610 -- the Node component is non-null, the iterator object was constructed
611 -- with a start expression, that specifies the position from which the
612 -- (forward) partial iteration begins.
614 if Object
.Node
= null then
615 return Doubly_Linked_Lists
.First
(Object
.Container
.all);
617 return Cursor
'(Object.Container, Object.Node);
625 function First_Element (Container : List) return Element_Type is
627 if Container.First = null then
628 raise Constraint_Error with "list is empty";
630 return Container.First.Element;
638 procedure Free (X : in out Node_Access) is
639 procedure Deallocate is
640 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
643 -- While a node is in use, as an active link in a list, its Previous and
644 -- Next components must be null, or designate a different node; this is
645 -- a node invariant. Before actually deallocating the node, we set both
646 -- access value components of the node to point to the node itself, thus
647 -- falsifying the node invariant. Subprogram Vet inspects the value of
648 -- the node components when interrogating the node, in order to detect
649 -- whether the cursor's node access value is dangling.
651 -- Note that we have no guarantee that the storage for the node isn't
652 -- modified when it is deallocated, but there are other tests that Vet
653 -- does if node invariants appear to be satisifed. However, in practice
654 -- this simple test works well enough, detecting dangling references
655 -- immediately, without needing further interrogation.
663 ---------------------
664 -- Generic_Sorting --
665 ---------------------
667 package body Generic_Sorting is
673 function Is_Sorted (Container : List) return Boolean is
674 B : Natural renames Container'Unrestricted_Access.Busy;
675 L : Natural renames Container'Unrestricted_Access.Lock;
681 -- Per AI05-0022, the container implementation is required to detect
682 -- element tampering by a generic actual subprogram.
687 Node := Container.First;
689 for Idx in 2 .. Container.Length loop
690 if Node.Next.Element < Node.Element then
715 (Target : in out List;
716 Source : in out List)
719 -- The semantics of Merge changed slightly per AI05-0021. It was
720 -- originally the case that if Target and Source denoted the same
721 -- container object, then the GNAT implementation of Merge did
722 -- nothing. However, it was argued that RM05 did not precisely
723 -- specify the semantics for this corner case. The decision of the
724 -- ARG was that if Target and Source denote the same non-empty
725 -- container object, then Program_Error is raised.
727 if Source.Is_Empty then
731 if Target'Address = Source'Address then
732 raise Program_Error with
733 "Target and Source denote same non-empty container";
736 if Target.Length > Count_Type'Last - Source.Length then
737 raise Constraint_Error with "new length exceeds maximum";
740 if Target.Busy > 0 then
741 raise Program_Error with
742 "attempt to tamper with cursors of Target (list is busy)";
745 if Source.Busy > 0 then
746 raise Program_Error with
747 "attempt to tamper with cursors of Source (list is busy)";
750 -- Per AI05-0022, the container implementation is required to detect
751 -- element tampering by a generic actual subprogram.
754 TB : Natural renames Target.Busy;
755 TL : Natural renames Target.Lock;
757 SB : Natural renames Source.Busy;
758 SL : Natural renames Source.Lock;
760 LI, RI, RJ : Node_Access;
771 while RI /= null loop
772 pragma Assert (RI.Next = null
773 or else not (RI.Next.Element < RI.Element));
776 Splice_Internal (Target, null, Source);
780 pragma Assert (LI.Next = null
781 or else not (LI.Next.Element < LI.Element));
783 if RI.Element < LI.Element then
786 Splice_Internal (Target, LI, Source, RJ);
815 procedure Sort (Container : in out List) is
817 procedure Partition (Pivot : Node_Access; Back : Node_Access);
819 procedure Sort (Front, Back : Node_Access);
825 procedure Partition (Pivot : Node_Access; Back : Node_Access) is
830 while Node /= Back loop
831 if Node.Element < Pivot.Element then
833 Prev : constant Node_Access := Node.Prev;
834 Next : constant Node_Access := Node.Next;
840 Container.Last := Prev;
846 Node.Prev := Pivot.Prev;
850 if Node.Prev = null then
851 Container.First := Node;
853 Node.Prev.Next := Node;
869 procedure Sort (Front, Back : Node_Access) is
870 Pivot : constant Node_Access :=
871 (if Front = null then Container.First else Front.Next);
873 if Pivot /= Back then
874 Partition (Pivot, Back);
880 -- Start of processing for Sort
883 if Container.Length <= 1 then
887 pragma Assert (Container.First.Prev = null);
888 pragma Assert (Container.Last.Next = null);
890 if Container.Busy > 0 then
891 raise Program_Error with
892 "attempt to tamper with cursors (list is busy)";
895 -- Per AI05-0022, the container implementation is required to detect
896 -- element tampering by a generic actual subprogram.
899 B : Natural renames Container.Busy;
900 L : Natural renames Container.Lock;
906 Sort (Front => null, Back => null);
918 pragma Assert (Container.First.Prev = null);
919 pragma Assert (Container.Last.Next = null);
928 function Has_Element (Position : Cursor) return Boolean is
930 pragma Assert (Vet (Position), "bad cursor in Has_Element");
931 return Position.Node /= null;
939 (Container : in out List;
941 New_Item : Element_Type;
942 Position : out Cursor;
943 Count : Count_Type := 1)
945 New_Node : Node_Access;
948 if Before.Container /= null then
949 if Before.Container /= Container'Unrestricted_Access then
950 raise Program_Error with
951 "Before cursor designates wrong list";
953 pragma Assert (Vet (Before), "bad cursor in Insert");
961 elsif Container.Length > Count_Type'Last - Count then
962 raise Constraint_Error with "new length exceeds maximum";
964 elsif Container.Busy > 0 then
965 raise Program_Error with
966 "attempt to tamper with cursors (list is busy)";
969 New_Node := new Node_Type'(New_Item
, null, null);
970 Insert_Internal
(Container
, Before
.Node
, New_Node
);
972 Position
:= Cursor
'(Container'Unchecked_Access, New_Node);
974 for J in 2 .. Count loop
975 New_Node := new Node_Type'(New_Item
, null, null);
976 Insert_Internal
(Container
, Before
.Node
, New_Node
);
982 (Container
: in out List
;
984 New_Item
: Element_Type
;
985 Count
: Count_Type
:= 1)
988 pragma Unreferenced
(Position
);
990 Insert
(Container
, Before
, New_Item
, Position
, Count
);
994 (Container
: in out List
;
996 Position
: out Cursor
;
997 Count
: Count_Type
:= 1)
999 New_Node
: Node_Access
;
1002 if Before
.Container
/= null then
1003 if Before
.Container
/= Container
'Unrestricted_Access then
1004 raise Program_Error
with
1005 "Before cursor designates wrong list";
1007 pragma Assert
(Vet
(Before
), "bad cursor in Insert");
1016 if Container
.Length
> Count_Type
'Last - Count
then
1017 raise Constraint_Error
with "new length exceeds maximum";
1019 elsif Container
.Busy
> 0 then
1020 raise Program_Error
with
1021 "attempt to tamper with cursors (list is busy)";
1024 New_Node
:= new Node_Type
;
1025 Insert_Internal
(Container
, Before
.Node
, New_Node
);
1027 Position
:= Cursor
'(Container'Unchecked_Access, New_Node);
1029 for J in 2 .. Count loop
1030 New_Node := new Node_Type;
1031 Insert_Internal (Container, Before.Node, New_Node);
1036 ---------------------
1037 -- Insert_Internal --
1038 ---------------------
1040 procedure Insert_Internal
1041 (Container : in out List;
1042 Before : Node_Access;
1043 New_Node : Node_Access)
1046 if Container.Length = 0 then
1047 pragma Assert (Before = null);
1048 pragma Assert (Container.First = null);
1049 pragma Assert (Container.Last = null);
1051 Container.First := New_Node;
1052 Container.Last := New_Node;
1054 elsif Before = null then
1055 pragma Assert (Container.Last.Next = null);
1057 Container.Last.Next := New_Node;
1058 New_Node.Prev := Container.Last;
1060 Container.Last := New_Node;
1062 elsif Before = Container.First then
1063 pragma Assert (Container.First.Prev = null);
1065 Container.First.Prev := New_Node;
1066 New_Node.Next := Container.First;
1068 Container.First := New_Node;
1071 pragma Assert (Container.First.Prev = null);
1072 pragma Assert (Container.Last.Next = null);
1074 New_Node.Next := Before;
1075 New_Node.Prev := Before.Prev;
1077 Before.Prev.Next := New_Node;
1078 Before.Prev := New_Node;
1081 Container.Length := Container.Length + 1;
1082 end Insert_Internal;
1088 function Is_Empty (Container : List) return Boolean is
1090 return Container.Length = 0;
1099 Process : not null access procedure (Position : Cursor))
1101 B : Natural renames Container'Unrestricted_Access.all.Busy;
1102 Node : Node_Access := Container.First;
1108 while Node /= null loop
1109 Process (Cursor'(Container
'Unrestricted_Access, Node
));
1121 function Iterate
(Container
: List
)
1122 return List_Iterator_Interfaces
.Reversible_Iterator
'Class
1124 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
1127 -- The value of the Node component influences the behavior of the First
1128 -- and Last selector functions of the iterator object. When the Node
1129 -- component is null (as is the case here), this means the iterator
1130 -- object was constructed without a start expression. This is a
1131 -- complete iterator, meaning that the iteration starts from the
1132 -- (logical) beginning of the sequence of items.
1134 -- Note: For a forward iterator, Container.First is the beginning, and
1135 -- for a reverse iterator, Container.Last is the beginning.
1137 return It
: constant Iterator
:=
1138 Iterator
'(Limited_Controlled with
1139 Container => Container'Unrestricted_Access,
1146 function Iterate (Container : List; Start : Cursor)
1147 return List_Iterator_Interfaces.Reversible_Iterator'Class
1149 B : Natural renames Container'Unrestricted_Access.all.Busy;
1152 -- It was formerly the case that when Start = No_Element, the partial
1153 -- iterator was defined to behave the same as for a complete iterator,
1154 -- and iterate over the entire sequence of items. However, those
1155 -- semantics were unintuitive and arguably error-prone (it is too easy
1156 -- to accidentally create an endless loop), and so they were changed,
1157 -- per the ARG meeting in Denver on 2011/11. However, there was no
1158 -- consensus about what positive meaning this corner case should have,
1159 -- and so it was decided to simply raise an exception. This does imply,
1160 -- however, that it is not possible to use a partial iterator to specify
1161 -- an empty sequence of items.
1163 if Start = No_Element then
1164 raise Constraint_Error with
1165 "Start position for iterator equals No_Element";
1167 elsif Start.Container /= Container'Unrestricted_Access then
1168 raise Program_Error with
1169 "Start cursor of Iterate designates wrong list";
1172 pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
1174 -- The value of the Node component influences the behavior of the
1175 -- First and Last selector functions of the iterator object. When
1176 -- the Node component is non-null (as is the case here), it means
1177 -- that this is a partial iteration, over a subset of the complete
1178 -- sequence of items. The iterator object was constructed with
1179 -- a start expression, indicating the position from which the
1180 -- iteration begins. Note that the start position has the same value
1181 -- irrespective of whether this is a forward or reverse iteration.
1183 return It : constant Iterator :=
1184 Iterator'(Limited_Controlled
with
1185 Container
=> Container
'Unrestricted_Access,
1197 function Last
(Container
: List
) return Cursor
is
1199 if Container
.Last
= null then
1202 return Cursor
'(Container'Unrestricted_Access, Container.Last);
1206 function Last (Object : Iterator) return Cursor is
1208 -- The value of the iterator object's Node component influences the
1209 -- behavior of the Last (and First) selector function.
1211 -- When the Node component is null, this means the iterator object was
1212 -- constructed without a start expression, in which case the (reverse)
1213 -- iteration starts from the (logical) beginning of the entire sequence
1214 -- (corresponding to Container.Last, for a reverse iterator).
1216 -- Otherwise, this is iteration over a partial sequence of items. When
1217 -- the Node component is non-null, the iterator object was constructed
1218 -- with a start expression, that specifies the position from which the
1219 -- (reverse) partial iteration begins.
1221 if Object.Node = null then
1222 return Doubly_Linked_Lists.Last (Object.Container.all);
1224 return Cursor'(Object
.Container
, Object
.Node
);
1232 function Last_Element
(Container
: List
) return Element_Type
is
1234 if Container
.Last
= null then
1235 raise Constraint_Error
with "list is empty";
1237 return Container
.Last
.Element
;
1245 function Length
(Container
: List
) return Count_Type
is
1247 return Container
.Length
;
1255 (Target
: in out List
;
1256 Source
: in out List
)
1259 if Target
'Address = Source
'Address then
1262 elsif Source
.Busy
> 0 then
1263 raise Program_Error
with
1264 "attempt to tamper with cursors of Source (list is busy)";
1269 Target
.First
:= Source
.First
;
1270 Source
.First
:= null;
1272 Target
.Last
:= Source
.Last
;
1273 Source
.Last
:= null;
1275 Target
.Length
:= Source
.Length
;
1284 procedure Next
(Position
: in out Cursor
) is
1286 Position
:= Next
(Position
);
1289 function Next
(Position
: Cursor
) return Cursor
is
1291 if Position
.Node
= null then
1295 pragma Assert
(Vet
(Position
), "bad cursor in Next");
1298 Next_Node
: constant Node_Access
:= Position
.Node
.Next
;
1300 if Next_Node
= null then
1303 return Cursor
'(Position.Container, Next_Node);
1311 Position : Cursor) return Cursor
1314 if Position.Container = null then
1316 elsif Position.Container /= Object.Container then
1317 raise Program_Error with
1318 "Position cursor of Next designates wrong list";
1320 return Next (Position);
1329 (Container : in out List;
1330 New_Item : Element_Type;
1331 Count : Count_Type := 1)
1334 Insert (Container, First (Container), New_Item, Count);
1341 procedure Previous (Position : in out Cursor) is
1343 Position := Previous (Position);
1346 function Previous (Position : Cursor) return Cursor is
1348 if Position.Node = null then
1352 pragma Assert (Vet (Position), "bad cursor in Previous");
1355 Prev_Node : constant Node_Access := Position.Node.Prev;
1357 if Prev_Node = null then
1360 return Cursor'(Position
.Container
, Prev_Node
);
1368 Position
: Cursor
) return Cursor
1371 if Position
.Container
= null then
1373 elsif Position
.Container
/= Object
.Container
then
1374 raise Program_Error
with
1375 "Position cursor of Previous designates wrong list";
1377 return Previous
(Position
);
1385 procedure Query_Element
1387 Process
: not null access procedure (Element
: Element_Type
))
1390 if Position
.Node
= null then
1391 raise Constraint_Error
with
1392 "Position cursor has no element";
1395 pragma Assert
(Vet
(Position
), "bad cursor in Query_Element");
1398 C
: List
renames Position
.Container
.all'Unrestricted_Access.all;
1399 B
: Natural renames C
.Busy
;
1400 L
: Natural renames C
.Lock
;
1407 Process
(Position
.Node
.Element
);
1425 (Stream
: not null access Root_Stream_Type
'Class;
1428 N
: Count_Type
'Base;
1433 Count_Type
'Base'Read (Stream, N);
1442 Element_Type'Read (Stream, X.Element);
1453 Item.Length := Item.Length + 1;
1454 exit when Item.Length = N;
1459 Element_Type'Read (Stream, X.Element);
1466 X.Prev := Item.Last;
1467 Item.Last.Next := X;
1473 (Stream : not null access Root_Stream_Type'Class;
1477 raise Program_Error with "attempt to stream list cursor";
1481 (Stream : not null access Root_Stream_Type'Class;
1482 Item : out Reference_Type)
1485 raise Program_Error with "attempt to stream reference";
1489 (Stream : not null access Root_Stream_Type'Class;
1490 Item : out Constant_Reference_Type)
1493 raise Program_Error with "attempt to stream reference";
1501 (Container : aliased in out List;
1502 Position : Cursor) return Reference_Type
1505 if Position.Container = null then
1506 raise Constraint_Error with "Position cursor has no element";
1508 elsif Position.Container /= Container'Unchecked_Access then
1509 raise Program_Error with
1510 "Position cursor designates wrong container";
1513 pragma Assert (Vet (Position), "bad cursor in function Reference");
1516 C : List renames Position.Container.all;
1517 B : Natural renames C.Busy;
1518 L : Natural renames C.Lock;
1520 return R : constant Reference_Type :=
1521 (Element => Position.Node.Element'Access,
1522 Control => (Controlled with Position.Container))
1531 ---------------------
1532 -- Replace_Element --
1533 ---------------------
1535 procedure Replace_Element
1536 (Container : in out List;
1538 New_Item : Element_Type)
1541 if Position.Container = null then
1542 raise Constraint_Error with "Position cursor has no element";
1544 elsif Position.Container /= Container'Unchecked_Access then
1545 raise Program_Error with
1546 "Position cursor designates wrong container";
1548 elsif Container.Lock > 0 then
1549 raise Program_Error with
1550 "attempt to tamper with elements (list is locked)";
1553 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1555 Position.Node.Element := New_Item;
1557 end Replace_Element;
1559 ----------------------
1560 -- Reverse_Elements --
1561 ----------------------
1563 procedure Reverse_Elements (Container : in out List) is
1564 I : Node_Access := Container.First;
1565 J : Node_Access := Container.Last;
1567 procedure Swap (L, R : Node_Access);
1573 procedure Swap (L, R : Node_Access) is
1574 LN : constant Node_Access := L.Next;
1575 LP : constant Node_Access := L.Prev;
1577 RN : constant Node_Access := R.Next;
1578 RP : constant Node_Access := R.Prev;
1593 pragma Assert (RP = L);
1607 -- Start of processing for Reverse_Elements
1610 if Container.Length <= 1 then
1614 pragma Assert (Container.First.Prev = null);
1615 pragma Assert (Container.Last.Next = null);
1617 if Container.Busy > 0 then
1618 raise Program_Error with
1619 "attempt to tamper with cursors (list is busy)";
1622 Container.First := J;
1623 Container.Last := I;
1625 Swap (L => I, R => J);
1633 Swap (L => J, R => I);
1642 pragma Assert (Container.First.Prev = null);
1643 pragma Assert (Container.Last.Next = null);
1644 end Reverse_Elements;
1650 function Reverse_Find
1652 Item : Element_Type;
1653 Position : Cursor := No_Element) return Cursor
1655 Node : Node_Access := Position.Node;
1659 Node := Container.Last;
1662 if Position.Container /= Container'Unrestricted_Access then
1663 raise Program_Error with
1664 "Position cursor designates wrong container";
1666 pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1670 -- Per AI05-0022, the container implementation is required to detect
1671 -- element tampering by a generic actual subprogram.
1674 B : Natural renames Container'Unrestricted_Access.Busy;
1675 L : Natural renames Container'Unrestricted_Access.Lock;
1677 Result : Node_Access;
1684 while Node /= null loop
1685 if Node.Element = Item then
1696 if Result = null then
1699 return Cursor'(Container
'Unrestricted_Access, Result
);
1710 ---------------------
1711 -- Reverse_Iterate --
1712 ---------------------
1714 procedure Reverse_Iterate
1716 Process
: not null access procedure (Position
: Cursor
))
1718 C
: List
renames Container
'Unrestricted_Access.all;
1719 B
: Natural renames C
.Busy
;
1721 Node
: Node_Access
:= Container
.Last
;
1727 while Node
/= null loop
1728 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1738 end Reverse_Iterate;
1745 (Target : in out List;
1747 Source : in out List)
1750 if Before.Container /= null then
1751 if Before.Container /= Target'Unrestricted_Access then
1752 raise Program_Error with
1753 "Before cursor designates wrong container";
1755 pragma Assert (Vet (Before), "bad cursor in Splice");
1759 if Target'Address = Source'Address or else Source.Length = 0 then
1762 elsif Target.Length > Count_Type'Last - Source.Length then
1763 raise Constraint_Error with "new length exceeds maximum";
1765 elsif Target.Busy > 0 then
1766 raise Program_Error with
1767 "attempt to tamper with cursors of Target (list is busy)";
1769 elsif Source.Busy > 0 then
1770 raise Program_Error with
1771 "attempt to tamper with cursors of Source (list is busy)";
1774 Splice_Internal (Target, Before.Node, Source);
1779 (Container : in out List;
1784 if Before.Container /= null then
1785 if Before.Container /= Container'Unchecked_Access then
1786 raise Program_Error with
1787 "Before cursor designates wrong container";
1789 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1793 if Position.Node = null then
1794 raise Constraint_Error with "Position cursor has no element";
1797 if Position.Container /= Container'Unrestricted_Access then
1798 raise Program_Error with
1799 "Position cursor designates wrong container";
1802 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1804 if Position.Node = Before.Node
1805 or else Position.Node.Next = Before.Node
1810 pragma Assert (Container.Length >= 2);
1812 if Container.Busy > 0 then
1813 raise Program_Error with
1814 "attempt to tamper with cursors (list is busy)";
1817 if Before.Node = null then
1818 pragma Assert (Position.Node /= Container.Last);
1820 if Position.Node = Container.First then
1821 Container.First := Position.Node.Next;
1822 Container.First.Prev := null;
1824 Position.Node.Prev.Next := Position.Node.Next;
1825 Position.Node.Next.Prev := Position.Node.Prev;
1828 Container.Last.Next := Position.Node;
1829 Position.Node.Prev := Container.Last;
1831 Container.Last := Position.Node;
1832 Container.Last.Next := null;
1837 if Before.Node = Container.First then
1838 pragma Assert (Position.Node /= Container.First);
1840 if Position.Node = Container.Last then
1841 Container.Last := Position.Node.Prev;
1842 Container.Last.Next := null;
1844 Position.Node.Prev.Next := Position.Node.Next;
1845 Position.Node.Next.Prev := Position.Node.Prev;
1848 Container.First.Prev := Position.Node;
1849 Position.Node.Next := Container.First;
1851 Container.First := Position.Node;
1852 Container.First.Prev := null;
1857 if Position.Node = Container.First then
1858 Container.First := Position.Node.Next;
1859 Container.First.Prev := null;
1861 elsif Position.Node = Container.Last then
1862 Container.Last := Position.Node.Prev;
1863 Container.Last.Next := null;
1866 Position.Node.Prev.Next := Position.Node.Next;
1867 Position.Node.Next.Prev := Position.Node.Prev;
1870 Before.Node.Prev.Next := Position.Node;
1871 Position.Node.Prev := Before.Node.Prev;
1873 Before.Node.Prev := Position.Node;
1874 Position.Node.Next := Before.Node;
1876 pragma Assert (Container.First.Prev = null);
1877 pragma Assert (Container.Last.Next = null);
1881 (Target : in out List;
1883 Source : in out List;
1884 Position : in out Cursor)
1887 if Target'Address = Source'Address then
1888 Splice (Target, Before, Position);
1892 if Before.Container /= null then
1893 if Before.Container /= Target'Unrestricted_Access then
1894 raise Program_Error with
1895 "Before cursor designates wrong container";
1897 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1901 if Position.Node = null then
1902 raise Constraint_Error with "Position cursor has no element";
1904 elsif Position.Container /= Source'Unrestricted_Access then
1905 raise Program_Error with
1906 "Position cursor designates wrong container";
1909 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1911 if Target.Length = Count_Type'Last then
1912 raise Constraint_Error with "Target is full";
1914 elsif Target.Busy > 0 then
1915 raise Program_Error with
1916 "attempt to tamper with cursors of Target (list is busy)";
1918 elsif Source.Busy > 0 then
1919 raise Program_Error with
1920 "attempt to tamper with cursors of Source (list is busy)";
1923 Splice_Internal (Target, Before.Node, Source, Position.Node);
1924 Position.Container := Target'Unchecked_Access;
1929 ---------------------
1930 -- Splice_Internal --
1931 ---------------------
1933 procedure Splice_Internal
1934 (Target : in out List;
1935 Before : Node_Access;
1936 Source : in out List)
1939 -- This implements the corresponding Splice operation, after the
1940 -- parameters have been vetted, and corner-cases disposed of.
1942 pragma Assert (Target'Address /= Source'Address);
1943 pragma Assert (Source.Length > 0);
1944 pragma Assert (Source.First /= null);
1945 pragma Assert (Source.First.Prev = null);
1946 pragma Assert (Source.Last /= null);
1947 pragma Assert (Source.Last.Next = null);
1948 pragma Assert (Target.Length <= Count_Type'Last - Source.Length);
1950 if Target.Length = 0 then
1951 pragma Assert (Target.First = null);
1952 pragma Assert (Target.Last = null);
1953 pragma Assert (Before = null);
1955 Target.First := Source.First;
1956 Target.Last := Source.Last;
1958 elsif Before = null then
1959 pragma Assert (Target.Last.Next = null);
1961 Target.Last.Next := Source.First;
1962 Source.First.Prev := Target.Last;
1964 Target.Last := Source.Last;
1966 elsif Before = Target.First then
1967 pragma Assert (Target.First.Prev = null);
1969 Source.Last.Next := Target.First;
1970 Target.First.Prev := Source.Last;
1972 Target.First := Source.First;
1975 pragma Assert (Target.Length >= 2);
1977 Before.Prev.Next := Source.First;
1978 Source.First.Prev := Before.Prev;
1980 Before.Prev := Source.Last;
1981 Source.Last.Next := Before;
1984 Source.First := null;
1985 Source.Last := null;
1987 Target.Length := Target.Length + Source.Length;
1989 end Splice_Internal;
1991 procedure Splice_Internal
1992 (Target : in out List;
1993 Before : Node_Access; -- node of Target
1994 Source : in out List;
1995 Position : Node_Access) -- node of Source
1998 -- This implements the corresponding Splice operation, after the
1999 -- parameters have been vetted.
2001 pragma Assert (Target'Address /= Source'Address);
2002 pragma Assert (Target.Length < Count_Type'Last);
2003 pragma Assert (Source.Length > 0);
2004 pragma Assert (Source.First /= null);
2005 pragma Assert (Source.First.Prev = null);
2006 pragma Assert (Source.Last /= null);
2007 pragma Assert (Source.Last.Next = null);
2008 pragma Assert (Position /= null);
2010 if Position = Source.First then
2011 Source.First := Position.Next;
2013 if Position = Source.Last then
2014 pragma Assert (Source.First = null);
2015 pragma Assert (Source.Length = 1);
2016 Source.Last := null;
2019 Source.First.Prev := null;
2022 elsif Position = Source.Last then
2023 pragma Assert (Source.Length >= 2);
2024 Source.Last := Position.Prev;
2025 Source.Last.Next := null;
2028 pragma Assert (Source.Length >= 3);
2029 Position.Prev.Next := Position.Next;
2030 Position.Next.Prev := Position.Prev;
2033 if Target.Length = 0 then
2034 pragma Assert (Target.First = null);
2035 pragma Assert (Target.Last = null);
2036 pragma Assert (Before = null);
2038 Target.First := Position;
2039 Target.Last := Position;
2041 Target.First.Prev := null;
2042 Target.Last.Next := null;
2044 elsif Before = null then
2045 pragma Assert (Target.Last.Next = null);
2046 Target.Last.Next := Position;
2047 Position.Prev := Target.Last;
2049 Target.Last := Position;
2050 Target.Last.Next := null;
2052 elsif Before = Target.First then
2053 pragma Assert (Target.First.Prev = null);
2054 Target.First.Prev := Position;
2055 Position.Next := Target.First;
2057 Target.First := Position;
2058 Target.First.Prev := null;
2061 pragma Assert (Target.Length >= 2);
2062 Before.Prev.Next := Position;
2063 Position.Prev := Before.Prev;
2065 Before.Prev := Position;
2066 Position.Next := Before;
2069 Target.Length := Target.Length + 1;
2070 Source.Length := Source.Length - 1;
2071 end Splice_Internal;
2078 (Container : in out List;
2082 if I.Node = null then
2083 raise Constraint_Error with "I cursor has no element";
2086 if J.Node = null then
2087 raise Constraint_Error with "J cursor has no element";
2090 if I.Container /= Container'Unchecked_Access then
2091 raise Program_Error with "I cursor designates wrong container";
2094 if J.Container /= Container'Unchecked_Access then
2095 raise Program_Error with "J cursor designates wrong container";
2098 if I.Node = J.Node then
2102 if Container.Lock > 0 then
2103 raise Program_Error with
2104 "attempt to tamper with elements (list is locked)";
2107 pragma Assert (Vet (I), "bad I cursor in Swap");
2108 pragma Assert (Vet (J), "bad J cursor in Swap");
2111 EI : Element_Type renames I.Node.Element;
2112 EJ : Element_Type renames J.Node.Element;
2114 EI_Copy : constant Element_Type := EI;
2126 procedure Swap_Links
2127 (Container : in out List;
2131 if I.Node = null then
2132 raise Constraint_Error with "I cursor has no element";
2135 if J.Node = null then
2136 raise Constraint_Error with "J cursor has no element";
2139 if I.Container /= Container'Unrestricted_Access then
2140 raise Program_Error with "I cursor designates wrong container";
2143 if J.Container /= Container'Unrestricted_Access then
2144 raise Program_Error with "J cursor designates wrong container";
2147 if I.Node = J.Node then
2151 if Container.Busy > 0 then
2152 raise Program_Error with
2153 "attempt to tamper with cursors (list is busy)";
2156 pragma Assert (Vet (I), "bad I cursor in Swap_Links");
2157 pragma Assert (Vet (J), "bad J cursor in Swap_Links");
2160 I_Next : constant Cursor := Next (I);
2164 Splice (Container, Before => I, Position => J);
2168 J_Next : constant Cursor := Next (J);
2172 Splice (Container, Before => J, Position => I);
2175 pragma Assert (Container.Length >= 3);
2177 Splice (Container, Before => I_Next, Position => J);
2178 Splice (Container, Before => J_Next, Position => I);
2185 --------------------
2186 -- Update_Element --
2187 --------------------
2189 procedure Update_Element
2190 (Container : in out List;
2192 Process : not null access procedure (Element : in out Element_Type))
2195 if Position.Node = null then
2196 raise Constraint_Error with "Position cursor has no element";
2198 elsif Position.Container /= Container'Unchecked_Access then
2199 raise Program_Error with
2200 "Position cursor designates wrong container";
2203 pragma Assert (Vet (Position), "bad cursor in Update_Element");
2206 B : Natural renames Container.Busy;
2207 L : Natural renames Container.Lock;
2214 Process (Position.Node.Element);
2232 function Vet (Position : Cursor) return Boolean is
2234 if Position.Node = null then
2235 return Position.Container = null;
2238 if Position.Container = null then
2242 -- An invariant of a node is that its Previous and Next components can
2243 -- be null, or designate a different node. Operation Free sets the
2244 -- access value components of the node to designate the node itself
2245 -- before actually deallocating the node, thus deliberately violating
2246 -- the node invariant. This gives us a simple way to detect a dangling
2247 -- reference to a node.
2249 if Position.Node.Next = Position.Node then
2253 if Position.Node.Prev = Position.Node then
2257 -- In practice the tests above will detect most instances of a dangling
2258 -- reference. If we get here, it means that the invariants of the
2259 -- designated node are satisfied (they at least appear to be satisfied),
2260 -- so we perform some more tests, to determine whether invariants of the
2261 -- designated list are satisfied too.
2264 L : List renames Position.Container.all;
2267 if L.Length = 0 then
2271 if L.First = null then
2275 if L.Last = null then
2279 if L.First.Prev /= null then
2283 if L.Last.Next /= null then
2287 if Position.Node.Prev = null and then Position.Node /= L.First then
2292 (Position.Node.Prev /= null or else Position.Node = L.First);
2294 if Position.Node.Next = null and then Position.Node /= L.Last then
2299 (Position.Node.Next /= null
2300 or else Position.Node = L.Last);
2302 if L.Length = 1 then
2303 return L.First = L.Last;
2306 if L.First = L.Last then
2310 if L.First.Next = null then
2314 if L.Last.Prev = null then
2318 if L.First.Next.Prev /= L.First then
2322 if L.Last.Prev.Next /= L.Last then
2326 if L.Length = 2 then
2327 if L.First.Next /= L.Last then
2329 elsif L.Last.Prev /= L.First then
2336 if L.First.Next = L.Last then
2340 if L.Last.Prev = L.First then
2344 -- Eliminate earlier possibility
2346 if Position.Node = L.First then
2350 pragma Assert (Position.Node.Prev /= null);
2352 -- Eliminate earlier possibility
2354 if Position.Node = L.Last then
2358 pragma Assert (Position.Node.Next /= null);
2360 if Position.Node.Next.Prev /= Position.Node then
2364 if Position.Node.Prev.Next /= Position.Node then
2368 if L.Length = 3 then
2369 if L.First.Next /= Position.Node then
2371 elsif L.Last.Prev /= Position.Node then
2385 (Stream : not null access Root_Stream_Type'Class;
2391 Count_Type'Base'Write
(Stream
, Item
.Length
);
2394 while Node
/= null loop
2395 Element_Type
'Write (Stream
, Node
.Element
);
2401 (Stream
: not null access Root_Stream_Type
'Class;
2405 raise Program_Error
with "attempt to stream list cursor";
2409 (Stream
: not null access Root_Stream_Type
'Class;
2410 Item
: Reference_Type
)
2413 raise Program_Error
with "attempt to stream reference";
2417 (Stream
: not null access Root_Stream_Type
'Class;
2418 Item
: Constant_Reference_Type
)
2421 raise Program_Error
with "attempt to stream reference";
2424 end Ada
.Containers
.Doubly_Linked_Lists
;