1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS --
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
.Indefinite_Doubly_Linked_Lists
is
37 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
39 -----------------------
40 -- Local Subprograms --
41 -----------------------
43 procedure Free
(X
: in out Node_Access
);
45 procedure Insert_Internal
46 (Container
: in out List
;
48 New_Node
: Node_Access
);
50 procedure Splice_Internal
51 (Target
: in out List
;
53 Source
: in out List
);
55 procedure Splice_Internal
56 (Target
: in out List
;
59 Position
: Node_Access
);
61 function Vet
(Position
: Cursor
) return Boolean;
62 -- Checks invariants of the cursor and its designated container, as a
63 -- simple way of detecting dangling references (see operation Free for a
64 -- description of the detection mechanism), returning True if all checks
65 -- pass. Invocations of Vet are used here as the argument of pragma Assert,
66 -- so the checks are performed only when assertions are enabled.
72 function "=" (Left
, Right
: List
) return Boolean is
73 BL
: Natural renames Left
'Unrestricted_Access.Busy
;
74 LL
: Natural renames Left
'Unrestricted_Access.Lock
;
76 BR
: Natural renames Right
'Unrestricted_Access.Busy
;
77 LR
: Natural renames Right
'Unrestricted_Access.Lock
;
84 if Left
'Address = Right
'Address then
88 if Left
.Length
/= Right
.Length
then
92 -- Per AI05-0022, the container implementation is required to detect
93 -- element tampering by a generic actual subprogram.
104 for J
in 1 .. Left
.Length
loop
105 if L
.Element
.all /= R
.Element
.all then
137 procedure Adjust
(Container
: in out List
) is
138 Src
: Node_Access
:= Container
.First
;
143 pragma Assert
(Container
.Last
= null);
144 pragma Assert
(Container
.Length
= 0);
145 pragma Assert
(Container
.Busy
= 0);
146 pragma Assert
(Container
.Lock
= 0);
150 pragma Assert
(Container
.First
.Prev
= null);
151 pragma Assert
(Container
.Last
.Next
= null);
152 pragma Assert
(Container
.Length
> 0);
154 Container
.First
:= null;
155 Container
.Last
:= null;
156 Container
.Length
:= 0;
161 Element
: Element_Access
:= new Element_Type
'(Src.Element.all);
163 Dst := new Node_Type'(Element
, null, null);
170 Container
.First
:= Dst
;
171 Container
.Last
:= Dst
;
172 Container
.Length
:= 1;
175 while Src
/= null loop
177 Element
: Element_Access
:= new Element_Type
'(Src.Element.all);
179 Dst := new Node_Type'(Element
, null, Prev
=> Container
.Last
);
186 Container
.Last
.Next
:= Dst
;
187 Container
.Last
:= Dst
;
188 Container
.Length
:= Container
.Length
+ 1;
194 procedure Adjust
(Control
: in out Reference_Control_Type
) is
196 if Control
.Container
/= null then
198 C
: List
renames Control
.Container
.all;
199 B
: Natural renames C
.Busy
;
200 L
: Natural renames C
.Lock
;
213 (Container
: in out List
;
214 New_Item
: Element_Type
;
215 Count
: Count_Type
:= 1)
218 Insert
(Container
, No_Element
, New_Item
, Count
);
225 procedure Assign
(Target
: in out List
; Source
: List
) is
229 if Target
'Address = Source
'Address then
235 Node
:= Source
.First
;
236 while Node
/= null loop
237 Target
.Append
(Node
.Element
.all);
247 procedure Clear
(Container
: in out List
) is
249 pragma Warnings
(Off
, X
);
252 if Container
.Length
= 0 then
253 pragma Assert
(Container
.First
= null);
254 pragma Assert
(Container
.Last
= null);
255 pragma Assert
(Container
.Busy
= 0);
256 pragma Assert
(Container
.Lock
= 0);
260 pragma Assert
(Container
.First
.Prev
= null);
261 pragma Assert
(Container
.Last
.Next
= null);
263 if Container
.Busy
> 0 then
264 raise Program_Error
with
265 "attempt to tamper with cursors (list is busy)";
268 while Container
.Length
> 1 loop
269 X
:= Container
.First
;
270 pragma Assert
(X
.Next
.Prev
= Container
.First
);
272 Container
.First
:= X
.Next
;
273 Container
.First
.Prev
:= null;
275 Container
.Length
:= Container
.Length
- 1;
280 X
:= Container
.First
;
281 pragma Assert
(X
= Container
.Last
);
283 Container
.First
:= null;
284 Container
.Last
:= null;
285 Container
.Length
:= 0;
290 ------------------------
291 -- Constant_Reference --
292 ------------------------
294 function Constant_Reference
295 (Container
: aliased List
;
296 Position
: Cursor
) return Constant_Reference_Type
299 if Position
.Container
= null then
300 raise Constraint_Error
with "Position cursor has no element";
302 elsif Position
.Container
/= Container
'Unrestricted_Access then
303 raise Program_Error
with
304 "Position cursor designates wrong container";
305 elsif Position
.Node
.Element
= null then
306 raise Program_Error
with "Node has no element";
309 pragma Assert
(Vet
(Position
), "bad cursor in Constant_Reference");
312 C
: List
renames Position
.Container
.all;
313 B
: Natural renames C
.Busy
;
314 L
: Natural renames C
.Lock
;
316 return R
: constant Constant_Reference_Type
:=
317 (Element
=> Position
.Node
.Element
.all'Access,
318 Control
=> (Controlled
with Position
.Container
))
325 end Constant_Reference
;
333 Item
: Element_Type
) return Boolean
336 return Find
(Container
, Item
) /= No_Element
;
343 function Copy
(Source
: List
) return List
is
345 return Target
: List
do
346 Target
.Assign
(Source
);
355 (Container
: in out List
;
356 Position
: in out Cursor
;
357 Count
: Count_Type
:= 1)
362 if Position
.Node
= null then
363 raise Constraint_Error
with
364 "Position cursor has no element";
367 if Position
.Node
.Element
= null then
368 raise Program_Error
with
369 "Position cursor has no element";
372 if Position
.Container
/= Container
'Unrestricted_Access then
373 raise Program_Error
with
374 "Position cursor designates wrong container";
377 pragma Assert
(Vet
(Position
), "bad cursor in Delete");
379 if Position
.Node
= Container
.First
then
380 Delete_First
(Container
, Count
);
381 Position
:= No_Element
; -- Post-York behavior
386 Position
:= No_Element
; -- Post-York behavior
390 if Container
.Busy
> 0 then
391 raise Program_Error
with
392 "attempt to tamper with cursors (list is busy)";
395 for Index
in 1 .. Count
loop
397 Container
.Length
:= Container
.Length
- 1;
399 if X
= Container
.Last
then
400 Position
:= No_Element
;
402 Container
.Last
:= X
.Prev
;
403 Container
.Last
.Next
:= null;
409 Position
.Node
:= X
.Next
;
411 X
.Next
.Prev
:= X
.Prev
;
412 X
.Prev
.Next
:= X
.Next
;
417 -- Fix this junk comment ???
419 Position
:= No_Element
; -- Post-York behavior
426 procedure Delete_First
427 (Container
: in out List
;
428 Count
: Count_Type
:= 1)
433 if Count
>= Container
.Length
then
440 elsif Container
.Busy
> 0 then
441 raise Program_Error
with
442 "attempt to tamper with cursors (list is busy)";
445 for J
in 1 .. Count
loop
446 X
:= Container
.First
;
447 pragma Assert
(X
.Next
.Prev
= Container
.First
);
449 Container
.First
:= X
.Next
;
450 Container
.First
.Prev
:= null;
452 Container
.Length
:= Container
.Length
- 1;
463 procedure Delete_Last
464 (Container
: in out List
;
465 Count
: Count_Type
:= 1)
470 if Count
>= Container
.Length
then
477 elsif Container
.Busy
> 0 then
478 raise Program_Error
with
479 "attempt to tamper with cursors (list is busy)";
482 for J
in 1 .. Count
loop
484 pragma Assert
(X
.Prev
.Next
= Container
.Last
);
486 Container
.Last
:= X
.Prev
;
487 Container
.Last
.Next
:= null;
489 Container
.Length
:= Container
.Length
- 1;
500 function Element
(Position
: Cursor
) return Element_Type
is
502 if Position
.Node
= null then
503 raise Constraint_Error
with
504 "Position cursor has no element";
506 elsif Position
.Node
.Element
= null then
507 raise Program_Error
with
508 "Position cursor has no element";
511 pragma Assert
(Vet
(Position
), "bad cursor in Element");
513 return Position
.Node
.Element
.all;
521 procedure Finalize
(Object
: in out Iterator
) is
523 if Object
.Container
/= null then
525 B
: Natural renames Object
.Container
.all.Busy
;
532 procedure Finalize
(Control
: in out Reference_Control_Type
) is
534 if Control
.Container
/= null then
536 C
: List
renames Control
.Container
.all;
537 B
: Natural renames C
.Busy
;
538 L
: Natural renames C
.Lock
;
544 Control
.Container
:= null;
555 Position
: Cursor
:= No_Element
) return Cursor
557 Node
: Node_Access
:= Position
.Node
;
561 Node
:= Container
.First
;
564 if Node
.Element
= null then
567 elsif Position
.Container
/= Container
'Unrestricted_Access then
568 raise Program_Error
with
569 "Position cursor designates wrong container";
572 pragma Assert
(Vet
(Position
), "bad cursor in Find");
576 -- Per AI05-0022, the container implementation is required to detect
577 -- element tampering by a generic actual subprogram.
580 B
: Natural renames Container
'Unrestricted_Access.Busy
;
581 L
: Natural renames Container
'Unrestricted_Access.Lock
;
583 Result
: Node_Access
;
590 while Node
/= null loop
591 if Node
.Element
.all = Item
then
602 if Result
= null then
605 return Cursor
'(Container'Unrestricted_Access, Result);
620 function First (Container : List) return Cursor is
622 if Container.First = null then
625 return Cursor'(Container
'Unrestricted_Access, Container
.First
);
629 function First
(Object
: Iterator
) return Cursor
is
631 -- The value of the iterator object's Node component influences the
632 -- behavior of the First (and Last) selector function.
634 -- When the Node component is null, this means the iterator object was
635 -- constructed without a start expression, in which case the (forward)
636 -- iteration starts from the (logical) beginning of the entire sequence
637 -- of items (corresponding to Container.First, for a forward iterator).
639 -- Otherwise, this is iteration over a partial sequence of items. When
640 -- the Node component is non-null, the iterator object was constructed
641 -- with a start expression, that specifies the position from which the
642 -- (forward) partial iteration begins.
644 if Object
.Node
= null then
645 return Indefinite_Doubly_Linked_Lists
.First
(Object
.Container
.all);
647 return Cursor
'(Object.Container, Object.Node);
655 function First_Element (Container : List) return Element_Type is
657 if Container.First = null then
658 raise Constraint_Error with "list is empty";
660 return Container.First.Element.all;
668 procedure Free (X : in out Node_Access) is
669 procedure Deallocate is
670 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
673 -- While a node is in use, as an active link in a list, its Previous and
674 -- Next components must be null, or designate a different node; this is
675 -- a node invariant. For this indefinite list, there is an additional
676 -- invariant: that the element access value be non-null. Before actually
677 -- deallocating the node, we set the node access value components of the
678 -- node to point to the node itself, and set the element access value to
679 -- null (by deallocating the node's element), thus falsifying the node
680 -- invariant. Subprogram Vet inspects the value of the node components
681 -- when interrogating the node, in order to detect whether the cursor's
682 -- node access value is dangling.
684 -- Note that we have no guarantee that the storage for the node isn't
685 -- modified when it is deallocated, but there are other tests that Vet
686 -- does if node invariants appear to be satisifed. However, in practice
687 -- this simple test works well enough, detecting dangling references
688 -- immediately, without needing further interrogation.
705 ---------------------
706 -- Generic_Sorting --
707 ---------------------
709 package body Generic_Sorting is
715 function Is_Sorted (Container : List) return Boolean is
716 B : Natural renames Container'Unrestricted_Access.Busy;
717 L : Natural renames Container'Unrestricted_Access.Lock;
723 -- Per AI05-0022, the container implementation is required to detect
724 -- element tampering by a generic actual subprogram.
729 Node := Container.First;
731 for J in 2 .. Container.Length loop
732 if Node.Next.Element.all < Node.Element.all then
757 (Target : in out List;
758 Source : in out List)
761 -- The semantics of Merge changed slightly per AI05-0021. It was
762 -- originally the case that if Target and Source denoted the same
763 -- container object, then the GNAT implementation of Merge did
764 -- nothing. However, it was argued that RM05 did not precisely
765 -- specify the semantics for this corner case. The decision of the
766 -- ARG was that if Target and Source denote the same non-empty
767 -- container object, then Program_Error is raised.
769 if Source.Is_Empty then
772 elsif Target'Address = Source'Address then
773 raise Program_Error with
774 "Target and Source denote same non-empty container";
776 elsif Target.Length > Count_Type'Last - Source.Length then
777 raise Constraint_Error with "new length exceeds maximum";
779 elsif Target.Busy > 0 then
780 raise Program_Error with
781 "attempt to tamper with cursors of Target (list is busy)";
783 elsif Source.Busy > 0 then
784 raise Program_Error with
785 "attempt to tamper with cursors of Source (list is busy)";
789 TB : Natural renames Target.Busy;
790 TL : Natural renames Target.Lock;
792 SB : Natural renames Source.Busy;
793 SL : Natural renames Source.Lock;
795 LI, RI, RJ : Node_Access;
806 while RI /= null loop
807 pragma Assert (RI.Next = null
808 or else not (RI.Next.Element.all <
812 Splice_Internal (Target, null, Source);
816 pragma Assert (LI.Next = null
817 or else not (LI.Next.Element.all <
820 if RI.Element.all < LI.Element.all then
823 Splice_Internal (Target, LI, Source, RJ);
852 procedure Sort (Container : in out List) is
853 procedure Partition (Pivot : Node_Access; Back : Node_Access);
856 procedure Sort (Front, Back : Node_Access);
857 -- Comment??? Confusing name??? change name???
863 procedure Partition (Pivot : Node_Access; Back : Node_Access) is
868 while Node /= Back loop
869 if Node.Element.all < Pivot.Element.all then
871 Prev : constant Node_Access := Node.Prev;
872 Next : constant Node_Access := Node.Next;
878 Container.Last := Prev;
884 Node.Prev := Pivot.Prev;
888 if Node.Prev = null then
889 Container.First := Node;
891 Node.Prev.Next := Node;
907 procedure Sort (Front, Back : Node_Access) is
908 Pivot : constant Node_Access :=
909 (if Front = null then Container.First else Front.Next);
911 if Pivot /= Back then
912 Partition (Pivot, Back);
918 -- Start of processing for Sort
921 if Container.Length <= 1 then
925 pragma Assert (Container.First.Prev = null);
926 pragma Assert (Container.Last.Next = null);
928 if Container.Busy > 0 then
929 raise Program_Error with
930 "attempt to tamper with cursors (list is busy)";
933 -- Per AI05-0022, the container implementation is required to detect
934 -- element tampering by a generic actual subprogram.
937 B : Natural renames Container.Busy;
938 L : Natural renames Container.Lock;
944 Sort (Front => null, Back => null);
955 pragma Assert (Container.First.Prev = null);
956 pragma Assert (Container.Last.Next = null);
965 function Has_Element (Position : Cursor) return Boolean is
967 pragma Assert (Vet (Position), "bad cursor in Has_Element");
968 return Position.Node /= null;
976 (Container : in out List;
978 New_Item : Element_Type;
979 Position : out Cursor;
980 Count : Count_Type := 1)
982 New_Node : Node_Access;
985 if Before.Container /= null then
986 if Before.Container /= Container'Unrestricted_Access then
987 raise Program_Error with
988 "attempt to tamper with cursors (list is busy)";
990 elsif Before.Node = null or else Before.Node.Element = null then
991 raise Program_Error with
992 "Before cursor has no element";
995 pragma Assert (Vet (Before), "bad cursor in Insert");
1004 if Container.Length > Count_Type'Last - Count then
1005 raise Constraint_Error with "new length exceeds maximum";
1008 if Container.Busy > 0 then
1009 raise Program_Error with
1010 "attempt to tamper with cursors (list is busy)";
1014 -- The element allocator may need an accessibility check in the case
1015 -- the actual type is class-wide or has access discriminants (see
1016 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
1017 -- allocator in the loop below, because the one in this block would
1018 -- have failed already.
1020 pragma Unsuppress (Accessibility_Check);
1022 Element : Element_Access := new Element_Type'(New_Item
);
1025 New_Node
:= new Node_Type
'(Element, null, null);
1033 Insert_Internal (Container, Before.Node, New_Node);
1034 Position := Cursor'(Container
'Unchecked_Access, New_Node
);
1036 for J
in 2 .. Count
loop
1038 Element
: Element_Access
:= new Element_Type
'(New_Item);
1040 New_Node := new Node_Type'(Element
, null, null);
1047 Insert_Internal
(Container
, Before
.Node
, New_Node
);
1052 (Container
: in out List
;
1054 New_Item
: Element_Type
;
1055 Count
: Count_Type
:= 1)
1058 pragma Unreferenced
(Position
);
1060 Insert
(Container
, Before
, New_Item
, Position
, Count
);
1063 ---------------------
1064 -- Insert_Internal --
1065 ---------------------
1067 procedure Insert_Internal
1068 (Container
: in out List
;
1069 Before
: Node_Access
;
1070 New_Node
: Node_Access
)
1073 if Container
.Length
= 0 then
1074 pragma Assert
(Before
= null);
1075 pragma Assert
(Container
.First
= null);
1076 pragma Assert
(Container
.Last
= null);
1078 Container
.First
:= New_Node
;
1079 Container
.Last
:= New_Node
;
1081 elsif Before
= null then
1082 pragma Assert
(Container
.Last
.Next
= null);
1084 Container
.Last
.Next
:= New_Node
;
1085 New_Node
.Prev
:= Container
.Last
;
1087 Container
.Last
:= New_Node
;
1089 elsif Before
= Container
.First
then
1090 pragma Assert
(Container
.First
.Prev
= null);
1092 Container
.First
.Prev
:= New_Node
;
1093 New_Node
.Next
:= Container
.First
;
1095 Container
.First
:= New_Node
;
1098 pragma Assert
(Container
.First
.Prev
= null);
1099 pragma Assert
(Container
.Last
.Next
= null);
1101 New_Node
.Next
:= Before
;
1102 New_Node
.Prev
:= Before
.Prev
;
1104 Before
.Prev
.Next
:= New_Node
;
1105 Before
.Prev
:= New_Node
;
1108 Container
.Length
:= Container
.Length
+ 1;
1109 end Insert_Internal
;
1115 function Is_Empty
(Container
: List
) return Boolean is
1117 return Container
.Length
= 0;
1126 Process
: not null access procedure (Position
: Cursor
))
1128 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
1129 Node
: Node_Access
:= Container
.First
;
1135 while Node
/= null loop
1136 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1150 return List_Iterator_Interfaces.Reversible_Iterator'class
1152 B : Natural renames Container'Unrestricted_Access.all.Busy;
1155 -- The value of the Node component influences the behavior of the First
1156 -- and Last selector functions of the iterator object. When the Node
1157 -- component is null (as is the case here), this means the iterator
1158 -- object was constructed without a start expression. This is a
1159 -- complete iterator, meaning that the iteration starts from the
1160 -- (logical) beginning of the sequence of items.
1162 -- Note: For a forward iterator, Container.First is the beginning, and
1163 -- for a reverse iterator, Container.Last is the beginning.
1165 return It : constant Iterator :=
1166 Iterator'(Limited_Controlled
with
1167 Container
=> Container
'Unrestricted_Access,
1177 return List_Iterator_Interfaces
.Reversible_Iterator
'Class
1179 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
1182 -- It was formerly the case that when Start = No_Element, the partial
1183 -- iterator was defined to behave the same as for a complete iterator,
1184 -- and iterate over the entire sequence of items. However, those
1185 -- semantics were unintuitive and arguably error-prone (it is too easy
1186 -- to accidentally create an endless loop), and so they were changed,
1187 -- per the ARG meeting in Denver on 2011/11. However, there was no
1188 -- consensus about what positive meaning this corner case should have,
1189 -- and so it was decided to simply raise an exception. This does imply,
1190 -- however, that it is not possible to use a partial iterator to specify
1191 -- an empty sequence of items.
1193 if Start
= No_Element
then
1194 raise Constraint_Error
with
1195 "Start position for iterator equals No_Element";
1197 elsif Start
.Container
/= Container
'Unrestricted_Access then
1198 raise Program_Error
with
1199 "Start cursor of Iterate designates wrong list";
1202 pragma Assert
(Vet
(Start
), "Start cursor of Iterate is bad");
1204 -- The value of the Node component influences the behavior of the
1205 -- First and Last selector functions of the iterator object. When
1206 -- the Node component is non-null (as is the case here), it means
1207 -- that this is a partial iteration, over a subset of the complete
1208 -- sequence of items. The iterator object was constructed with
1209 -- a start expression, indicating the position from which the
1210 -- iteration begins. Note that the start position has the same value
1211 -- irrespective of whether this is a forward or reverse iteration.
1213 return It
: constant Iterator
:=
1214 Iterator
'(Limited_Controlled with
1215 Container => Container'Unrestricted_Access,
1227 function Last (Container : List) return Cursor is
1229 if Container.Last = null then
1232 return Cursor'(Container
'Unrestricted_Access, Container
.Last
);
1236 function Last
(Object
: Iterator
) return Cursor
is
1238 -- The value of the iterator object's Node component influences the
1239 -- behavior of the Last (and First) selector function.
1241 -- When the Node component is null, this means the iterator object was
1242 -- constructed without a start expression, in which case the (reverse)
1243 -- iteration starts from the (logical) beginning of the entire sequence
1244 -- (corresponding to Container.Last, for a reverse iterator).
1246 -- Otherwise, this is iteration over a partial sequence of items. When
1247 -- the Node component is non-null, the iterator object was constructed
1248 -- with a start expression, that specifies the position from which the
1249 -- (reverse) partial iteration begins.
1251 if Object
.Node
= null then
1252 return Indefinite_Doubly_Linked_Lists
.Last
(Object
.Container
.all);
1254 return Cursor
'(Object.Container, Object.Node);
1262 function Last_Element (Container : List) return Element_Type is
1264 if Container.Last = null then
1265 raise Constraint_Error with "list is empty";
1267 return Container.Last.Element.all;
1275 function Length (Container : List) return Count_Type is
1277 return Container.Length;
1284 procedure Move (Target : in out List; Source : in out List) is
1286 if Target'Address = Source'Address then
1289 elsif Source.Busy > 0 then
1290 raise Program_Error with
1291 "attempt to tamper with cursors of Source (list is busy)";
1296 Target.First := Source.First;
1297 Source.First := null;
1299 Target.Last := Source.Last;
1300 Source.Last := null;
1302 Target.Length := Source.Length;
1311 procedure Next (Position : in out Cursor) is
1313 Position := Next (Position);
1316 function Next (Position : Cursor) return Cursor is
1318 if Position.Node = null then
1322 pragma Assert (Vet (Position), "bad cursor in Next");
1325 Next_Node : constant Node_Access := Position.Node.Next;
1327 if Next_Node = null then
1330 return Cursor'(Position
.Container
, Next_Node
);
1336 function Next
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
1338 if Position
.Container
= null then
1340 elsif Position
.Container
/= Object
.Container
then
1341 raise Program_Error
with
1342 "Position cursor of Next designates wrong list";
1344 return Next
(Position
);
1353 (Container
: in out List
;
1354 New_Item
: Element_Type
;
1355 Count
: Count_Type
:= 1)
1358 Insert
(Container
, First
(Container
), New_Item
, Count
);
1365 procedure Previous
(Position
: in out Cursor
) is
1367 Position
:= Previous
(Position
);
1370 function Previous
(Position
: Cursor
) return Cursor
is
1372 if Position
.Node
= null then
1376 pragma Assert
(Vet
(Position
), "bad cursor in Previous");
1379 Prev_Node
: constant Node_Access
:= Position
.Node
.Prev
;
1381 if Prev_Node
= null then
1384 return Cursor
'(Position.Container, Prev_Node);
1390 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1392 if Position.Container = null then
1394 elsif Position.Container /= Object.Container then
1395 raise Program_Error with
1396 "Position cursor of Previous designates wrong list";
1398 return Previous (Position);
1406 procedure Query_Element
1408 Process : not null access procedure (Element : Element_Type))
1411 if Position.Node = null then
1412 raise Constraint_Error with
1413 "Position cursor has no element";
1415 elsif Position.Node.Element = null then
1416 raise Program_Error with
1417 "Position cursor has no element";
1420 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1423 C : List renames Position.Container.all'Unrestricted_Access.all;
1424 B : Natural renames C.Busy;
1425 L : Natural renames C.Lock;
1432 Process (Position.Node.Element.all);
1451 (Stream : not null access Root_Stream_Type'Class;
1454 N : Count_Type'Base;
1460 Count_Type'Base'Read
(Stream
, N
);
1467 Element
: Element_Access
:=
1468 new Element_Type
'(Element_Type'Input (Stream));
1470 Dst := new Node_Type'(Element
, null, null);
1481 while Item
.Length
< N
loop
1483 Element
: Element_Access
:=
1484 new Element_Type
'(Element_Type'Input (Stream));
1486 Dst := new Node_Type'(Element
, Next
=> null, Prev
=> Item
.Last
);
1493 Item
.Last
.Next
:= Dst
;
1495 Item
.Length
:= Item
.Length
+ 1;
1500 (Stream
: not null access Root_Stream_Type
'Class;
1504 raise Program_Error
with "attempt to stream list cursor";
1508 (Stream
: not null access Root_Stream_Type
'Class;
1509 Item
: out Reference_Type
)
1512 raise Program_Error
with "attempt to stream reference";
1516 (Stream
: not null access Root_Stream_Type
'Class;
1517 Item
: out Constant_Reference_Type
)
1520 raise Program_Error
with "attempt to stream reference";
1528 (Container
: aliased in out List
;
1529 Position
: Cursor
) return Reference_Type
1532 if Position
.Container
= null then
1533 raise Constraint_Error
with "Position cursor has no element";
1535 elsif Position
.Container
/= Container
'Unrestricted_Access then
1536 raise Program_Error
with
1537 "Position cursor designates wrong container";
1539 elsif Position
.Node
.Element
= null then
1540 raise Program_Error
with "Node has no element";
1543 pragma Assert
(Vet
(Position
), "bad cursor in function Reference");
1546 C
: List
renames Position
.Container
.all;
1547 B
: Natural renames C
.Busy
;
1548 L
: Natural renames C
.Lock
;
1550 return R
: constant Reference_Type
:=
1551 (Element
=> Position
.Node
.Element
.all'Access,
1552 Control
=> (Controlled
with Position
.Container
))
1561 ---------------------
1562 -- Replace_Element --
1563 ---------------------
1565 procedure Replace_Element
1566 (Container
: in out List
;
1568 New_Item
: Element_Type
)
1571 if Position
.Container
= null then
1572 raise Constraint_Error
with "Position cursor has no element";
1574 elsif Position
.Container
/= Container
'Unchecked_Access then
1575 raise Program_Error
with
1576 "Position cursor designates wrong container";
1578 elsif Container
.Lock
> 0 then
1579 raise Program_Error
with
1580 "attempt to tamper with elements (list is locked)";
1582 elsif Position
.Node
.Element
= null then
1583 raise Program_Error
with
1584 "Position cursor has no element";
1587 pragma Assert
(Vet
(Position
), "bad cursor in Replace_Element");
1590 -- The element allocator may need an accessibility check in the
1591 -- case the actual type is class-wide or has access discriminants
1592 -- (see RM 4.8(10.1) and AI12-0035).
1594 pragma Unsuppress
(Accessibility_Check
);
1596 X
: Element_Access
:= Position
.Node
.Element
;
1599 Position
.Node
.Element
:= new Element_Type
'(New_Item);
1603 end Replace_Element;
1605 ----------------------
1606 -- Reverse_Elements --
1607 ----------------------
1609 procedure Reverse_Elements (Container : in out List) is
1610 I : Node_Access := Container.First;
1611 J : Node_Access := Container.Last;
1613 procedure Swap (L, R : Node_Access);
1619 procedure Swap (L, R : Node_Access) is
1620 LN : constant Node_Access := L.Next;
1621 LP : constant Node_Access := L.Prev;
1623 RN : constant Node_Access := R.Next;
1624 RP : constant Node_Access := R.Prev;
1639 pragma Assert (RP = L);
1653 -- Start of processing for Reverse_Elements
1656 if Container.Length <= 1 then
1660 pragma Assert (Container.First.Prev = null);
1661 pragma Assert (Container.Last.Next = null);
1663 if Container.Busy > 0 then
1664 raise Program_Error with
1665 "attempt to tamper with cursors (list is busy)";
1668 Container.First := J;
1669 Container.Last := I;
1671 Swap (L => I, R => J);
1679 Swap (L => J, R => I);
1688 pragma Assert (Container.First.Prev = null);
1689 pragma Assert (Container.Last.Next = null);
1690 end Reverse_Elements;
1696 function Reverse_Find
1698 Item : Element_Type;
1699 Position : Cursor := No_Element) return Cursor
1701 Node : Node_Access := Position.Node;
1705 Node := Container.Last;
1708 if Node.Element = null then
1709 raise Program_Error with "Position cursor has no element";
1711 elsif Position.Container /= Container'Unrestricted_Access then
1712 raise Program_Error with
1713 "Position cursor designates wrong container";
1716 pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1720 -- Per AI05-0022, the container implementation is required to detect
1721 -- element tampering by a generic actual subprogram.
1724 B : Natural renames Container'Unrestricted_Access.Busy;
1725 L : Natural renames Container'Unrestricted_Access.Lock;
1727 Result : Node_Access;
1734 while Node /= null loop
1735 if Node.Element.all = Item then
1746 if Result = null then
1749 return Cursor'(Container
'Unrestricted_Access, Result
);
1760 ---------------------
1761 -- Reverse_Iterate --
1762 ---------------------
1764 procedure Reverse_Iterate
1766 Process
: not null access procedure (Position
: Cursor
))
1768 C
: List
renames Container
'Unrestricted_Access.all;
1769 B
: Natural renames C
.Busy
;
1771 Node
: Node_Access
:= Container
.Last
;
1777 while Node
/= null loop
1778 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1788 end Reverse_Iterate;
1795 (Target : in out List;
1797 Source : in out List)
1800 if Before.Container /= null then
1801 if Before.Container /= Target'Unrestricted_Access then
1802 raise Program_Error with
1803 "Before cursor designates wrong container";
1805 elsif Before.Node = null or else Before.Node.Element = null then
1806 raise Program_Error with
1807 "Before cursor has no element";
1810 pragma Assert (Vet (Before), "bad cursor in Splice");
1814 if Target'Address = Source'Address or else Source.Length = 0 then
1817 elsif Target.Length > Count_Type'Last - Source.Length then
1818 raise Constraint_Error with "new length exceeds maximum";
1820 elsif Target.Busy > 0 then
1821 raise Program_Error with
1822 "attempt to tamper with cursors of Target (list is busy)";
1824 elsif Source.Busy > 0 then
1825 raise Program_Error with
1826 "attempt to tamper with cursors of Source (list is busy)";
1829 Splice_Internal (Target, Before.Node, Source);
1834 (Container : in out List;
1839 if Before.Container /= null then
1840 if Before.Container /= Container'Unchecked_Access then
1841 raise Program_Error with
1842 "Before cursor designates wrong container";
1844 elsif Before.Node = null or else Before.Node.Element = null then
1845 raise Program_Error with
1846 "Before cursor has no element";
1849 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1853 if Position.Node = null then
1854 raise Constraint_Error with "Position cursor has no element";
1857 if Position.Node.Element = null then
1858 raise Program_Error with "Position cursor has no element";
1861 if Position.Container /= Container'Unrestricted_Access then
1862 raise Program_Error with
1863 "Position cursor designates wrong container";
1866 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1868 if Position.Node = Before.Node
1869 or else Position.Node.Next = Before.Node
1874 pragma Assert (Container.Length >= 2);
1876 if Container.Busy > 0 then
1877 raise Program_Error with
1878 "attempt to tamper with cursors (list is busy)";
1881 if Before.Node = null then
1882 pragma Assert (Position.Node /= Container.Last);
1884 if Position.Node = Container.First then
1885 Container.First := Position.Node.Next;
1886 Container.First.Prev := null;
1888 Position.Node.Prev.Next := Position.Node.Next;
1889 Position.Node.Next.Prev := Position.Node.Prev;
1892 Container.Last.Next := Position.Node;
1893 Position.Node.Prev := Container.Last;
1895 Container.Last := Position.Node;
1896 Container.Last.Next := null;
1901 if Before.Node = Container.First then
1902 pragma Assert (Position.Node /= Container.First);
1904 if Position.Node = Container.Last then
1905 Container.Last := Position.Node.Prev;
1906 Container.Last.Next := null;
1908 Position.Node.Prev.Next := Position.Node.Next;
1909 Position.Node.Next.Prev := Position.Node.Prev;
1912 Container.First.Prev := Position.Node;
1913 Position.Node.Next := Container.First;
1915 Container.First := Position.Node;
1916 Container.First.Prev := null;
1921 if Position.Node = Container.First then
1922 Container.First := Position.Node.Next;
1923 Container.First.Prev := null;
1925 elsif Position.Node = Container.Last then
1926 Container.Last := Position.Node.Prev;
1927 Container.Last.Next := null;
1930 Position.Node.Prev.Next := Position.Node.Next;
1931 Position.Node.Next.Prev := Position.Node.Prev;
1934 Before.Node.Prev.Next := Position.Node;
1935 Position.Node.Prev := Before.Node.Prev;
1937 Before.Node.Prev := Position.Node;
1938 Position.Node.Next := Before.Node;
1940 pragma Assert (Container.First.Prev = null);
1941 pragma Assert (Container.Last.Next = null);
1945 (Target : in out List;
1947 Source : in out List;
1948 Position : in out Cursor)
1951 if Target'Address = Source'Address then
1952 Splice (Target, Before, Position);
1956 if Before.Container /= null then
1957 if Before.Container /= Target'Unrestricted_Access then
1958 raise Program_Error with
1959 "Before cursor designates wrong container";
1962 if Before.Node = null
1963 or else Before.Node.Element = null
1965 raise Program_Error with
1966 "Before cursor has no element";
1969 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1972 if Position.Node = null then
1973 raise Constraint_Error with "Position cursor has no element";
1976 if Position.Node.Element = null then
1977 raise Program_Error with
1978 "Position cursor has no element";
1981 if Position.Container /= Source'Unrestricted_Access then
1982 raise Program_Error with
1983 "Position cursor designates wrong container";
1986 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1988 if Target.Length = Count_Type'Last then
1989 raise Constraint_Error with "Target is full";
1992 if Target.Busy > 0 then
1993 raise Program_Error with
1994 "attempt to tamper with cursors of Target (list is busy)";
1997 if Source.Busy > 0 then
1998 raise Program_Error with
1999 "attempt to tamper with cursors of Source (list is busy)";
2002 Splice_Internal (Target, Before.Node, Source, Position.Node);
2003 Position.Container := Target'Unchecked_Access;
2006 ---------------------
2007 -- Splice_Internal --
2008 ---------------------
2010 procedure Splice_Internal
2011 (Target : in out List;
2012 Before : Node_Access;
2013 Source : in out List)
2016 -- This implements the corresponding Splice operation, after the
2017 -- parameters have been vetted, and corner-cases disposed of.
2019 pragma Assert (Target'Address /= Source'Address);
2020 pragma Assert (Source.Length > 0);
2021 pragma Assert (Source.First /= null);
2022 pragma Assert (Source.First.Prev = null);
2023 pragma Assert (Source.Last /= null);
2024 pragma Assert (Source.Last.Next = null);
2025 pragma Assert (Target.Length <= Count_Type'Last - Source.Length);
2027 if Target.Length = 0 then
2028 pragma Assert (Before = null);
2029 pragma Assert (Target.First = null);
2030 pragma Assert (Target.Last = null);
2032 Target.First := Source.First;
2033 Target.Last := Source.Last;
2035 elsif Before = null then
2036 pragma Assert (Target.Last.Next = null);
2038 Target.Last.Next := Source.First;
2039 Source.First.Prev := Target.Last;
2041 Target.Last := Source.Last;
2043 elsif Before = Target.First then
2044 pragma Assert (Target.First.Prev = null);
2046 Source.Last.Next := Target.First;
2047 Target.First.Prev := Source.Last;
2049 Target.First := Source.First;
2052 pragma Assert (Target.Length >= 2);
2053 Before.Prev.Next := Source.First;
2054 Source.First.Prev := Before.Prev;
2056 Before.Prev := Source.Last;
2057 Source.Last.Next := Before;
2060 Source.First := null;
2061 Source.Last := null;
2063 Target.Length := Target.Length + Source.Length;
2065 end Splice_Internal;
2067 procedure Splice_Internal
2068 (Target : in out List;
2069 Before : Node_Access; -- node of Target
2070 Source : in out List;
2071 Position : Node_Access) -- node of Source
2074 -- This implements the corresponding Splice operation, after the
2075 -- parameters have been vetted.
2077 pragma Assert (Target'Address /= Source'Address);
2078 pragma Assert (Target.Length < Count_Type'Last);
2079 pragma Assert (Source.Length > 0);
2080 pragma Assert (Source.First /= null);
2081 pragma Assert (Source.First.Prev = null);
2082 pragma Assert (Source.Last /= null);
2083 pragma Assert (Source.Last.Next = null);
2084 pragma Assert (Position /= null);
2086 if Position = Source.First then
2087 Source.First := Position.Next;
2089 if Position = Source.Last then
2090 pragma Assert (Source.First = null);
2091 pragma Assert (Source.Length = 1);
2092 Source.Last := null;
2095 Source.First.Prev := null;
2098 elsif Position = Source.Last then
2099 pragma Assert (Source.Length >= 2);
2100 Source.Last := Position.Prev;
2101 Source.Last.Next := null;
2104 pragma Assert (Source.Length >= 3);
2105 Position.Prev.Next := Position.Next;
2106 Position.Next.Prev := Position.Prev;
2109 if Target.Length = 0 then
2110 pragma Assert (Before = null);
2111 pragma Assert (Target.First = null);
2112 pragma Assert (Target.Last = null);
2114 Target.First := Position;
2115 Target.Last := Position;
2117 Target.First.Prev := null;
2118 Target.Last.Next := null;
2120 elsif Before = null then
2121 pragma Assert (Target.Last.Next = null);
2122 Target.Last.Next := Position;
2123 Position.Prev := Target.Last;
2125 Target.Last := Position;
2126 Target.Last.Next := null;
2128 elsif Before = Target.First then
2129 pragma Assert (Target.First.Prev = null);
2130 Target.First.Prev := Position;
2131 Position.Next := Target.First;
2133 Target.First := Position;
2134 Target.First.Prev := null;
2137 pragma Assert (Target.Length >= 2);
2138 Before.Prev.Next := Position;
2139 Position.Prev := Before.Prev;
2141 Before.Prev := Position;
2142 Position.Next := Before;
2145 Target.Length := Target.Length + 1;
2146 Source.Length := Source.Length - 1;
2147 end Splice_Internal;
2154 (Container : in out List;
2158 if I.Node = null then
2159 raise Constraint_Error with "I cursor has no element";
2162 if J.Node = null then
2163 raise Constraint_Error with "J cursor has no element";
2166 if I.Container /= Container'Unchecked_Access then
2167 raise Program_Error with "I cursor designates wrong container";
2170 if J.Container /= Container'Unchecked_Access then
2171 raise Program_Error with "J cursor designates wrong container";
2174 if I.Node = J.Node then
2178 if Container.Lock > 0 then
2179 raise Program_Error with
2180 "attempt to tamper with elements (list is locked)";
2183 pragma Assert (Vet (I), "bad I cursor in Swap");
2184 pragma Assert (Vet (J), "bad J cursor in Swap");
2187 EI_Copy : constant Element_Access := I.Node.Element;
2190 I.Node.Element := J.Node.Element;
2191 J.Node.Element := EI_Copy;
2199 procedure Swap_Links
2200 (Container : in out List;
2204 if I.Node = null then
2205 raise Constraint_Error with "I cursor has no element";
2208 if J.Node = null then
2209 raise Constraint_Error with "J cursor has no element";
2212 if I.Container /= Container'Unrestricted_Access then
2213 raise Program_Error with "I cursor designates wrong container";
2216 if J.Container /= Container'Unrestricted_Access then
2217 raise Program_Error with "J cursor designates wrong container";
2220 if I.Node = J.Node then
2224 if Container.Busy > 0 then
2225 raise Program_Error with
2226 "attempt to tamper with cursors (list is busy)";
2229 pragma Assert (Vet (I), "bad I cursor in Swap_Links");
2230 pragma Assert (Vet (J), "bad J cursor in Swap_Links");
2233 I_Next : constant Cursor := Next (I);
2237 Splice (Container, Before => I, Position => J);
2241 J_Next : constant Cursor := Next (J);
2245 Splice (Container, Before => J, Position => I);
2248 pragma Assert (Container.Length >= 3);
2250 Splice (Container, Before => I_Next, Position => J);
2251 Splice (Container, Before => J_Next, Position => I);
2257 pragma Assert (Container.First.Prev = null);
2258 pragma Assert (Container.Last.Next = null);
2261 --------------------
2262 -- Update_Element --
2263 --------------------
2265 procedure Update_Element
2266 (Container : in out List;
2268 Process : not null access procedure (Element : in out Element_Type))
2271 if Position.Node = null then
2272 raise Constraint_Error with "Position cursor has no element";
2275 if Position.Node.Element = null then
2276 raise Program_Error with
2277 "Position cursor has no element";
2280 if Position.Container /= Container'Unchecked_Access then
2281 raise Program_Error with
2282 "Position cursor designates wrong container";
2285 pragma Assert (Vet (Position), "bad cursor in Update_Element");
2288 B : Natural renames Container.Busy;
2289 L : Natural renames Container.Lock;
2296 Process (Position.Node.Element.all);
2313 function Vet (Position : Cursor) return Boolean is
2315 if Position.Node = null then
2316 return Position.Container = null;
2319 if Position.Container = null then
2323 -- An invariant of a node is that its Previous and Next components can
2324 -- be null, or designate a different node. Also, its element access
2325 -- value must be non-null. Operation Free sets the node access value
2326 -- components of the node to designate the node itself, and the element
2327 -- access value to null, before actually deallocating the node, thus
2328 -- deliberately violating the node invariant. This gives us a simple way
2329 -- to detect a dangling reference to a node.
2331 if Position.Node.Next = Position.Node then
2335 if Position.Node.Prev = Position.Node then
2339 if Position.Node.Element = null then
2343 -- In practice the tests above will detect most instances of a dangling
2344 -- reference. If we get here, it means that the invariants of the
2345 -- designated node are satisfied (they at least appear to be satisfied),
2346 -- so we perform some more tests, to determine whether invariants of the
2347 -- designated list are satisfied too.
2350 L : List renames Position.Container.all;
2353 if L.Length = 0 then
2357 if L.First = null then
2361 if L.Last = null then
2365 if L.First.Prev /= null then
2369 if L.Last.Next /= null then
2373 if Position.Node.Prev = null and then Position.Node /= L.First then
2377 if Position.Node.Next = null and then Position.Node /= L.Last then
2381 if L.Length = 1 then
2382 return L.First = L.Last;
2385 if L.First = L.Last then
2389 if L.First.Next = null then
2393 if L.Last.Prev = null then
2397 if L.First.Next.Prev /= L.First then
2401 if L.Last.Prev.Next /= L.Last then
2405 if L.Length = 2 then
2406 if L.First.Next /= L.Last then
2410 if L.Last.Prev /= L.First then
2417 if L.First.Next = L.Last then
2421 if L.Last.Prev = L.First then
2425 if Position.Node = L.First then
2429 if Position.Node = L.Last then
2433 if Position.Node.Next = null then
2437 if Position.Node.Prev = null then
2441 if Position.Node.Next.Prev /= Position.Node then
2445 if Position.Node.Prev.Next /= Position.Node then
2449 if L.Length = 3 then
2450 if L.First.Next /= Position.Node then
2454 if L.Last.Prev /= Position.Node then
2468 (Stream : not null access Root_Stream_Type'Class;
2471 Node : Node_Access := Item.First;
2474 Count_Type'Base'Write
(Stream
, Item
.Length
);
2476 while Node
/= null loop
2477 Element_Type
'Output (Stream
, Node
.Element
.all);
2483 (Stream
: not null access Root_Stream_Type
'Class;
2487 raise Program_Error
with "attempt to stream list cursor";
2491 (Stream
: not null access Root_Stream_Type
'Class;
2492 Item
: Reference_Type
)
2495 raise Program_Error
with "attempt to stream reference";
2499 (Stream
: not null access Root_Stream_Type
'Class;
2500 Item
: Constant_Reference_Type
)
2503 raise Program_Error
with "attempt to stream reference";
2506 end Ada
.Containers
.Indefinite_Doubly_Linked_Lists
;