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
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);
621 function First (Container : List) return Cursor is
623 if Container.First = null then
626 return Cursor'(Container
'Unrestricted_Access, Container
.First
);
630 function First
(Object
: Iterator
) return Cursor
is
632 -- The value of the iterator object's Node component influences the
633 -- behavior of the First (and Last) selector function.
635 -- When the Node component is null, this means the iterator object was
636 -- constructed without a start expression, in which case the (forward)
637 -- iteration starts from the (logical) beginning of the entire sequence
638 -- of items (corresponding to Container.First, for a forward iterator).
640 -- Otherwise, this is iteration over a partial sequence of items. When
641 -- the Node component is non-null, the iterator object was constructed
642 -- with a start expression, that specifies the position from which the
643 -- (forward) partial iteration begins.
645 if Object
.Node
= null then
646 return Indefinite_Doubly_Linked_Lists
.First
(Object
.Container
.all);
648 return Cursor
'(Object.Container, Object.Node);
656 function First_Element (Container : List) return Element_Type is
658 if Container.First = null then
659 raise Constraint_Error with "list is empty";
661 return Container.First.Element.all;
669 procedure Free (X : in out Node_Access) is
670 procedure Deallocate is
671 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
674 -- While a node is in use, as an active link in a list, its Previous and
675 -- Next components must be null, or designate a different node; this is
676 -- a node invariant. For this indefinite list, there is an additional
677 -- invariant: that the element access value be non-null. Before actually
678 -- deallocating the node, we set the node access value components of the
679 -- node to point to the node itself, and set the element access value to
680 -- null (by deallocating the node's element), thus falsifying the node
681 -- invariant. Subprogram Vet inspects the value of the node components
682 -- when interrogating the node, in order to detect whether the cursor's
683 -- node access value is dangling.
685 -- Note that we have no guarantee that the storage for the node isn't
686 -- modified when it is deallocated, but there are other tests that Vet
687 -- does if node invariants appear to be satisifed. However, in practice
688 -- this simple test works well enough, detecting dangling references
689 -- immediately, without needing further interrogation.
706 ---------------------
707 -- Generic_Sorting --
708 ---------------------
710 package body Generic_Sorting is
716 function Is_Sorted (Container : List) return Boolean is
717 B : Natural renames Container'Unrestricted_Access.Busy;
718 L : Natural renames Container'Unrestricted_Access.Lock;
724 -- Per AI05-0022, the container implementation is required to detect
725 -- element tampering by a generic actual subprogram.
730 Node := Container.First;
732 for J in 2 .. Container.Length loop
733 if Node.Next.Element.all < Node.Element.all then
759 (Target : in out List;
760 Source : in out List)
763 -- The semantics of Merge changed slightly per AI05-0021. It was
764 -- originally the case that if Target and Source denoted the same
765 -- container object, then the GNAT implementation of Merge did
766 -- nothing. However, it was argued that RM05 did not precisely
767 -- specify the semantics for this corner case. The decision of the
768 -- ARG was that if Target and Source denote the same non-empty
769 -- container object, then Program_Error is raised.
771 if Source.Is_Empty then
774 elsif Target'Address = Source'Address then
775 raise Program_Error with
776 "Target and Source denote same non-empty container";
778 elsif Target.Length > Count_Type'Last - Source.Length then
779 raise Constraint_Error with "new length exceeds maximum";
781 elsif Target.Busy > 0 then
782 raise Program_Error with
783 "attempt to tamper with cursors of Target (list is busy)";
785 elsif Source.Busy > 0 then
786 raise Program_Error with
787 "attempt to tamper with cursors of Source (list is busy)";
791 TB : Natural renames Target.Busy;
792 TL : Natural renames Target.Lock;
794 SB : Natural renames Source.Busy;
795 SL : Natural renames Source.Lock;
797 LI, RI, RJ : Node_Access;
808 while RI /= null loop
809 pragma Assert (RI.Next = null
810 or else not (RI.Next.Element.all <
814 Splice_Internal (Target, null, Source);
818 pragma Assert (LI.Next = null
819 or else not (LI.Next.Element.all <
822 if RI.Element.all < LI.Element.all then
825 Splice_Internal (Target, LI, Source, RJ);
854 procedure Sort (Container : in out List) is
855 procedure Partition (Pivot : Node_Access; Back : Node_Access);
858 procedure Sort (Front, Back : Node_Access);
859 -- Comment??? Confusing name??? change name???
865 procedure Partition (Pivot : Node_Access; Back : Node_Access) is
870 while Node /= Back loop
871 if Node.Element.all < Pivot.Element.all then
873 Prev : constant Node_Access := Node.Prev;
874 Next : constant Node_Access := Node.Next;
880 Container.Last := Prev;
886 Node.Prev := Pivot.Prev;
890 if Node.Prev = null then
891 Container.First := Node;
893 Node.Prev.Next := Node;
909 procedure Sort (Front, Back : Node_Access) is
910 Pivot : constant Node_Access :=
911 (if Front = null then Container.First else Front.Next);
913 if Pivot /= Back then
914 Partition (Pivot, Back);
920 -- Start of processing for Sort
923 if Container.Length <= 1 then
927 pragma Assert (Container.First.Prev = null);
928 pragma Assert (Container.Last.Next = null);
930 if Container.Busy > 0 then
931 raise Program_Error with
932 "attempt to tamper with cursors (list is busy)";
935 -- Per AI05-0022, the container implementation is required to detect
936 -- element tampering by a generic actual subprogram.
939 B : Natural renames Container.Busy;
940 L : Natural renames Container.Lock;
946 Sort (Front => null, Back => null);
959 pragma Assert (Container.First.Prev = null);
960 pragma Assert (Container.Last.Next = null);
969 function Has_Element (Position : Cursor) return Boolean is
971 pragma Assert (Vet (Position), "bad cursor in Has_Element");
972 return Position.Node /= null;
980 (Container : in out List;
982 New_Item : Element_Type;
983 Position : out Cursor;
984 Count : Count_Type := 1)
986 First_Node : Node_Access;
987 New_Node : Node_Access;
990 if Before.Container /= null then
991 if Before.Container /= Container'Unrestricted_Access then
992 raise Program_Error with
993 "attempt to tamper with cursors (list is busy)";
995 elsif Before.Node = null or else Before.Node.Element = null then
996 raise Program_Error with
997 "Before cursor has no element";
1000 pragma Assert (Vet (Before), "bad cursor in Insert");
1009 if Container.Length > Count_Type'Last - Count then
1010 raise Constraint_Error with "new length exceeds maximum";
1013 if Container.Busy > 0 then
1014 raise Program_Error with
1015 "attempt to tamper with cursors (list is busy)";
1019 -- The element allocator may need an accessibility check in the case
1020 -- the actual type is class-wide or has access discriminants (see
1021 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
1022 -- allocator in the loop below, because the one in this block would
1023 -- have failed already.
1025 pragma Unsuppress (Accessibility_Check);
1027 Element : Element_Access := new Element_Type'(New_Item
);
1030 New_Node
:= new Node_Type
'(Element, null, null);
1031 First_Node := New_Node;
1039 Insert_Internal (Container, Before.Node, New_Node);
1041 for J in 2 .. Count loop
1043 Element : Element_Access := new Element_Type'(New_Item
);
1045 New_Node
:= new Node_Type
'(Element, null, null);
1052 Insert_Internal (Container, Before.Node, New_Node);
1055 Position := Cursor'(Container
'Unchecked_Access, First_Node
);
1059 (Container
: in out List
;
1061 New_Item
: Element_Type
;
1062 Count
: Count_Type
:= 1)
1065 pragma Unreferenced
(Position
);
1067 Insert
(Container
, Before
, New_Item
, Position
, Count
);
1070 ---------------------
1071 -- Insert_Internal --
1072 ---------------------
1074 procedure Insert_Internal
1075 (Container
: in out List
;
1076 Before
: Node_Access
;
1077 New_Node
: Node_Access
)
1080 if Container
.Length
= 0 then
1081 pragma Assert
(Before
= null);
1082 pragma Assert
(Container
.First
= null);
1083 pragma Assert
(Container
.Last
= null);
1085 Container
.First
:= New_Node
;
1086 Container
.Last
:= New_Node
;
1088 elsif Before
= null then
1089 pragma Assert
(Container
.Last
.Next
= null);
1091 Container
.Last
.Next
:= New_Node
;
1092 New_Node
.Prev
:= Container
.Last
;
1094 Container
.Last
:= New_Node
;
1096 elsif Before
= Container
.First
then
1097 pragma Assert
(Container
.First
.Prev
= null);
1099 Container
.First
.Prev
:= New_Node
;
1100 New_Node
.Next
:= Container
.First
;
1102 Container
.First
:= New_Node
;
1105 pragma Assert
(Container
.First
.Prev
= null);
1106 pragma Assert
(Container
.Last
.Next
= null);
1108 New_Node
.Next
:= Before
;
1109 New_Node
.Prev
:= Before
.Prev
;
1111 Before
.Prev
.Next
:= New_Node
;
1112 Before
.Prev
:= New_Node
;
1115 Container
.Length
:= Container
.Length
+ 1;
1116 end Insert_Internal
;
1122 function Is_Empty
(Container
: List
) return Boolean is
1124 return Container
.Length
= 0;
1133 Process
: not null access procedure (Position
: Cursor
))
1135 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
1136 Node
: Node_Access
:= Container
.First
;
1142 while Node
/= null loop
1143 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1157 return List_Iterator_Interfaces.Reversible_Iterator'class
1159 B : Natural renames Container'Unrestricted_Access.all.Busy;
1162 -- The value of the Node component influences the behavior of the First
1163 -- and Last selector functions of the iterator object. When the Node
1164 -- component is null (as is the case here), this means the iterator
1165 -- object was constructed without a start expression. This is a
1166 -- complete iterator, meaning that the iteration starts from the
1167 -- (logical) beginning of the sequence of items.
1169 -- Note: For a forward iterator, Container.First is the beginning, and
1170 -- for a reverse iterator, Container.Last is the beginning.
1172 return It : constant Iterator :=
1173 Iterator'(Limited_Controlled
with
1174 Container
=> Container
'Unrestricted_Access,
1184 return List_Iterator_Interfaces
.Reversible_Iterator
'Class
1186 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
1189 -- It was formerly the case that when Start = No_Element, the partial
1190 -- iterator was defined to behave the same as for a complete iterator,
1191 -- and iterate over the entire sequence of items. However, those
1192 -- semantics were unintuitive and arguably error-prone (it is too easy
1193 -- to accidentally create an endless loop), and so they were changed,
1194 -- per the ARG meeting in Denver on 2011/11. However, there was no
1195 -- consensus about what positive meaning this corner case should have,
1196 -- and so it was decided to simply raise an exception. This does imply,
1197 -- however, that it is not possible to use a partial iterator to specify
1198 -- an empty sequence of items.
1200 if Start
= No_Element
then
1201 raise Constraint_Error
with
1202 "Start position for iterator equals No_Element";
1204 elsif Start
.Container
/= Container
'Unrestricted_Access then
1205 raise Program_Error
with
1206 "Start cursor of Iterate designates wrong list";
1209 pragma Assert
(Vet
(Start
), "Start cursor of Iterate is bad");
1211 -- The value of the Node component influences the behavior of the
1212 -- First and Last selector functions of the iterator object. When
1213 -- the Node component is non-null (as is the case here), it means
1214 -- that this is a partial iteration, over a subset of the complete
1215 -- sequence of items. The iterator object was constructed with
1216 -- a start expression, indicating the position from which the
1217 -- iteration begins. Note that the start position has the same value
1218 -- irrespective of whether this is a forward or reverse iteration.
1220 return It
: constant Iterator
:=
1221 Iterator
'(Limited_Controlled with
1222 Container => Container'Unrestricted_Access,
1234 function Last (Container : List) return Cursor is
1236 if Container.Last = null then
1239 return Cursor'(Container
'Unrestricted_Access, Container
.Last
);
1243 function Last
(Object
: Iterator
) return Cursor
is
1245 -- The value of the iterator object's Node component influences the
1246 -- behavior of the Last (and First) selector function.
1248 -- When the Node component is null, this means the iterator object was
1249 -- constructed without a start expression, in which case the (reverse)
1250 -- iteration starts from the (logical) beginning of the entire sequence
1251 -- (corresponding to Container.Last, for a reverse iterator).
1253 -- Otherwise, this is iteration over a partial sequence of items. When
1254 -- the Node component is non-null, the iterator object was constructed
1255 -- with a start expression, that specifies the position from which the
1256 -- (reverse) partial iteration begins.
1258 if Object
.Node
= null then
1259 return Indefinite_Doubly_Linked_Lists
.Last
(Object
.Container
.all);
1261 return Cursor
'(Object.Container, Object.Node);
1269 function Last_Element (Container : List) return Element_Type is
1271 if Container.Last = null then
1272 raise Constraint_Error with "list is empty";
1274 return Container.Last.Element.all;
1282 function Length (Container : List) return Count_Type is
1284 return Container.Length;
1291 procedure Move (Target : in out List; Source : in out List) is
1293 if Target'Address = Source'Address then
1296 elsif Source.Busy > 0 then
1297 raise Program_Error with
1298 "attempt to tamper with cursors of Source (list is busy)";
1303 Target.First := Source.First;
1304 Source.First := null;
1306 Target.Last := Source.Last;
1307 Source.Last := null;
1309 Target.Length := Source.Length;
1318 procedure Next (Position : in out Cursor) is
1320 Position := Next (Position);
1323 function Next (Position : Cursor) return Cursor is
1325 if Position.Node = null then
1329 pragma Assert (Vet (Position), "bad cursor in Next");
1332 Next_Node : constant Node_Access := Position.Node.Next;
1334 if Next_Node = null then
1337 return Cursor'(Position
.Container
, Next_Node
);
1343 function Next
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
1345 if Position
.Container
= null then
1347 elsif Position
.Container
/= Object
.Container
then
1348 raise Program_Error
with
1349 "Position cursor of Next designates wrong list";
1351 return Next
(Position
);
1360 (Container
: in out List
;
1361 New_Item
: Element_Type
;
1362 Count
: Count_Type
:= 1)
1365 Insert
(Container
, First
(Container
), New_Item
, Count
);
1372 procedure Previous
(Position
: in out Cursor
) is
1374 Position
:= Previous
(Position
);
1377 function Previous
(Position
: Cursor
) return Cursor
is
1379 if Position
.Node
= null then
1383 pragma Assert
(Vet
(Position
), "bad cursor in Previous");
1386 Prev_Node
: constant Node_Access
:= Position
.Node
.Prev
;
1388 if Prev_Node
= null then
1391 return Cursor
'(Position.Container, Prev_Node);
1397 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1399 if Position.Container = null then
1401 elsif Position.Container /= Object.Container then
1402 raise Program_Error with
1403 "Position cursor of Previous designates wrong list";
1405 return Previous (Position);
1413 procedure Query_Element
1415 Process : not null access procedure (Element : Element_Type))
1418 if Position.Node = null then
1419 raise Constraint_Error with
1420 "Position cursor has no element";
1422 elsif Position.Node.Element = null then
1423 raise Program_Error with
1424 "Position cursor has no element";
1427 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1430 C : List renames Position.Container.all'Unrestricted_Access.all;
1431 B : Natural renames C.Busy;
1432 L : Natural renames C.Lock;
1439 Process (Position.Node.Element.all);
1458 (Stream : not null access Root_Stream_Type'Class;
1461 N : Count_Type'Base;
1467 Count_Type'Base'Read
(Stream
, N
);
1474 Element
: Element_Access
:=
1475 new Element_Type
'(Element_Type'Input (Stream));
1477 Dst := new Node_Type'(Element
, null, null);
1488 while Item
.Length
< N
loop
1490 Element
: Element_Access
:=
1491 new Element_Type
'(Element_Type'Input (Stream));
1493 Dst := new Node_Type'(Element
, Next
=> null, Prev
=> Item
.Last
);
1500 Item
.Last
.Next
:= Dst
;
1502 Item
.Length
:= Item
.Length
+ 1;
1507 (Stream
: not null access Root_Stream_Type
'Class;
1511 raise Program_Error
with "attempt to stream list cursor";
1515 (Stream
: not null access Root_Stream_Type
'Class;
1516 Item
: out Reference_Type
)
1519 raise Program_Error
with "attempt to stream reference";
1523 (Stream
: not null access Root_Stream_Type
'Class;
1524 Item
: out Constant_Reference_Type
)
1527 raise Program_Error
with "attempt to stream reference";
1535 (Container
: aliased in out List
;
1536 Position
: Cursor
) return Reference_Type
1539 if Position
.Container
= null then
1540 raise Constraint_Error
with "Position cursor has no element";
1542 elsif Position
.Container
/= Container
'Unrestricted_Access then
1543 raise Program_Error
with
1544 "Position cursor designates wrong container";
1546 elsif Position
.Node
.Element
= null then
1547 raise Program_Error
with "Node has no element";
1550 pragma Assert
(Vet
(Position
), "bad cursor in function Reference");
1553 C
: List
renames Position
.Container
.all;
1554 B
: Natural renames C
.Busy
;
1555 L
: Natural renames C
.Lock
;
1557 return R
: constant Reference_Type
:=
1558 (Element
=> Position
.Node
.Element
.all'Access,
1559 Control
=> (Controlled
with Position
.Container
))
1568 ---------------------
1569 -- Replace_Element --
1570 ---------------------
1572 procedure Replace_Element
1573 (Container
: in out List
;
1575 New_Item
: Element_Type
)
1578 if Position
.Container
= null then
1579 raise Constraint_Error
with "Position cursor has no element";
1581 elsif Position
.Container
/= Container
'Unchecked_Access then
1582 raise Program_Error
with
1583 "Position cursor designates wrong container";
1585 elsif Container
.Lock
> 0 then
1586 raise Program_Error
with
1587 "attempt to tamper with elements (list is locked)";
1589 elsif Position
.Node
.Element
= null then
1590 raise Program_Error
with
1591 "Position cursor has no element";
1594 pragma Assert
(Vet
(Position
), "bad cursor in Replace_Element");
1597 -- The element allocator may need an accessibility check in the
1598 -- case the actual type is class-wide or has access discriminants
1599 -- (see RM 4.8(10.1) and AI12-0035).
1601 pragma Unsuppress
(Accessibility_Check
);
1603 X
: Element_Access
:= Position
.Node
.Element
;
1606 Position
.Node
.Element
:= new Element_Type
'(New_Item);
1610 end Replace_Element;
1612 ----------------------
1613 -- Reverse_Elements --
1614 ----------------------
1616 procedure Reverse_Elements (Container : in out List) is
1617 I : Node_Access := Container.First;
1618 J : Node_Access := Container.Last;
1620 procedure Swap (L, R : Node_Access);
1626 procedure Swap (L, R : Node_Access) is
1627 LN : constant Node_Access := L.Next;
1628 LP : constant Node_Access := L.Prev;
1630 RN : constant Node_Access := R.Next;
1631 RP : constant Node_Access := R.Prev;
1646 pragma Assert (RP = L);
1660 -- Start of processing for Reverse_Elements
1663 if Container.Length <= 1 then
1667 pragma Assert (Container.First.Prev = null);
1668 pragma Assert (Container.Last.Next = null);
1670 if Container.Busy > 0 then
1671 raise Program_Error with
1672 "attempt to tamper with cursors (list is busy)";
1675 Container.First := J;
1676 Container.Last := I;
1678 Swap (L => I, R => J);
1686 Swap (L => J, R => I);
1695 pragma Assert (Container.First.Prev = null);
1696 pragma Assert (Container.Last.Next = null);
1697 end Reverse_Elements;
1703 function Reverse_Find
1705 Item : Element_Type;
1706 Position : Cursor := No_Element) return Cursor
1708 Node : Node_Access := Position.Node;
1712 Node := Container.Last;
1715 if Node.Element = null then
1716 raise Program_Error with "Position cursor has no element";
1718 elsif Position.Container /= Container'Unrestricted_Access then
1719 raise Program_Error with
1720 "Position cursor designates wrong container";
1723 pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1727 -- Per AI05-0022, the container implementation is required to detect
1728 -- element tampering by a generic actual subprogram.
1731 B : Natural renames Container'Unrestricted_Access.Busy;
1732 L : Natural renames Container'Unrestricted_Access.Lock;
1734 Result : Node_Access;
1741 while Node /= null loop
1742 if Node.Element.all = Item then
1753 if Result = null then
1756 return Cursor'(Container
'Unrestricted_Access, Result
);
1768 ---------------------
1769 -- Reverse_Iterate --
1770 ---------------------
1772 procedure Reverse_Iterate
1774 Process
: not null access procedure (Position
: Cursor
))
1776 C
: List
renames Container
'Unrestricted_Access.all;
1777 B
: Natural renames C
.Busy
;
1779 Node
: Node_Access
:= Container
.Last
;
1785 while Node
/= null loop
1786 Process
(Cursor
'(Container'Unrestricted_Access, Node));
1796 end Reverse_Iterate;
1803 (Target : in out List;
1805 Source : in out List)
1808 if Before.Container /= null then
1809 if Before.Container /= Target'Unrestricted_Access then
1810 raise Program_Error with
1811 "Before cursor designates wrong container";
1813 elsif Before.Node = null or else Before.Node.Element = null then
1814 raise Program_Error with
1815 "Before cursor has no element";
1818 pragma Assert (Vet (Before), "bad cursor in Splice");
1822 if Target'Address = Source'Address or else Source.Length = 0 then
1825 elsif Target.Length > Count_Type'Last - Source.Length then
1826 raise Constraint_Error with "new length exceeds maximum";
1828 elsif Target.Busy > 0 then
1829 raise Program_Error with
1830 "attempt to tamper with cursors of Target (list is busy)";
1832 elsif Source.Busy > 0 then
1833 raise Program_Error with
1834 "attempt to tamper with cursors of Source (list is busy)";
1837 Splice_Internal (Target, Before.Node, Source);
1842 (Container : in out List;
1847 if Before.Container /= null then
1848 if Before.Container /= Container'Unchecked_Access then
1849 raise Program_Error with
1850 "Before cursor designates wrong container";
1852 elsif Before.Node = null or else Before.Node.Element = null then
1853 raise Program_Error with
1854 "Before cursor has no element";
1857 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1861 if Position.Node = null then
1862 raise Constraint_Error with "Position cursor has no element";
1865 if Position.Node.Element = null then
1866 raise Program_Error with "Position cursor has no element";
1869 if Position.Container /= Container'Unrestricted_Access then
1870 raise Program_Error with
1871 "Position cursor designates wrong container";
1874 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1876 if Position.Node = Before.Node
1877 or else Position.Node.Next = Before.Node
1882 pragma Assert (Container.Length >= 2);
1884 if Container.Busy > 0 then
1885 raise Program_Error with
1886 "attempt to tamper with cursors (list is busy)";
1889 if Before.Node = null then
1890 pragma Assert (Position.Node /= Container.Last);
1892 if Position.Node = Container.First then
1893 Container.First := Position.Node.Next;
1894 Container.First.Prev := null;
1896 Position.Node.Prev.Next := Position.Node.Next;
1897 Position.Node.Next.Prev := Position.Node.Prev;
1900 Container.Last.Next := Position.Node;
1901 Position.Node.Prev := Container.Last;
1903 Container.Last := Position.Node;
1904 Container.Last.Next := null;
1909 if Before.Node = Container.First then
1910 pragma Assert (Position.Node /= Container.First);
1912 if Position.Node = Container.Last then
1913 Container.Last := Position.Node.Prev;
1914 Container.Last.Next := null;
1916 Position.Node.Prev.Next := Position.Node.Next;
1917 Position.Node.Next.Prev := Position.Node.Prev;
1920 Container.First.Prev := Position.Node;
1921 Position.Node.Next := Container.First;
1923 Container.First := Position.Node;
1924 Container.First.Prev := null;
1929 if Position.Node = Container.First then
1930 Container.First := Position.Node.Next;
1931 Container.First.Prev := null;
1933 elsif Position.Node = Container.Last then
1934 Container.Last := Position.Node.Prev;
1935 Container.Last.Next := null;
1938 Position.Node.Prev.Next := Position.Node.Next;
1939 Position.Node.Next.Prev := Position.Node.Prev;
1942 Before.Node.Prev.Next := Position.Node;
1943 Position.Node.Prev := Before.Node.Prev;
1945 Before.Node.Prev := Position.Node;
1946 Position.Node.Next := Before.Node;
1948 pragma Assert (Container.First.Prev = null);
1949 pragma Assert (Container.Last.Next = null);
1953 (Target : in out List;
1955 Source : in out List;
1956 Position : in out Cursor)
1959 if Target'Address = Source'Address then
1960 Splice (Target, Before, Position);
1964 if Before.Container /= null then
1965 if Before.Container /= Target'Unrestricted_Access then
1966 raise Program_Error with
1967 "Before cursor designates wrong container";
1970 if Before.Node = null
1971 or else Before.Node.Element = null
1973 raise Program_Error with
1974 "Before cursor has no element";
1977 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1980 if Position.Node = null then
1981 raise Constraint_Error with "Position cursor has no element";
1984 if Position.Node.Element = null then
1985 raise Program_Error with
1986 "Position cursor has no element";
1989 if Position.Container /= Source'Unrestricted_Access then
1990 raise Program_Error with
1991 "Position cursor designates wrong container";
1994 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1996 if Target.Length = Count_Type'Last then
1997 raise Constraint_Error with "Target is full";
2000 if Target.Busy > 0 then
2001 raise Program_Error with
2002 "attempt to tamper with cursors of Target (list is busy)";
2005 if Source.Busy > 0 then
2006 raise Program_Error with
2007 "attempt to tamper with cursors of Source (list is busy)";
2010 Splice_Internal (Target, Before.Node, Source, Position.Node);
2011 Position.Container := Target'Unchecked_Access;
2014 ---------------------
2015 -- Splice_Internal --
2016 ---------------------
2018 procedure Splice_Internal
2019 (Target : in out List;
2020 Before : Node_Access;
2021 Source : in out List)
2024 -- This implements the corresponding Splice operation, after the
2025 -- parameters have been vetted, and corner-cases disposed of.
2027 pragma Assert (Target'Address /= Source'Address);
2028 pragma Assert (Source.Length > 0);
2029 pragma Assert (Source.First /= null);
2030 pragma Assert (Source.First.Prev = null);
2031 pragma Assert (Source.Last /= null);
2032 pragma Assert (Source.Last.Next = null);
2033 pragma Assert (Target.Length <= Count_Type'Last - Source.Length);
2035 if Target.Length = 0 then
2036 pragma Assert (Before = null);
2037 pragma Assert (Target.First = null);
2038 pragma Assert (Target.Last = null);
2040 Target.First := Source.First;
2041 Target.Last := Source.Last;
2043 elsif Before = null then
2044 pragma Assert (Target.Last.Next = null);
2046 Target.Last.Next := Source.First;
2047 Source.First.Prev := Target.Last;
2049 Target.Last := Source.Last;
2051 elsif Before = Target.First then
2052 pragma Assert (Target.First.Prev = null);
2054 Source.Last.Next := Target.First;
2055 Target.First.Prev := Source.Last;
2057 Target.First := Source.First;
2060 pragma Assert (Target.Length >= 2);
2061 Before.Prev.Next := Source.First;
2062 Source.First.Prev := Before.Prev;
2064 Before.Prev := Source.Last;
2065 Source.Last.Next := Before;
2068 Source.First := null;
2069 Source.Last := null;
2071 Target.Length := Target.Length + Source.Length;
2073 end Splice_Internal;
2075 procedure Splice_Internal
2076 (Target : in out List;
2077 Before : Node_Access; -- node of Target
2078 Source : in out List;
2079 Position : Node_Access) -- node of Source
2082 -- This implements the corresponding Splice operation, after the
2083 -- parameters have been vetted.
2085 pragma Assert (Target'Address /= Source'Address);
2086 pragma Assert (Target.Length < Count_Type'Last);
2087 pragma Assert (Source.Length > 0);
2088 pragma Assert (Source.First /= null);
2089 pragma Assert (Source.First.Prev = null);
2090 pragma Assert (Source.Last /= null);
2091 pragma Assert (Source.Last.Next = null);
2092 pragma Assert (Position /= null);
2094 if Position = Source.First then
2095 Source.First := Position.Next;
2097 if Position = Source.Last then
2098 pragma Assert (Source.First = null);
2099 pragma Assert (Source.Length = 1);
2100 Source.Last := null;
2103 Source.First.Prev := null;
2106 elsif Position = Source.Last then
2107 pragma Assert (Source.Length >= 2);
2108 Source.Last := Position.Prev;
2109 Source.Last.Next := null;
2112 pragma Assert (Source.Length >= 3);
2113 Position.Prev.Next := Position.Next;
2114 Position.Next.Prev := Position.Prev;
2117 if Target.Length = 0 then
2118 pragma Assert (Before = null);
2119 pragma Assert (Target.First = null);
2120 pragma Assert (Target.Last = null);
2122 Target.First := Position;
2123 Target.Last := Position;
2125 Target.First.Prev := null;
2126 Target.Last.Next := null;
2128 elsif Before = null then
2129 pragma Assert (Target.Last.Next = null);
2130 Target.Last.Next := Position;
2131 Position.Prev := Target.Last;
2133 Target.Last := Position;
2134 Target.Last.Next := null;
2136 elsif Before = Target.First then
2137 pragma Assert (Target.First.Prev = null);
2138 Target.First.Prev := Position;
2139 Position.Next := Target.First;
2141 Target.First := Position;
2142 Target.First.Prev := null;
2145 pragma Assert (Target.Length >= 2);
2146 Before.Prev.Next := Position;
2147 Position.Prev := Before.Prev;
2149 Before.Prev := Position;
2150 Position.Next := Before;
2153 Target.Length := Target.Length + 1;
2154 Source.Length := Source.Length - 1;
2155 end Splice_Internal;
2162 (Container : in out List;
2166 if I.Node = null then
2167 raise Constraint_Error with "I cursor has no element";
2170 if J.Node = null then
2171 raise Constraint_Error with "J cursor has no element";
2174 if I.Container /= Container'Unchecked_Access then
2175 raise Program_Error with "I cursor designates wrong container";
2178 if J.Container /= Container'Unchecked_Access then
2179 raise Program_Error with "J cursor designates wrong container";
2182 if I.Node = J.Node then
2186 if Container.Lock > 0 then
2187 raise Program_Error with
2188 "attempt to tamper with elements (list is locked)";
2191 pragma Assert (Vet (I), "bad I cursor in Swap");
2192 pragma Assert (Vet (J), "bad J cursor in Swap");
2195 EI_Copy : constant Element_Access := I.Node.Element;
2198 I.Node.Element := J.Node.Element;
2199 J.Node.Element := EI_Copy;
2207 procedure Swap_Links
2208 (Container : in out List;
2212 if I.Node = null then
2213 raise Constraint_Error with "I cursor has no element";
2216 if J.Node = null then
2217 raise Constraint_Error with "J cursor has no element";
2220 if I.Container /= Container'Unrestricted_Access then
2221 raise Program_Error with "I cursor designates wrong container";
2224 if J.Container /= Container'Unrestricted_Access then
2225 raise Program_Error with "J cursor designates wrong container";
2228 if I.Node = J.Node then
2232 if Container.Busy > 0 then
2233 raise Program_Error with
2234 "attempt to tamper with cursors (list is busy)";
2237 pragma Assert (Vet (I), "bad I cursor in Swap_Links");
2238 pragma Assert (Vet (J), "bad J cursor in Swap_Links");
2241 I_Next : constant Cursor := Next (I);
2245 Splice (Container, Before => I, Position => J);
2249 J_Next : constant Cursor := Next (J);
2253 Splice (Container, Before => J, Position => I);
2256 pragma Assert (Container.Length >= 3);
2258 Splice (Container, Before => I_Next, Position => J);
2259 Splice (Container, Before => J_Next, Position => I);
2265 pragma Assert (Container.First.Prev = null);
2266 pragma Assert (Container.Last.Next = null);
2269 --------------------
2270 -- Update_Element --
2271 --------------------
2273 procedure Update_Element
2274 (Container : in out List;
2276 Process : not null access procedure (Element : in out Element_Type))
2279 if Position.Node = null then
2280 raise Constraint_Error with "Position cursor has no element";
2283 if Position.Node.Element = null then
2284 raise Program_Error with
2285 "Position cursor has no element";
2288 if Position.Container /= Container'Unchecked_Access then
2289 raise Program_Error with
2290 "Position cursor designates wrong container";
2293 pragma Assert (Vet (Position), "bad cursor in Update_Element");
2296 B : Natural renames Container.Busy;
2297 L : Natural renames Container.Lock;
2304 Process (Position.Node.Element.all);
2321 function Vet (Position : Cursor) return Boolean is
2323 if Position.Node = null then
2324 return Position.Container = null;
2327 if Position.Container = null then
2331 -- An invariant of a node is that its Previous and Next components can
2332 -- be null, or designate a different node. Also, its element access
2333 -- value must be non-null. Operation Free sets the node access value
2334 -- components of the node to designate the node itself, and the element
2335 -- access value to null, before actually deallocating the node, thus
2336 -- deliberately violating the node invariant. This gives us a simple way
2337 -- to detect a dangling reference to a node.
2339 if Position.Node.Next = Position.Node then
2343 if Position.Node.Prev = Position.Node then
2347 if Position.Node.Element = null then
2351 -- In practice the tests above will detect most instances of a dangling
2352 -- reference. If we get here, it means that the invariants of the
2353 -- designated node are satisfied (they at least appear to be satisfied),
2354 -- so we perform some more tests, to determine whether invariants of the
2355 -- designated list are satisfied too.
2358 L : List renames Position.Container.all;
2361 if L.Length = 0 then
2365 if L.First = null then
2369 if L.Last = null then
2373 if L.First.Prev /= null then
2377 if L.Last.Next /= null then
2381 if Position.Node.Prev = null and then Position.Node /= L.First then
2385 if Position.Node.Next = null and then Position.Node /= L.Last then
2389 if L.Length = 1 then
2390 return L.First = L.Last;
2393 if L.First = L.Last then
2397 if L.First.Next = null then
2401 if L.Last.Prev = null then
2405 if L.First.Next.Prev /= L.First then
2409 if L.Last.Prev.Next /= L.Last then
2413 if L.Length = 2 then
2414 if L.First.Next /= L.Last then
2418 if L.Last.Prev /= L.First then
2425 if L.First.Next = L.Last then
2429 if L.Last.Prev = L.First then
2433 if Position.Node = L.First then
2437 if Position.Node = L.Last then
2441 if Position.Node.Next = null then
2445 if Position.Node.Prev = null then
2449 if Position.Node.Next.Prev /= Position.Node then
2453 if Position.Node.Prev.Next /= Position.Node then
2457 if L.Length = 3 then
2458 if L.First.Next /= Position.Node then
2462 if L.Last.Prev /= Position.Node then
2476 (Stream : not null access Root_Stream_Type'Class;
2479 Node : Node_Access := Item.First;
2482 Count_Type'Base'Write
(Stream
, Item
.Length
);
2484 while Node
/= null loop
2485 Element_Type
'Output (Stream
, Node
.Element
.all);
2491 (Stream
: not null access Root_Stream_Type
'Class;
2495 raise Program_Error
with "attempt to stream list cursor";
2499 (Stream
: not null access Root_Stream_Type
'Class;
2500 Item
: Reference_Type
)
2503 raise Program_Error
with "attempt to stream reference";
2507 (Stream
: not null access Root_Stream_Type
'Class;
2508 Item
: Constant_Reference_Type
)
2511 raise Program_Error
with "attempt to stream reference";
2514 end Ada
.Containers
.Indefinite_Doubly_Linked_Lists
;