1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS --
9 -- Copyright (C) 2004-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/>. --
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
.Indefinite_Doubly_Linked_Lists
is
36 pragma Annotate
(CodePeer
, Skip_Analysis
);
39 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
41 -----------------------
42 -- Local Subprograms --
43 -----------------------
45 procedure Free
(X
: in out Node_Access
);
47 procedure Insert_Internal
48 (Container
: in out List
;
50 New_Node
: Node_Access
);
52 procedure Splice_Internal
53 (Target
: in out List
;
55 Source
: in out List
);
57 procedure Splice_Internal
58 (Target
: in out List
;
61 Position
: Node_Access
);
63 function Vet
(Position
: Cursor
) return Boolean;
64 -- Checks invariants of the cursor and its designated container, as a
65 -- simple way of detecting dangling references (see operation Free for a
66 -- description of the detection mechanism), returning True if all checks
67 -- pass. Invocations of Vet are used here as the argument of pragma Assert,
68 -- so the checks are performed only when assertions are enabled.
74 function "=" (Left
, Right
: List
) return Boolean is
75 BL
: Natural renames Left
'Unrestricted_Access.Busy
;
76 LL
: Natural renames Left
'Unrestricted_Access.Lock
;
78 BR
: Natural renames Right
'Unrestricted_Access.Busy
;
79 LR
: Natural renames Right
'Unrestricted_Access.Lock
;
86 if Left
'Address = Right
'Address then
90 if Left
.Length
/= Right
.Length
then
94 -- Per AI05-0022, the container implementation is required to detect
95 -- element tampering by a generic actual subprogram.
106 for J
in 1 .. Left
.Length
loop
107 if L
.Element
.all /= R
.Element
.all then
139 procedure Adjust
(Container
: in out List
) is
140 Src
: Node_Access
:= Container
.First
;
145 pragma Assert
(Container
.Last
= null);
146 pragma Assert
(Container
.Length
= 0);
147 pragma Assert
(Container
.Busy
= 0);
148 pragma Assert
(Container
.Lock
= 0);
152 pragma Assert
(Container
.First
.Prev
= null);
153 pragma Assert
(Container
.Last
.Next
= null);
154 pragma Assert
(Container
.Length
> 0);
156 Container
.First
:= null;
157 Container
.Last
:= null;
158 Container
.Length
:= 0;
163 Element
: Element_Access
:= new Element_Type
'(Src.Element.all);
165 Dst := new Node_Type'(Element
, null, null);
172 Container
.First
:= Dst
;
173 Container
.Last
:= Dst
;
174 Container
.Length
:= 1;
177 while Src
/= null loop
179 Element
: Element_Access
:= new Element_Type
'(Src.Element.all);
181 Dst := new Node_Type'(Element
, null, Prev
=> Container
.Last
);
188 Container
.Last
.Next
:= Dst
;
189 Container
.Last
:= Dst
;
190 Container
.Length
:= Container
.Length
+ 1;
196 procedure Adjust
(Control
: in out Reference_Control_Type
) is
198 if Control
.Container
/= null then
200 C
: List
renames Control
.Container
.all;
201 B
: Natural renames C
.Busy
;
202 L
: Natural renames C
.Lock
;
215 (Container
: in out List
;
216 New_Item
: Element_Type
;
217 Count
: Count_Type
:= 1)
220 Insert
(Container
, No_Element
, New_Item
, Count
);
227 procedure Assign
(Target
: in out List
; Source
: List
) is
231 if Target
'Address = Source
'Address then
237 Node
:= Source
.First
;
238 while Node
/= null loop
239 Target
.Append
(Node
.Element
.all);
249 procedure Clear
(Container
: in out List
) is
251 pragma Warnings
(Off
, X
);
254 if Container
.Length
= 0 then
255 pragma Assert
(Container
.First
= null);
256 pragma Assert
(Container
.Last
= null);
257 pragma Assert
(Container
.Busy
= 0);
258 pragma Assert
(Container
.Lock
= 0);
262 pragma Assert
(Container
.First
.Prev
= null);
263 pragma Assert
(Container
.Last
.Next
= null);
265 if Container
.Busy
> 0 then
266 raise Program_Error
with
267 "attempt to tamper with cursors (list is busy)";
270 while Container
.Length
> 1 loop
271 X
:= Container
.First
;
272 pragma Assert
(X
.Next
.Prev
= Container
.First
);
274 Container
.First
:= X
.Next
;
275 Container
.First
.Prev
:= null;
277 Container
.Length
:= Container
.Length
- 1;
282 X
:= Container
.First
;
283 pragma Assert
(X
= Container
.Last
);
285 Container
.First
:= null;
286 Container
.Last
:= null;
287 Container
.Length
:= 0;
292 ------------------------
293 -- Constant_Reference --
294 ------------------------
296 function Constant_Reference
297 (Container
: aliased List
;
298 Position
: Cursor
) return Constant_Reference_Type
301 if Position
.Container
= null then
302 raise Constraint_Error
with "Position cursor has no element";
304 elsif Position
.Container
/= Container
'Unrestricted_Access then
305 raise Program_Error
with
306 "Position cursor designates wrong container";
307 elsif Position
.Node
.Element
= null then
308 raise Program_Error
with "Node has no element";
311 pragma Assert
(Vet
(Position
), "bad cursor in Constant_Reference");
314 C
: List
renames Position
.Container
.all;
315 B
: Natural renames C
.Busy
;
316 L
: Natural renames C
.Lock
;
318 return R
: constant Constant_Reference_Type
:=
319 (Element
=> Position
.Node
.Element
.all'Access,
320 Control
=> (Controlled
with Position
.Container
))
327 end Constant_Reference
;
335 Item
: Element_Type
) return Boolean
338 return Find
(Container
, Item
) /= No_Element
;
345 function Copy
(Source
: List
) return List
is
347 return Target
: List
do
348 Target
.Assign
(Source
);
357 (Container
: in out List
;
358 Position
: in out Cursor
;
359 Count
: Count_Type
:= 1)
364 if Position
.Node
= null then
365 raise Constraint_Error
with
366 "Position cursor has no element";
369 if Position
.Node
.Element
= null then
370 raise Program_Error
with
371 "Position cursor has no element";
374 if Position
.Container
/= Container
'Unrestricted_Access then
375 raise Program_Error
with
376 "Position cursor designates wrong container";
379 pragma Assert
(Vet
(Position
), "bad cursor in Delete");
381 if Position
.Node
= Container
.First
then
382 Delete_First
(Container
, Count
);
383 Position
:= No_Element
; -- Post-York behavior
388 Position
:= No_Element
; -- Post-York behavior
392 if Container
.Busy
> 0 then
393 raise Program_Error
with
394 "attempt to tamper with cursors (list is busy)";
397 for Index
in 1 .. Count
loop
399 Container
.Length
:= Container
.Length
- 1;
401 if X
= Container
.Last
then
402 Position
:= No_Element
;
404 Container
.Last
:= X
.Prev
;
405 Container
.Last
.Next
:= null;
411 Position
.Node
:= X
.Next
;
413 X
.Next
.Prev
:= X
.Prev
;
414 X
.Prev
.Next
:= X
.Next
;
419 -- Fix this junk comment ???
421 Position
:= No_Element
; -- Post-York behavior
428 procedure Delete_First
429 (Container
: in out List
;
430 Count
: Count_Type
:= 1)
435 if Count
>= Container
.Length
then
442 elsif Container
.Busy
> 0 then
443 raise Program_Error
with
444 "attempt to tamper with cursors (list is busy)";
447 for J
in 1 .. Count
loop
448 X
:= Container
.First
;
449 pragma Assert
(X
.Next
.Prev
= Container
.First
);
451 Container
.First
:= X
.Next
;
452 Container
.First
.Prev
:= null;
454 Container
.Length
:= Container
.Length
- 1;
465 procedure Delete_Last
466 (Container
: in out List
;
467 Count
: Count_Type
:= 1)
472 if Count
>= Container
.Length
then
479 elsif Container
.Busy
> 0 then
480 raise Program_Error
with
481 "attempt to tamper with cursors (list is busy)";
484 for J
in 1 .. Count
loop
486 pragma Assert
(X
.Prev
.Next
= Container
.Last
);
488 Container
.Last
:= X
.Prev
;
489 Container
.Last
.Next
:= null;
491 Container
.Length
:= Container
.Length
- 1;
502 function Element
(Position
: Cursor
) return Element_Type
is
504 if Position
.Node
= null then
505 raise Constraint_Error
with
506 "Position cursor has no element";
508 elsif Position
.Node
.Element
= null then
509 raise Program_Error
with
510 "Position cursor has no element";
513 pragma Assert
(Vet
(Position
), "bad cursor in Element");
515 return Position
.Node
.Element
.all;
523 procedure Finalize
(Object
: in out Iterator
) is
525 if Object
.Container
/= null then
527 B
: Natural renames Object
.Container
.all.Busy
;
534 procedure Finalize
(Control
: in out Reference_Control_Type
) is
536 if Control
.Container
/= null then
538 C
: List
renames Control
.Container
.all;
539 B
: Natural renames C
.Busy
;
540 L
: Natural renames C
.Lock
;
546 Control
.Container
:= null;
557 Position
: Cursor
:= No_Element
) return Cursor
559 Node
: Node_Access
:= Position
.Node
;
563 Node
:= Container
.First
;
566 if Node
.Element
= null then
569 elsif Position
.Container
/= Container
'Unrestricted_Access then
570 raise Program_Error
with
571 "Position cursor designates wrong container";
574 pragma Assert
(Vet
(Position
), "bad cursor in Find");
578 -- Per AI05-0022, the container implementation is required to detect
579 -- element tampering by a generic actual subprogram.
582 B
: Natural renames Container
'Unrestricted_Access.Busy
;
583 L
: Natural renames Container
'Unrestricted_Access.Lock
;
585 Result
: Node_Access
;
592 while Node
/= null loop
593 if Node
.Element
.all = Item
then
604 if Result
= null then
607 return Cursor
'(Container'Unrestricted_Access, Result);
623 function First (Container : List) return Cursor is
625 if Container.First = null then
628 return Cursor'(Container
'Unrestricted_Access, Container
.First
);
632 function First
(Object
: Iterator
) return Cursor
is
634 -- The value of the iterator object's Node component influences the
635 -- behavior of the First (and Last) selector function.
637 -- When the Node component is null, this means the iterator object was
638 -- constructed without a start expression, in which case the (forward)
639 -- iteration starts from the (logical) beginning of the entire sequence
640 -- of items (corresponding to Container.First, for a forward iterator).
642 -- Otherwise, this is iteration over a partial sequence of items. When
643 -- the Node component is non-null, the iterator object was constructed
644 -- with a start expression, that specifies the position from which the
645 -- (forward) partial iteration begins.
647 if Object
.Node
= null then
648 return Indefinite_Doubly_Linked_Lists
.First
(Object
.Container
.all);
650 return Cursor
'(Object.Container, Object.Node);
658 function First_Element (Container : List) return Element_Type is
660 if Container.First = null then
661 raise Constraint_Error with "list is empty";
663 return Container.First.Element.all;
671 procedure Free (X : in out Node_Access) is
672 procedure Deallocate is
673 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
676 -- While a node is in use, as an active link in a list, its Previous and
677 -- Next components must be null, or designate a different node; this is
678 -- a node invariant. For this indefinite list, there is an additional
679 -- invariant: that the element access value be non-null. Before actually
680 -- deallocating the node, we set the node access value components of the
681 -- node to point to the node itself, and set the element access value to
682 -- null (by deallocating the node's element), thus falsifying the node
683 -- invariant. Subprogram Vet inspects the value of the node components
684 -- when interrogating the node, in order to detect whether the cursor's
685 -- node access value is dangling.
687 -- Note that we have no guarantee that the storage for the node isn't
688 -- modified when it is deallocated, but there are other tests that Vet
689 -- does if node invariants appear to be satisifed. However, in practice
690 -- this simple test works well enough, detecting dangling references
691 -- immediately, without needing further interrogation.
708 ---------------------
709 -- Generic_Sorting --
710 ---------------------
712 package body Generic_Sorting is
718 function Is_Sorted (Container : List) return Boolean is
719 B : Natural renames Container'Unrestricted_Access.Busy;
720 L : Natural renames Container'Unrestricted_Access.Lock;
726 -- Per AI05-0022, the container implementation is required to detect
727 -- element tampering by a generic actual subprogram.
732 Node := Container.First;
734 for J in 2 .. Container.Length loop
735 if Node.Next.Element.all < Node.Element.all then
761 (Target : in out List;
762 Source : in out List)
765 -- The semantics of Merge changed slightly per AI05-0021. It was
766 -- originally the case that if Target and Source denoted the same
767 -- container object, then the GNAT implementation of Merge did
768 -- nothing. However, it was argued that RM05 did not precisely
769 -- specify the semantics for this corner case. The decision of the
770 -- ARG was that if Target and Source denote the same non-empty
771 -- container object, then Program_Error is raised.
773 if Source.Is_Empty then
776 elsif Target'Address = Source'Address then
777 raise Program_Error with
778 "Target and Source denote same non-empty container";
780 elsif Target.Length > Count_Type'Last - Source.Length then
781 raise Constraint_Error with "new length exceeds maximum";
783 elsif Target.Busy > 0 then
784 raise Program_Error with
785 "attempt to tamper with cursors of Target (list is busy)";
787 elsif Source.Busy > 0 then
788 raise Program_Error with
789 "attempt to tamper with cursors of Source (list is busy)";
793 TB : Natural renames Target.Busy;
794 TL : Natural renames Target.Lock;
796 SB : Natural renames Source.Busy;
797 SL : Natural renames Source.Lock;
799 LI, RI, RJ : Node_Access;
810 while RI /= null loop
811 pragma Assert (RI.Next = null
812 or else not (RI.Next.Element.all <
816 Splice_Internal (Target, null, Source);
820 pragma Assert (LI.Next = null
821 or else not (LI.Next.Element.all <
824 if RI.Element.all < LI.Element.all then
827 Splice_Internal (Target, LI, Source, RJ);
856 procedure Sort (Container : in out List) is
857 procedure Partition (Pivot : Node_Access; Back : Node_Access);
860 procedure Sort (Front, Back : Node_Access);
861 -- Comment??? Confusing name??? change name???
867 procedure Partition (Pivot : Node_Access; Back : Node_Access) is
872 while Node /= Back loop
873 if Node.Element.all < Pivot.Element.all then
875 Prev : constant Node_Access := Node.Prev;
876 Next : constant Node_Access := Node.Next;
882 Container.Last := Prev;
888 Node.Prev := Pivot.Prev;
892 if Node.Prev = null then
893 Container.First := Node;
895 Node.Prev.Next := Node;
911 procedure Sort (Front, Back : Node_Access) is
912 Pivot : constant Node_Access :=
913 (if Front = null then Container.First else Front.Next);
915 if Pivot /= Back then
916 Partition (Pivot, Back);
922 -- Start of processing for Sort
925 if Container.Length <= 1 then
929 pragma Assert (Container.First.Prev = null);
930 pragma Assert (Container.Last.Next = null);
932 if Container.Busy > 0 then
933 raise Program_Error with
934 "attempt to tamper with cursors (list is busy)";
937 -- Per AI05-0022, the container implementation is required to detect
938 -- element tampering by a generic actual subprogram.
941 B : Natural renames Container.Busy;
942 L : Natural renames Container.Lock;
948 Sort (Front => null, Back => null);
961 pragma Assert (Container.First.Prev = null);
962 pragma Assert (Container.Last.Next = null);
971 function Has_Element (Position : Cursor) return Boolean is
973 pragma Assert (Vet (Position), "bad cursor in Has_Element");
974 return Position.Node /= null;
982 (Container : in out List;
984 New_Item : Element_Type;
985 Position : out Cursor;
986 Count : Count_Type := 1)
988 First_Node : Node_Access;
989 New_Node : Node_Access;
992 if Before.Container /= null then
993 if Before.Container /= Container'Unrestricted_Access then
994 raise Program_Error with
995 "attempt to tamper with cursors (list is busy)";
997 elsif Before.Node = null or else Before.Node.Element = null then
998 raise Program_Error with
999 "Before cursor has no element";
1002 pragma Assert (Vet (Before), "bad cursor in Insert");
1011 if Container.Length > Count_Type'Last - Count then
1012 raise Constraint_Error with "new length exceeds maximum";
1015 if Container.Busy > 0 then
1016 raise Program_Error with
1017 "attempt to tamper with cursors (list is busy)";
1021 -- The element allocator may need an accessibility check in the case
1022 -- the actual type is class-wide or has access discriminants (see
1023 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
1024 -- allocator in the loop below, because the one in this block would
1025 -- have failed already.
1027 pragma Unsuppress (Accessibility_Check);
1029 Element : Element_Access := new Element_Type'(New_Item
);
1032 New_Node
:= new Node_Type
'(Element, null, null);
1033 First_Node := New_Node;
1041 Insert_Internal (Container, Before.Node, New_Node);
1043 for J in 2 .. Count loop
1045 Element : Element_Access := new Element_Type'(New_Item
);
1047 New_Node
:= new Node_Type
'(Element, null, null);
1054 Insert_Internal (Container, Before.Node, New_Node);
1057 Position := Cursor'(Container
'Unchecked_Access, First_Node
);
1061 (Container
: in out List
;
1063 New_Item
: Element_Type
;
1064 Count
: Count_Type
:= 1)
1067 pragma Unreferenced
(Position
);
1069 Insert
(Container
, Before
, New_Item
, Position
, Count
);
1072 ---------------------
1073 -- Insert_Internal --
1074 ---------------------
1076 procedure Insert_Internal
1077 (Container
: in out List
;
1078 Before
: Node_Access
;
1079 New_Node
: Node_Access
)
1082 if Container
.Length
= 0 then
1083 pragma Assert
(Before
= null);
1084 pragma Assert
(Container
.First
= null);
1085 pragma Assert
(Container
.Last
= null);
1087 Container
.First
:= New_Node
;
1088 Container
.Last
:= New_Node
;
1090 elsif Before
= null then
1091 pragma Assert
(Container
.Last
.Next
= null);
1093 Container
.Last
.Next
:= New_Node
;
1094 New_Node
.Prev
:= Container
.Last
;
1096 Container
.Last
:= New_Node
;
1098 elsif Before
= Container
.First
then
1099 pragma Assert
(Container
.First
.Prev
= null);
1101 Container
.First
.Prev
:= New_Node
;
1102 New_Node
.Next
:= Container
.First
;
1104 Container
.First
:= New_Node
;
1107 pragma Assert
(Container
.First
.Prev
= null);
1108 pragma Assert
(Container
.Last
.Next
= null);
1110 New_Node
.Next
:= Before
;
1111 New_Node
.Prev
:= Before
.Prev
;
1113 Before
.Prev
.Next
:= New_Node
;
1114 Before
.Prev
:= New_Node
;
1117 Container
.Length
:= Container
.Length
+ 1;
1118 end Insert_Internal
;
1124 function Is_Empty
(Container
: List
) return Boolean is
1126 return Container
.Length
= 0;
1135 Process
: not null access procedure (Position
: Cursor
))
1137 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
1138 Node
: Node_Access
:= Container
.First
;
1144 while Node
/= null loop
1145 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1159 return List_Iterator_Interfaces.Reversible_Iterator'class
1161 B : Natural renames Container'Unrestricted_Access.all.Busy;
1164 -- The value of the Node component influences the behavior of the First
1165 -- and Last selector functions of the iterator object. When the Node
1166 -- component is null (as is the case here), this means the iterator
1167 -- object was constructed without a start expression. This is a
1168 -- complete iterator, meaning that the iteration starts from the
1169 -- (logical) beginning of the sequence of items.
1171 -- Note: For a forward iterator, Container.First is the beginning, and
1172 -- for a reverse iterator, Container.Last is the beginning.
1174 return It : constant Iterator :=
1175 Iterator'(Limited_Controlled
with
1176 Container
=> Container
'Unrestricted_Access,
1186 return List_Iterator_Interfaces
.Reversible_Iterator
'Class
1188 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
1191 -- It was formerly the case that when Start = No_Element, the partial
1192 -- iterator was defined to behave the same as for a complete iterator,
1193 -- and iterate over the entire sequence of items. However, those
1194 -- semantics were unintuitive and arguably error-prone (it is too easy
1195 -- to accidentally create an endless loop), and so they were changed,
1196 -- per the ARG meeting in Denver on 2011/11. However, there was no
1197 -- consensus about what positive meaning this corner case should have,
1198 -- and so it was decided to simply raise an exception. This does imply,
1199 -- however, that it is not possible to use a partial iterator to specify
1200 -- an empty sequence of items.
1202 if Start
= No_Element
then
1203 raise Constraint_Error
with
1204 "Start position for iterator equals No_Element";
1206 elsif Start
.Container
/= Container
'Unrestricted_Access then
1207 raise Program_Error
with
1208 "Start cursor of Iterate designates wrong list";
1211 pragma Assert
(Vet
(Start
), "Start cursor of Iterate is bad");
1213 -- The value of the Node component influences the behavior of the
1214 -- First and Last selector functions of the iterator object. When
1215 -- the Node component is non-null (as is the case here), it means
1216 -- that this is a partial iteration, over a subset of the complete
1217 -- sequence of items. The iterator object was constructed with
1218 -- a start expression, indicating the position from which the
1219 -- iteration begins. Note that the start position has the same value
1220 -- irrespective of whether this is a forward or reverse iteration.
1222 return It
: constant Iterator
:=
1223 Iterator
'(Limited_Controlled with
1224 Container => Container'Unrestricted_Access,
1236 function Last (Container : List) return Cursor is
1238 if Container.Last = null then
1241 return Cursor'(Container
'Unrestricted_Access, Container
.Last
);
1245 function Last
(Object
: Iterator
) return Cursor
is
1247 -- The value of the iterator object's Node component influences the
1248 -- behavior of the Last (and First) selector function.
1250 -- When the Node component is null, this means the iterator object was
1251 -- constructed without a start expression, in which case the (reverse)
1252 -- iteration starts from the (logical) beginning of the entire sequence
1253 -- (corresponding to Container.Last, for a reverse iterator).
1255 -- Otherwise, this is iteration over a partial sequence of items. When
1256 -- the Node component is non-null, the iterator object was constructed
1257 -- with a start expression, that specifies the position from which the
1258 -- (reverse) partial iteration begins.
1260 if Object
.Node
= null then
1261 return Indefinite_Doubly_Linked_Lists
.Last
(Object
.Container
.all);
1263 return Cursor
'(Object.Container, Object.Node);
1271 function Last_Element (Container : List) return Element_Type is
1273 if Container.Last = null then
1274 raise Constraint_Error with "list is empty";
1276 return Container.Last.Element.all;
1284 function Length (Container : List) return Count_Type is
1286 return Container.Length;
1293 procedure Move (Target : in out List; Source : in out List) is
1295 if Target'Address = Source'Address then
1298 elsif Source.Busy > 0 then
1299 raise Program_Error with
1300 "attempt to tamper with cursors of Source (list is busy)";
1305 Target.First := Source.First;
1306 Source.First := null;
1308 Target.Last := Source.Last;
1309 Source.Last := null;
1311 Target.Length := Source.Length;
1320 procedure Next (Position : in out Cursor) is
1322 Position := Next (Position);
1325 function Next (Position : Cursor) return Cursor is
1327 if Position.Node = null then
1331 pragma Assert (Vet (Position), "bad cursor in Next");
1334 Next_Node : constant Node_Access := Position.Node.Next;
1336 if Next_Node = null then
1339 return Cursor'(Position
.Container
, Next_Node
);
1345 function Next
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
1347 if Position
.Container
= null then
1349 elsif Position
.Container
/= Object
.Container
then
1350 raise Program_Error
with
1351 "Position cursor of Next designates wrong list";
1353 return Next
(Position
);
1362 (Container
: in out List
;
1363 New_Item
: Element_Type
;
1364 Count
: Count_Type
:= 1)
1367 Insert
(Container
, First
(Container
), New_Item
, Count
);
1374 procedure Previous
(Position
: in out Cursor
) is
1376 Position
:= Previous
(Position
);
1379 function Previous
(Position
: Cursor
) return Cursor
is
1381 if Position
.Node
= null then
1385 pragma Assert
(Vet
(Position
), "bad cursor in Previous");
1388 Prev_Node
: constant Node_Access
:= Position
.Node
.Prev
;
1390 if Prev_Node
= null then
1393 return Cursor
'(Position.Container, Prev_Node);
1399 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1401 if Position.Container = null then
1403 elsif Position.Container /= Object.Container then
1404 raise Program_Error with
1405 "Position cursor of Previous designates wrong list";
1407 return Previous (Position);
1415 procedure Query_Element
1417 Process : not null access procedure (Element : Element_Type))
1420 if Position.Node = null then
1421 raise Constraint_Error with
1422 "Position cursor has no element";
1424 elsif Position.Node.Element = null then
1425 raise Program_Error with
1426 "Position cursor has no element";
1429 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1432 C : List renames Position.Container.all'Unrestricted_Access.all;
1433 B : Natural renames C.Busy;
1434 L : Natural renames C.Lock;
1441 Process (Position.Node.Element.all);
1460 (Stream : not null access Root_Stream_Type'Class;
1463 N : Count_Type'Base;
1469 Count_Type'Base'Read
(Stream
, N
);
1476 Element
: Element_Access
:=
1477 new Element_Type
'(Element_Type'Input (Stream));
1479 Dst := new Node_Type'(Element
, null, null);
1490 while Item
.Length
< N
loop
1492 Element
: Element_Access
:=
1493 new Element_Type
'(Element_Type'Input (Stream));
1495 Dst := new Node_Type'(Element
, Next
=> null, Prev
=> Item
.Last
);
1502 Item
.Last
.Next
:= Dst
;
1504 Item
.Length
:= Item
.Length
+ 1;
1509 (Stream
: not null access Root_Stream_Type
'Class;
1513 raise Program_Error
with "attempt to stream list cursor";
1517 (Stream
: not null access Root_Stream_Type
'Class;
1518 Item
: out Reference_Type
)
1521 raise Program_Error
with "attempt to stream reference";
1525 (Stream
: not null access Root_Stream_Type
'Class;
1526 Item
: out Constant_Reference_Type
)
1529 raise Program_Error
with "attempt to stream reference";
1537 (Container
: aliased in out List
;
1538 Position
: Cursor
) return Reference_Type
1541 if Position
.Container
= null then
1542 raise Constraint_Error
with "Position cursor has no element";
1544 elsif Position
.Container
/= Container
'Unrestricted_Access then
1545 raise Program_Error
with
1546 "Position cursor designates wrong container";
1548 elsif Position
.Node
.Element
= null then
1549 raise Program_Error
with "Node has no element";
1552 pragma Assert
(Vet
(Position
), "bad cursor in function Reference");
1555 C
: List
renames Position
.Container
.all;
1556 B
: Natural renames C
.Busy
;
1557 L
: Natural renames C
.Lock
;
1559 return R
: constant Reference_Type
:=
1560 (Element
=> Position
.Node
.Element
.all'Access,
1561 Control
=> (Controlled
with Position
.Container
))
1570 ---------------------
1571 -- Replace_Element --
1572 ---------------------
1574 procedure Replace_Element
1575 (Container
: in out List
;
1577 New_Item
: Element_Type
)
1580 if Position
.Container
= null then
1581 raise Constraint_Error
with "Position cursor has no element";
1583 elsif Position
.Container
/= Container
'Unchecked_Access then
1584 raise Program_Error
with
1585 "Position cursor designates wrong container";
1587 elsif Container
.Lock
> 0 then
1588 raise Program_Error
with
1589 "attempt to tamper with elements (list is locked)";
1591 elsif Position
.Node
.Element
= null then
1592 raise Program_Error
with
1593 "Position cursor has no element";
1596 pragma Assert
(Vet
(Position
), "bad cursor in Replace_Element");
1599 -- The element allocator may need an accessibility check in the
1600 -- case the actual type is class-wide or has access discriminants
1601 -- (see RM 4.8(10.1) and AI12-0035).
1603 pragma Unsuppress
(Accessibility_Check
);
1605 X
: Element_Access
:= Position
.Node
.Element
;
1608 Position
.Node
.Element
:= new Element_Type
'(New_Item);
1612 end Replace_Element;
1614 ----------------------
1615 -- Reverse_Elements --
1616 ----------------------
1618 procedure Reverse_Elements (Container : in out List) is
1619 I : Node_Access := Container.First;
1620 J : Node_Access := Container.Last;
1622 procedure Swap (L, R : Node_Access);
1628 procedure Swap (L, R : Node_Access) is
1629 LN : constant Node_Access := L.Next;
1630 LP : constant Node_Access := L.Prev;
1632 RN : constant Node_Access := R.Next;
1633 RP : constant Node_Access := R.Prev;
1648 pragma Assert (RP = L);
1662 -- Start of processing for Reverse_Elements
1665 if Container.Length <= 1 then
1669 pragma Assert (Container.First.Prev = null);
1670 pragma Assert (Container.Last.Next = null);
1672 if Container.Busy > 0 then
1673 raise Program_Error with
1674 "attempt to tamper with cursors (list is busy)";
1677 Container.First := J;
1678 Container.Last := I;
1680 Swap (L => I, R => J);
1688 Swap (L => J, R => I);
1697 pragma Assert (Container.First.Prev = null);
1698 pragma Assert (Container.Last.Next = null);
1699 end Reverse_Elements;
1705 function Reverse_Find
1707 Item : Element_Type;
1708 Position : Cursor := No_Element) return Cursor
1710 Node : Node_Access := Position.Node;
1714 Node := Container.Last;
1717 if Node.Element = null then
1718 raise Program_Error with "Position cursor has no element";
1720 elsif Position.Container /= Container'Unrestricted_Access then
1721 raise Program_Error with
1722 "Position cursor designates wrong container";
1725 pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1729 -- Per AI05-0022, the container implementation is required to detect
1730 -- element tampering by a generic actual subprogram.
1733 B : Natural renames Container'Unrestricted_Access.Busy;
1734 L : Natural renames Container'Unrestricted_Access.Lock;
1736 Result : Node_Access;
1743 while Node /= null loop
1744 if Node.Element.all = Item then
1755 if Result = null then
1758 return Cursor'(Container
'Unrestricted_Access, Result
);
1770 ---------------------
1771 -- Reverse_Iterate --
1772 ---------------------
1774 procedure Reverse_Iterate
1776 Process
: not null access procedure (Position
: Cursor
))
1778 C
: List
renames Container
'Unrestricted_Access.all;
1779 B
: Natural renames C
.Busy
;
1781 Node
: Node_Access
:= Container
.Last
;
1787 while Node
/= null loop
1788 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1798 end Reverse_Iterate;
1805 (Target : in out List;
1807 Source : in out List)
1810 if Before.Container /= null then
1811 if Before.Container /= Target'Unrestricted_Access then
1812 raise Program_Error with
1813 "Before cursor designates wrong container";
1815 elsif Before.Node = null or else Before.Node.Element = null then
1816 raise Program_Error with
1817 "Before cursor has no element";
1820 pragma Assert (Vet (Before), "bad cursor in Splice");
1824 if Target'Address = Source'Address or else Source.Length = 0 then
1827 elsif Target.Length > Count_Type'Last - Source.Length then
1828 raise Constraint_Error with "new length exceeds maximum";
1830 elsif Target.Busy > 0 then
1831 raise Program_Error with
1832 "attempt to tamper with cursors of Target (list is busy)";
1834 elsif Source.Busy > 0 then
1835 raise Program_Error with
1836 "attempt to tamper with cursors of Source (list is busy)";
1839 Splice_Internal (Target, Before.Node, Source);
1844 (Container : in out List;
1849 if Before.Container /= null then
1850 if Before.Container /= Container'Unchecked_Access then
1851 raise Program_Error with
1852 "Before cursor designates wrong container";
1854 elsif Before.Node = null or else Before.Node.Element = null then
1855 raise Program_Error with
1856 "Before cursor has no element";
1859 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1863 if Position.Node = null then
1864 raise Constraint_Error with "Position cursor has no element";
1867 if Position.Node.Element = null then
1868 raise Program_Error with "Position cursor has no element";
1871 if Position.Container /= Container'Unrestricted_Access then
1872 raise Program_Error with
1873 "Position cursor designates wrong container";
1876 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1878 if Position.Node = Before.Node
1879 or else Position.Node.Next = Before.Node
1884 pragma Assert (Container.Length >= 2);
1886 if Container.Busy > 0 then
1887 raise Program_Error with
1888 "attempt to tamper with cursors (list is busy)";
1891 if Before.Node = null then
1892 pragma Assert (Position.Node /= Container.Last);
1894 if Position.Node = Container.First then
1895 Container.First := Position.Node.Next;
1896 Container.First.Prev := null;
1898 Position.Node.Prev.Next := Position.Node.Next;
1899 Position.Node.Next.Prev := Position.Node.Prev;
1902 Container.Last.Next := Position.Node;
1903 Position.Node.Prev := Container.Last;
1905 Container.Last := Position.Node;
1906 Container.Last.Next := null;
1911 if Before.Node = Container.First then
1912 pragma Assert (Position.Node /= Container.First);
1914 if Position.Node = Container.Last then
1915 Container.Last := Position.Node.Prev;
1916 Container.Last.Next := null;
1918 Position.Node.Prev.Next := Position.Node.Next;
1919 Position.Node.Next.Prev := Position.Node.Prev;
1922 Container.First.Prev := Position.Node;
1923 Position.Node.Next := Container.First;
1925 Container.First := Position.Node;
1926 Container.First.Prev := null;
1931 if Position.Node = Container.First then
1932 Container.First := Position.Node.Next;
1933 Container.First.Prev := null;
1935 elsif Position.Node = Container.Last then
1936 Container.Last := Position.Node.Prev;
1937 Container.Last.Next := null;
1940 Position.Node.Prev.Next := Position.Node.Next;
1941 Position.Node.Next.Prev := Position.Node.Prev;
1944 Before.Node.Prev.Next := Position.Node;
1945 Position.Node.Prev := Before.Node.Prev;
1947 Before.Node.Prev := Position.Node;
1948 Position.Node.Next := Before.Node;
1950 pragma Assert (Container.First.Prev = null);
1951 pragma Assert (Container.Last.Next = null);
1955 (Target : in out List;
1957 Source : in out List;
1958 Position : in out Cursor)
1961 if Target'Address = Source'Address then
1962 Splice (Target, Before, Position);
1966 if Before.Container /= null then
1967 if Before.Container /= Target'Unrestricted_Access then
1968 raise Program_Error with
1969 "Before cursor designates wrong container";
1972 if Before.Node = null
1973 or else Before.Node.Element = null
1975 raise Program_Error with
1976 "Before cursor has no element";
1979 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1982 if Position.Node = null then
1983 raise Constraint_Error with "Position cursor has no element";
1986 if Position.Node.Element = null then
1987 raise Program_Error with
1988 "Position cursor has no element";
1991 if Position.Container /= Source'Unrestricted_Access then
1992 raise Program_Error with
1993 "Position cursor designates wrong container";
1996 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1998 if Target.Length = Count_Type'Last then
1999 raise Constraint_Error with "Target is full";
2002 if Target.Busy > 0 then
2003 raise Program_Error with
2004 "attempt to tamper with cursors of Target (list is busy)";
2007 if Source.Busy > 0 then
2008 raise Program_Error with
2009 "attempt to tamper with cursors of Source (list is busy)";
2012 Splice_Internal (Target, Before.Node, Source, Position.Node);
2013 Position.Container := Target'Unchecked_Access;
2016 ---------------------
2017 -- Splice_Internal --
2018 ---------------------
2020 procedure Splice_Internal
2021 (Target : in out List;
2022 Before : Node_Access;
2023 Source : in out List)
2026 -- This implements the corresponding Splice operation, after the
2027 -- parameters have been vetted, and corner-cases disposed of.
2029 pragma Assert (Target'Address /= Source'Address);
2030 pragma Assert (Source.Length > 0);
2031 pragma Assert (Source.First /= null);
2032 pragma Assert (Source.First.Prev = null);
2033 pragma Assert (Source.Last /= null);
2034 pragma Assert (Source.Last.Next = null);
2035 pragma Assert (Target.Length <= Count_Type'Last - Source.Length);
2037 if Target.Length = 0 then
2038 pragma Assert (Before = null);
2039 pragma Assert (Target.First = null);
2040 pragma Assert (Target.Last = null);
2042 Target.First := Source.First;
2043 Target.Last := Source.Last;
2045 elsif Before = null then
2046 pragma Assert (Target.Last.Next = null);
2048 Target.Last.Next := Source.First;
2049 Source.First.Prev := Target.Last;
2051 Target.Last := Source.Last;
2053 elsif Before = Target.First then
2054 pragma Assert (Target.First.Prev = null);
2056 Source.Last.Next := Target.First;
2057 Target.First.Prev := Source.Last;
2059 Target.First := Source.First;
2062 pragma Assert (Target.Length >= 2);
2063 Before.Prev.Next := Source.First;
2064 Source.First.Prev := Before.Prev;
2066 Before.Prev := Source.Last;
2067 Source.Last.Next := Before;
2070 Source.First := null;
2071 Source.Last := null;
2073 Target.Length := Target.Length + Source.Length;
2075 end Splice_Internal;
2077 procedure Splice_Internal
2078 (Target : in out List;
2079 Before : Node_Access; -- node of Target
2080 Source : in out List;
2081 Position : Node_Access) -- node of Source
2084 -- This implements the corresponding Splice operation, after the
2085 -- parameters have been vetted.
2087 pragma Assert (Target'Address /= Source'Address);
2088 pragma Assert (Target.Length < Count_Type'Last);
2089 pragma Assert (Source.Length > 0);
2090 pragma Assert (Source.First /= null);
2091 pragma Assert (Source.First.Prev = null);
2092 pragma Assert (Source.Last /= null);
2093 pragma Assert (Source.Last.Next = null);
2094 pragma Assert (Position /= null);
2096 if Position = Source.First then
2097 Source.First := Position.Next;
2099 if Position = Source.Last then
2100 pragma Assert (Source.First = null);
2101 pragma Assert (Source.Length = 1);
2102 Source.Last := null;
2105 Source.First.Prev := null;
2108 elsif Position = Source.Last then
2109 pragma Assert (Source.Length >= 2);
2110 Source.Last := Position.Prev;
2111 Source.Last.Next := null;
2114 pragma Assert (Source.Length >= 3);
2115 Position.Prev.Next := Position.Next;
2116 Position.Next.Prev := Position.Prev;
2119 if Target.Length = 0 then
2120 pragma Assert (Before = null);
2121 pragma Assert (Target.First = null);
2122 pragma Assert (Target.Last = null);
2124 Target.First := Position;
2125 Target.Last := Position;
2127 Target.First.Prev := null;
2128 Target.Last.Next := null;
2130 elsif Before = null then
2131 pragma Assert (Target.Last.Next = null);
2132 Target.Last.Next := Position;
2133 Position.Prev := Target.Last;
2135 Target.Last := Position;
2136 Target.Last.Next := null;
2138 elsif Before = Target.First then
2139 pragma Assert (Target.First.Prev = null);
2140 Target.First.Prev := Position;
2141 Position.Next := Target.First;
2143 Target.First := Position;
2144 Target.First.Prev := null;
2147 pragma Assert (Target.Length >= 2);
2148 Before.Prev.Next := Position;
2149 Position.Prev := Before.Prev;
2151 Before.Prev := Position;
2152 Position.Next := Before;
2155 Target.Length := Target.Length + 1;
2156 Source.Length := Source.Length - 1;
2157 end Splice_Internal;
2164 (Container : in out List;
2168 if I.Node = null then
2169 raise Constraint_Error with "I cursor has no element";
2172 if J.Node = null then
2173 raise Constraint_Error with "J cursor has no element";
2176 if I.Container /= Container'Unchecked_Access then
2177 raise Program_Error with "I cursor designates wrong container";
2180 if J.Container /= Container'Unchecked_Access then
2181 raise Program_Error with "J cursor designates wrong container";
2184 if I.Node = J.Node then
2188 if Container.Lock > 0 then
2189 raise Program_Error with
2190 "attempt to tamper with elements (list is locked)";
2193 pragma Assert (Vet (I), "bad I cursor in Swap");
2194 pragma Assert (Vet (J), "bad J cursor in Swap");
2197 EI_Copy : constant Element_Access := I.Node.Element;
2200 I.Node.Element := J.Node.Element;
2201 J.Node.Element := EI_Copy;
2209 procedure Swap_Links
2210 (Container : in out List;
2214 if I.Node = null then
2215 raise Constraint_Error with "I cursor has no element";
2218 if J.Node = null then
2219 raise Constraint_Error with "J cursor has no element";
2222 if I.Container /= Container'Unrestricted_Access then
2223 raise Program_Error with "I cursor designates wrong container";
2226 if J.Container /= Container'Unrestricted_Access then
2227 raise Program_Error with "J cursor designates wrong container";
2230 if I.Node = J.Node then
2234 if Container.Busy > 0 then
2235 raise Program_Error with
2236 "attempt to tamper with cursors (list is busy)";
2239 pragma Assert (Vet (I), "bad I cursor in Swap_Links");
2240 pragma Assert (Vet (J), "bad J cursor in Swap_Links");
2243 I_Next : constant Cursor := Next (I);
2247 Splice (Container, Before => I, Position => J);
2251 J_Next : constant Cursor := Next (J);
2255 Splice (Container, Before => J, Position => I);
2258 pragma Assert (Container.Length >= 3);
2260 Splice (Container, Before => I_Next, Position => J);
2261 Splice (Container, Before => J_Next, Position => I);
2267 pragma Assert (Container.First.Prev = null);
2268 pragma Assert (Container.Last.Next = null);
2271 --------------------
2272 -- Update_Element --
2273 --------------------
2275 procedure Update_Element
2276 (Container : in out List;
2278 Process : not null access procedure (Element : in out Element_Type))
2281 if Position.Node = null then
2282 raise Constraint_Error with "Position cursor has no element";
2285 if Position.Node.Element = null then
2286 raise Program_Error with
2287 "Position cursor has no element";
2290 if Position.Container /= Container'Unchecked_Access then
2291 raise Program_Error with
2292 "Position cursor designates wrong container";
2295 pragma Assert (Vet (Position), "bad cursor in Update_Element");
2298 B : Natural renames Container.Busy;
2299 L : Natural renames Container.Lock;
2306 Process (Position.Node.Element.all);
2323 function Vet (Position : Cursor) return Boolean is
2325 if Position.Node = null then
2326 return Position.Container = null;
2329 if Position.Container = null then
2333 -- An invariant of a node is that its Previous and Next components can
2334 -- be null, or designate a different node. Also, its element access
2335 -- value must be non-null. Operation Free sets the node access value
2336 -- components of the node to designate the node itself, and the element
2337 -- access value to null, before actually deallocating the node, thus
2338 -- deliberately violating the node invariant. This gives us a simple way
2339 -- to detect a dangling reference to a node.
2341 if Position.Node.Next = Position.Node then
2345 if Position.Node.Prev = Position.Node then
2349 if Position.Node.Element = null then
2353 -- In practice the tests above will detect most instances of a dangling
2354 -- reference. If we get here, it means that the invariants of the
2355 -- designated node are satisfied (they at least appear to be satisfied),
2356 -- so we perform some more tests, to determine whether invariants of the
2357 -- designated list are satisfied too.
2360 L : List renames Position.Container.all;
2363 if L.Length = 0 then
2367 if L.First = null then
2371 if L.Last = null then
2375 if L.First.Prev /= null then
2379 if L.Last.Next /= null then
2383 if Position.Node.Prev = null and then Position.Node /= L.First then
2387 if Position.Node.Next = null and then Position.Node /= L.Last then
2391 if L.Length = 1 then
2392 return L.First = L.Last;
2395 if L.First = L.Last then
2399 if L.First.Next = null then
2403 if L.Last.Prev = null then
2407 if L.First.Next.Prev /= L.First then
2411 if L.Last.Prev.Next /= L.Last then
2415 if L.Length = 2 then
2416 if L.First.Next /= L.Last then
2420 if L.Last.Prev /= L.First then
2427 if L.First.Next = L.Last then
2431 if L.Last.Prev = L.First then
2435 if Position.Node = L.First then
2439 if Position.Node = L.Last then
2443 if Position.Node.Next = null then
2447 if Position.Node.Prev = null then
2451 if Position.Node.Next.Prev /= Position.Node then
2455 if Position.Node.Prev.Next /= Position.Node then
2459 if L.Length = 3 then
2460 if L.First.Next /= Position.Node then
2464 if L.Last.Prev /= Position.Node then
2478 (Stream : not null access Root_Stream_Type'Class;
2481 Node : Node_Access := Item.First;
2484 Count_Type'Base'Write
(Stream
, Item
.Length
);
2486 while Node
/= null loop
2487 Element_Type
'Output (Stream
, Node
.Element
.all);
2493 (Stream
: not null access Root_Stream_Type
'Class;
2497 raise Program_Error
with "attempt to stream list cursor";
2501 (Stream
: not null access Root_Stream_Type
'Class;
2502 Item
: Reference_Type
)
2505 raise Program_Error
with "attempt to stream reference";
2509 (Stream
: not null access Root_Stream_Type
'Class;
2510 Item
: Constant_Reference_Type
)
2513 raise Program_Error
with "attempt to stream reference";
2516 end Ada
.Containers
.Indefinite_Doubly_Linked_Lists
;