1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S --
9 -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada.Unchecked_Deallocation;
32 with System; use type System.Address;
34 package body Ada.Containers.Doubly_Linked_Lists is
36 type Iterator is new Limited_Controlled and
37 List_Iterator_Interfaces.Reversible_Iterator with
39 Container : List_Access;
43 overriding procedure Finalize (Object : in out Iterator);
45 overriding function First (Object : Iterator) return Cursor;
46 overriding function Last (Object : Iterator) return Cursor;
48 overriding function Next
50 Position : Cursor) return Cursor;
52 overriding function Previous
54 Position : Cursor) return Cursor;
56 -----------------------
57 -- Local Subprograms --
58 -----------------------
60 procedure Free (X : in out Node_Access);
62 procedure Insert_Internal
63 (Container : in out List;
65 New_Node : Node_Access);
67 procedure Splice_Internal
68 (Target : in out List;
70 Source : in out List);
72 procedure Splice_Internal
73 (Target : in out List;
76 Position : Node_Access);
78 function Vet (Position : Cursor) return Boolean;
79 -- Checks invariants of the cursor and its designated container, as a
80 -- simple way of detecting dangling references (see operation Free for a
81 -- description of the detection mechanism), returning True if all checks
82 -- pass. Invocations of Vet are used here as the argument of pragma Assert,
83 -- so the checks are performed only when assertions are enabled.
89 function "=" (Left, Right : List) return Boolean is
90 BL : Natural renames Left'Unrestricted_Access.Busy;
91 LL : Natural renames Left'Unrestricted_Access.Lock;
93 BR : Natural renames Right'Unrestricted_Access.Busy;
94 LR : Natural renames Right'Unrestricted_Access.Lock;
101 if Left'Address = Right'Address then
105 if Left.Length /= Right.Length then
109 -- Per AI05-0022, the container implementation is required to detect
110 -- element tampering by a generic actual subprogram.
121 for J in 1 .. Left.Length loop
122 if L.Element /= R.Element then
154 procedure Adjust (Container : in out List) is
155 Src : Node_Access := Container.First;
159 pragma Assert (Container.Last = null);
160 pragma Assert (Container.Length = 0);
161 pragma Assert (Container.Busy = 0);
162 pragma Assert (Container.Lock = 0);
166 pragma Assert (Container.First.Prev = null);
167 pragma Assert (Container.Last.Next = null);
168 pragma Assert (Container.Length > 0);
170 Container.First := null;
171 Container.Last := null;
172 Container.Length := 0;
176 Container.First := new Node_Type'(Src.Element, null, null);
177 Container.Last := Container.First;
178 Container.Length := 1;
181 while Src /= null loop
182 Container.Last.Next := new Node_Type'(Element => Src.Element,
183 Prev => Container.Last,
185 Container.Last := Container.Last.Next;
186 Container.Length := Container.Length + 1;
192 procedure Adjust (Control : in out Reference_Control_Type) is
194 if Control.Container /= null then
196 C : List renames Control.Container.all;
197 B : Natural renames C.Busy;
198 L : Natural renames C.Lock;
211 (Container : in out List;
212 New_Item : Element_Type;
213 Count : Count_Type := 1)
216 Insert (Container, No_Element, New_Item, Count);
223 procedure Assign (Target : in out List; Source : List) is
227 if Target'Address = Source'Address then
233 Node := Source.First;
234 while Node /= null loop
235 Target.Append (Node.Element);
244 procedure Clear (Container : in out List) is
248 if Container.Length = 0 then
249 pragma Assert (Container.First = null);
250 pragma Assert (Container.Last = null);
251 pragma Assert (Container.Busy = 0);
252 pragma Assert (Container.Lock = 0);
256 pragma Assert (Container.First.Prev = null);
257 pragma Assert (Container.Last.Next = null);
259 if Container.Busy > 0 then
260 raise Program_Error with
261 "attempt to tamper with cursors (list is busy)";
264 while Container.Length > 1 loop
265 X := Container.First;
266 pragma Assert (X.Next.Prev = Container.First);
268 Container.First := X.Next;
269 Container.First.Prev := null;
271 Container.Length := Container.Length - 1;
276 X := Container.First;
277 pragma Assert (X = Container.Last);
279 Container.First := null;
280 Container.Last := null;
281 Container.Length := 0;
283 pragma Warnings (Off);
285 pragma Warnings (On);
288 ------------------------
289 -- Constant_Reference --
290 ------------------------
292 function Constant_Reference
293 (Container : aliased List;
294 Position : Cursor) return Constant_Reference_Type
297 if Position.Container = null then
298 raise Constraint_Error with "Position cursor has no element";
301 if Position.Container /= Container'Unrestricted_Access then
302 raise Program_Error with
303 "Position cursor designates wrong container";
306 pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
309 C : List renames Position.Container.all;
310 B : Natural renames C.Busy;
311 L : Natural renames C.Lock;
313 return R : constant Constant_Reference_Type :=
314 (Element => Position.Node.Element'Access,
315 Control => (Controlled with Container'Unrestricted_Access))
321 end Constant_Reference;
329 Item : Element_Type) return Boolean
332 return Find (Container, Item) /= No_Element;
339 function Copy (Source : List) return List is
341 return Target : List do
342 Target.Assign (Source);
351 (Container : in out List;
352 Position : in out Cursor;
353 Count : Count_Type := 1)
358 if Position.Node = null then
359 raise Constraint_Error with
360 "Position cursor has no element";
363 if Position.Container /= Container'Unrestricted_Access then
364 raise Program_Error with
365 "Position cursor designates wrong container";
368 pragma Assert (Vet (Position), "bad cursor in Delete");
370 if Position.Node = Container.First then
371 Delete_First (Container, Count);
372 Position := No_Element; -- Post-York behavior
377 Position := No_Element; -- Post-York behavior
381 if Container.Busy > 0 then
382 raise Program_Error with
383 "attempt to tamper with cursors (list is busy)";
386 for Index in 1 .. Count loop
388 Container.Length := Container.Length - 1;
390 if X = Container.Last then
391 Position := No_Element;
393 Container.Last := X.Prev;
394 Container.Last.Next := null;
400 Position.Node := X.Next;
402 X.Next.Prev := X.Prev;
403 X.Prev.Next := X.Next;
408 -- The following comment is unacceptable, more detail needed ???
410 Position := No_Element; -- Post-York behavior
417 procedure Delete_First
418 (Container : in out List;
419 Count : Count_Type := 1)
424 if Count >= Container.Length then
433 if Container.Busy > 0 then
434 raise Program_Error with
435 "attempt to tamper with cursors (list is busy)";
438 for J in 1 .. Count loop
439 X := Container.First;
440 pragma Assert (X.Next.Prev = Container.First);
442 Container.First := X.Next;
443 Container.First.Prev := null;
445 Container.Length := Container.Length - 1;
455 procedure Delete_Last
456 (Container : in out List;
457 Count : Count_Type := 1)
462 if Count >= Container.Length then
471 if Container.Busy > 0 then
472 raise Program_Error with
473 "attempt to tamper with cursors (list is busy)";
476 for J in 1 .. Count loop
478 pragma Assert (X.Prev.Next = Container.Last);
480 Container.Last := X.Prev;
481 Container.Last.Next := null;
483 Container.Length := Container.Length - 1;
493 function Element (Position : Cursor) return Element_Type is
495 if Position.Node = null then
496 raise Constraint_Error with
497 "Position cursor has no element";
499 pragma Assert (Vet (Position), "bad cursor in Element");
501 return Position.Node.Element;
509 procedure Finalize (Object : in out Iterator) is
511 if Object.Container /= null then
513 B : Natural renames Object.Container.all.Busy;
520 procedure Finalize (Control : in out Reference_Control_Type) is
522 if Control.Container /= null then
524 C : List renames Control.Container.all;
525 B : Natural renames C.Busy;
526 L : Natural renames C.Lock;
532 Control.Container := null;
543 Position : Cursor := No_Element) return Cursor
545 Node : Node_Access := Position.Node;
549 Node := Container.First;
552 if Position.Container /= Container'Unrestricted_Access then
553 raise Program_Error with
554 "Position cursor designates wrong container";
556 pragma Assert (Vet (Position), "bad cursor in Find");
560 -- Per AI05-0022, the container implementation is required to detect
561 -- element tampering by a generic actual subprogram.
564 B : Natural renames Container'Unrestricted_Access.Busy;
565 L : Natural renames Container'Unrestricted_Access.Lock;
567 Result : Node_Access;
574 while Node /= null loop
575 if Node.Element = Item then
586 if Result = null then
589 return Cursor'(Container'Unrestricted_Access, Result);
604 function First (Container : List) return Cursor is
606 if Container.First = null then
609 return Cursor'(Container'Unrestricted_Access, Container.First);
613 function First (Object : Iterator) return Cursor is
615 -- The value of the iterator object's Node component influences the
616 -- behavior of the First (and Last) selector function.
618 -- When the Node component is null, this means the iterator object was
619 -- constructed without a start expression, in which case the (forward)
620 -- iteration starts from the (logical) beginning of the entire sequence
621 -- of items (corresponding to Container.First, for a forward iterator).
623 -- Otherwise, this is iteration over a partial sequence of items. When
624 -- the Node component is non-null, the iterator object was constructed
625 -- with a start expression, that specifies the position from which the
626 -- (forward) partial iteration begins.
628 if Object.Node = null then
629 return Doubly_Linked_Lists.First (Object.Container.all);
631 return Cursor'(Object.Container, Object.Node);
639 function First_Element (Container : List) return Element_Type is
641 if Container.First = null then
642 raise Constraint_Error with "list is empty";
644 return Container.First.Element;
652 procedure Free (X : in out Node_Access) is
653 procedure Deallocate is
654 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
657 -- While a node is in use, as an active link in a list, its Previous and
658 -- Next components must be null, or designate a different node; this is
659 -- a node invariant. Before actually deallocating the node, we set both
660 -- access value components of the node to point to the node itself, thus
661 -- falsifying the node invariant. Subprogram Vet inspects the value of
662 -- the node components when interrogating the node, in order to detect
663 -- whether the cursor's node access value is dangling.
665 -- Note that we have no guarantee that the storage for the node isn't
666 -- modified when it is deallocated, but there are other tests that Vet
667 -- does if node invariants appear to be satisifed. However, in practice
668 -- this simple test works well enough, detecting dangling references
669 -- immediately, without needing further interrogation.
677 ---------------------
678 -- Generic_Sorting --
679 ---------------------
681 package body Generic_Sorting is
687 function Is_Sorted (Container : List) return Boolean is
688 B : Natural renames Container'Unrestricted_Access.Busy;
689 L : Natural renames Container'Unrestricted_Access.Lock;
695 -- Per AI05-0022, the container implementation is required to detect
696 -- element tampering by a generic actual subprogram.
701 Node := Container.First;
703 for Idx in 2 .. Container.Length loop
704 if Node.Next.Element < Node.Element then
729 (Target : in out List;
730 Source : in out List)
733 -- The semantics of Merge changed slightly per AI05-0021. It was
734 -- originally the case that if Target and Source denoted the same
735 -- container object, then the GNAT implementation of Merge did
736 -- nothing. However, it was argued that RM05 did not precisely
737 -- specify the semantics for this corner case. The decision of the
738 -- ARG was that if Target and Source denote the same non-empty
739 -- container object, then Program_Error is raised.
741 if Source.Is_Empty then
745 if Target'Address = Source'Address then
746 raise Program_Error with
747 "Target and Source denote same non-empty container";
750 if Target.Length > Count_Type'Last - Source.Length then
751 raise Constraint_Error with "new length exceeds maximum";
754 if Target.Busy > 0 then
755 raise Program_Error with
756 "attempt to tamper with cursors of Target (list is busy)";
759 if Source.Busy > 0 then
760 raise Program_Error with
761 "attempt to tamper with cursors of Source (list is busy)";
764 -- Per AI05-0022, the container implementation is required to detect
765 -- element tampering by a generic actual subprogram.
768 TB : Natural renames Target.Busy;
769 TL : Natural renames Target.Lock;
771 SB : Natural renames Source.Busy;
772 SL : Natural renames Source.Lock;
774 LI, RI, RJ : Node_Access;
785 while RI /= null loop
786 pragma Assert (RI.Next = null
787 or else not (RI.Next.Element < RI.Element));
790 Splice_Internal (Target, null, Source);
794 pragma Assert (LI.Next = null
795 or else not (LI.Next.Element < LI.Element));
797 if RI.Element < LI.Element then
800 Splice_Internal (Target, LI, Source, RJ);
829 procedure Sort (Container : in out List) is
831 procedure Partition (Pivot : Node_Access; Back : Node_Access);
833 procedure Sort (Front, Back : Node_Access);
839 procedure Partition (Pivot : Node_Access; Back : Node_Access) is
844 while Node /= Back loop
845 if Node.Element < Pivot.Element then
847 Prev : constant Node_Access := Node.Prev;
848 Next : constant Node_Access := Node.Next;
854 Container.Last := Prev;
860 Node.Prev := Pivot.Prev;
864 if Node.Prev = null then
865 Container.First := Node;
867 Node.Prev.Next := Node;
883 procedure Sort (Front, Back : Node_Access) is
884 Pivot : constant Node_Access :=
885 (if Front = null then Container.First else Front.Next);
887 if Pivot /= Back then
888 Partition (Pivot, Back);
894 -- Start of processing for Sort
897 if Container.Length <= 1 then
901 pragma Assert (Container.First.Prev = null);
902 pragma Assert (Container.Last.Next = null);
904 if Container.Busy > 0 then
905 raise Program_Error with
906 "attempt to tamper with cursors (list is busy)";
909 -- Per AI05-0022, the container implementation is required to detect
910 -- element tampering by a generic actual subprogram.
913 B : Natural renames Container.Busy;
914 L : Natural renames Container.Lock;
920 Sort (Front => null, Back => null);
932 pragma Assert (Container.First.Prev = null);
933 pragma Assert (Container.Last.Next = null);
942 function Has_Element (Position : Cursor) return Boolean is
944 pragma Assert (Vet (Position), "bad cursor in Has_Element");
945 return Position.Node /= null;
953 (Container : in out List;
955 New_Item : Element_Type;
956 Position : out Cursor;
957 Count : Count_Type := 1)
959 New_Node : Node_Access;
962 if Before.Container /= null then
963 if Before.Container /= Container'Unrestricted_Access then
964 raise Program_Error with
965 "Before cursor designates wrong list";
967 pragma Assert (Vet (Before), "bad cursor in Insert");
975 elsif Container.Length > Count_Type'Last - Count then
976 raise Constraint_Error with "new length exceeds maximum";
978 elsif Container.Busy > 0 then
979 raise Program_Error with
980 "attempt to tamper with cursors (list is busy)";
983 New_Node := new Node_Type'(New_Item, null, null);
984 Insert_Internal (Container, Before.Node, New_Node);
986 Position := Cursor'(Container'Unchecked_Access, New_Node);
988 for J in 2 .. Count loop
989 New_Node := new Node_Type'(New_Item, null, null);
990 Insert_Internal (Container, Before.Node, New_Node);
996 (Container : in out List;
998 New_Item : Element_Type;
999 Count : Count_Type := 1)
1002 pragma Unreferenced (Position);
1004 Insert (Container, Before, New_Item, Position, Count);
1008 (Container : in out List;
1010 Position : out Cursor;
1011 Count : Count_Type := 1)
1013 New_Node : Node_Access;
1016 if Before.Container /= null then
1017 if Before.Container /= Container'Unrestricted_Access then
1018 raise Program_Error with
1019 "Before cursor designates wrong list";
1021 pragma Assert (Vet (Before), "bad cursor in Insert");
1030 if Container.Length > Count_Type'Last - Count then
1031 raise Constraint_Error with "new length exceeds maximum";
1033 elsif Container.Busy > 0 then
1034 raise Program_Error with
1035 "attempt to tamper with cursors (list is busy)";
1038 New_Node := new Node_Type;
1039 Insert_Internal (Container, Before.Node, New_Node);
1041 Position := Cursor'(Container'Unchecked_Access, New_Node);
1043 for J in 2 .. Count loop
1044 New_Node := new Node_Type;
1045 Insert_Internal (Container, Before.Node, New_Node);
1050 ---------------------
1051 -- Insert_Internal --
1052 ---------------------
1054 procedure Insert_Internal
1055 (Container : in out List;
1056 Before : Node_Access;
1057 New_Node : Node_Access)
1060 if Container.Length = 0 then
1061 pragma Assert (Before = null);
1062 pragma Assert (Container.First = null);
1063 pragma Assert (Container.Last = null);
1065 Container.First := New_Node;
1066 Container.Last := New_Node;
1068 elsif Before = null then
1069 pragma Assert (Container.Last.Next = null);
1071 Container.Last.Next := New_Node;
1072 New_Node.Prev := Container.Last;
1074 Container.Last := New_Node;
1076 elsif Before = Container.First then
1077 pragma Assert (Container.First.Prev = null);
1079 Container.First.Prev := New_Node;
1080 New_Node.Next := Container.First;
1082 Container.First := New_Node;
1085 pragma Assert (Container.First.Prev = null);
1086 pragma Assert (Container.Last.Next = null);
1088 New_Node.Next := Before;
1089 New_Node.Prev := Before.Prev;
1091 Before.Prev.Next := New_Node;
1092 Before.Prev := New_Node;
1095 Container.Length := Container.Length + 1;
1096 end Insert_Internal;
1102 function Is_Empty (Container : List) return Boolean is
1104 return Container.Length = 0;
1113 Process : not null access procedure (Position : Cursor))
1115 B : Natural renames Container'Unrestricted_Access.all.Busy;
1116 Node : Node_Access := Container.First;
1122 while Node /= null loop
1123 Process (Cursor'(Container'Unrestricted_Access, Node));
1135 function Iterate (Container : List)
1136 return List_Iterator_Interfaces.Reversible_Iterator'Class
1138 B : Natural renames Container'Unrestricted_Access.all.Busy;
1141 -- The value of the Node component influences the behavior of the First
1142 -- and Last selector functions of the iterator object. When the Node
1143 -- component is null (as is the case here), this means the iterator
1144 -- object was constructed without a start expression. This is a
1145 -- complete iterator, meaning that the iteration starts from the
1146 -- (logical) beginning of the sequence of items.
1148 -- Note: For a forward iterator, Container.First is the beginning, and
1149 -- for a reverse iterator, Container.Last is the beginning.
1151 return It : constant Iterator :=
1152 Iterator'(Limited_Controlled with
1153 Container => Container'Unrestricted_Access,
1160 function Iterate (Container : List; Start : Cursor)
1161 return List_Iterator_Interfaces.Reversible_Iterator'Class
1163 B : Natural renames Container'Unrestricted_Access.all.Busy;
1166 -- It was formerly the case that when Start = No_Element, the partial
1167 -- iterator was defined to behave the same as for a complete iterator,
1168 -- and iterate over the entire sequence of items. However, those
1169 -- semantics were unintuitive and arguably error-prone (it is too easy
1170 -- to accidentally create an endless loop), and so they were changed,
1171 -- per the ARG meeting in Denver on 2011/11. However, there was no
1172 -- consensus about what positive meaning this corner case should have,
1173 -- and so it was decided to simply raise an exception. This does imply,
1174 -- however, that it is not possible to use a partial iterator to specify
1175 -- an empty sequence of items.
1177 if Start = No_Element then
1178 raise Constraint_Error with
1179 "Start position for iterator equals No_Element";
1181 elsif Start.Container /= Container'Unrestricted_Access then
1182 raise Program_Error with
1183 "Start cursor of Iterate designates wrong list";
1186 pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
1188 -- The value of the Node component influences the behavior of the
1189 -- First and Last selector functions of the iterator object. When
1190 -- the Node component is non-null (as is the case here), it means
1191 -- that this is a partial iteration, over a subset of the complete
1192 -- sequence of items. The iterator object was constructed with
1193 -- a start expression, indicating the position from which the
1194 -- iteration begins. Note that the start position has the same value
1195 -- irrespective of whether this is a forward or reverse iteration.
1197 return It : constant Iterator :=
1198 Iterator'(Limited_Controlled with
1199 Container => Container'Unrestricted_Access,
1211 function Last (Container : List) return Cursor is
1213 if Container.Last = null then
1216 return Cursor'(Container'Unrestricted_Access, Container.Last);
1220 function Last (Object : Iterator) return Cursor is
1222 -- The value of the iterator object's Node component influences the
1223 -- behavior of the Last (and First) selector function.
1225 -- When the Node component is null, this means the iterator object was
1226 -- constructed without a start expression, in which case the (reverse)
1227 -- iteration starts from the (logical) beginning of the entire sequence
1228 -- (corresponding to Container.Last, for a reverse iterator).
1230 -- Otherwise, this is iteration over a partial sequence of items. When
1231 -- the Node component is non-null, the iterator object was constructed
1232 -- with a start expression, that specifies the position from which the
1233 -- (reverse) partial iteration begins.
1235 if Object.Node = null then
1236 return Doubly_Linked_Lists.Last (Object.Container.all);
1238 return Cursor'(Object.Container, Object.Node);
1246 function Last_Element (Container : List) return Element_Type is
1248 if Container.Last = null then
1249 raise Constraint_Error with "list is empty";
1251 return Container.Last.Element;
1259 function Length (Container : List) return Count_Type is
1261 return Container.Length;
1269 (Target : in out List;
1270 Source : in out List)
1273 if Target'Address = Source'Address then
1276 elsif Source.Busy > 0 then
1277 raise Program_Error with
1278 "attempt to tamper with cursors of Source (list is busy)";
1283 Target.First := Source.First;
1284 Source.First := null;
1286 Target.Last := Source.Last;
1287 Source.Last := null;
1289 Target.Length := Source.Length;
1298 procedure Next (Position : in out Cursor) is
1300 Position := Next (Position);
1303 function Next (Position : Cursor) return Cursor is
1305 if Position.Node = null then
1309 pragma Assert (Vet (Position), "bad cursor in Next");
1312 Next_Node : constant Node_Access := Position.Node.Next;
1314 if Next_Node = null then
1317 return Cursor'(Position.Container, Next_Node);
1325 Position : Cursor) return Cursor
1328 if Position.Container = null then
1330 elsif Position.Container /= Object.Container then
1331 raise Program_Error with
1332 "Position cursor of Next designates wrong list";
1334 return Next (Position);
1343 (Container : in out List;
1344 New_Item : Element_Type;
1345 Count : Count_Type := 1)
1348 Insert (Container, First (Container), New_Item, Count);
1355 procedure Previous (Position : in out Cursor) is
1357 Position := Previous (Position);
1360 function Previous (Position : Cursor) return Cursor is
1362 if Position.Node = null then
1366 pragma Assert (Vet (Position), "bad cursor in Previous");
1369 Prev_Node : constant Node_Access := Position.Node.Prev;
1371 if Prev_Node = null then
1374 return Cursor'(Position.Container, Prev_Node);
1382 Position : Cursor) return Cursor
1385 if Position.Container = null then
1387 elsif Position.Container /= Object.Container then
1388 raise Program_Error with
1389 "Position cursor of Previous designates wrong list";
1391 return Previous (Position);
1399 procedure Query_Element
1401 Process : not null access procedure (Element : Element_Type))
1404 if Position.Node = null then
1405 raise Constraint_Error with
1406 "Position cursor has no element";
1409 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1412 C : List renames Position.Container.all'Unrestricted_Access.all;
1413 B : Natural renames C.Busy;
1414 L : Natural renames C.Lock;
1421 Process (Position.Node.Element);
1439 (Stream : not null access Root_Stream_Type'Class;
1442 N : Count_Type'Base;
1447 Count_Type'Base'Read (Stream, N);
1456 Element_Type'Read (Stream, X.Element);
1467 Item.Length := Item.Length + 1;
1468 exit when Item.Length = N;
1473 Element_Type'Read (Stream, X.Element);
1480 X.Prev := Item.Last;
1481 Item.Last.Next := X;
1487 (Stream : not null access Root_Stream_Type'Class;
1491 raise Program_Error with "attempt to stream list cursor";
1495 (Stream : not null access Root_Stream_Type'Class;
1496 Item : out Reference_Type)
1499 raise Program_Error with "attempt to stream reference";
1503 (Stream : not null access Root_Stream_Type'Class;
1504 Item : out Constant_Reference_Type)
1507 raise Program_Error with "attempt to stream reference";
1515 (Container : aliased in out List;
1516 Position : Cursor) return Reference_Type
1519 if Position.Container = null then
1520 raise Constraint_Error with "Position cursor has no element";
1522 elsif Position.Container /= Container'Unchecked_Access then
1523 raise Program_Error with
1524 "Position cursor designates wrong container";
1527 pragma Assert (Vet (Position), "bad cursor in function Reference");
1530 C : List renames Position.Container.all;
1531 B : Natural renames C.Busy;
1532 L : Natural renames C.Lock;
1534 return R : constant Reference_Type :=
1535 (Element => Position.Node.Element'Access,
1536 Control => (Controlled with Position.Container))
1545 ---------------------
1546 -- Replace_Element --
1547 ---------------------
1549 procedure Replace_Element
1550 (Container : in out List;
1552 New_Item : Element_Type)
1555 if Position.Container = null then
1556 raise Constraint_Error with "Position cursor has no element";
1558 elsif Position.Container /= Container'Unchecked_Access then
1559 raise Program_Error with
1560 "Position cursor designates wrong container";
1562 elsif Container.Lock > 0 then
1563 raise Program_Error with
1564 "attempt to tamper with elements (list is locked)";
1567 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1569 Position.Node.Element := New_Item;
1571 end Replace_Element;
1573 ----------------------
1574 -- Reverse_Elements --
1575 ----------------------
1577 procedure Reverse_Elements (Container : in out List) is
1578 I : Node_Access := Container.First;
1579 J : Node_Access := Container.Last;
1581 procedure Swap (L, R : Node_Access);
1587 procedure Swap (L, R : Node_Access) is
1588 LN : constant Node_Access := L.Next;
1589 LP : constant Node_Access := L.Prev;
1591 RN : constant Node_Access := R.Next;
1592 RP : constant Node_Access := R.Prev;
1607 pragma Assert (RP = L);
1621 -- Start of processing for Reverse_Elements
1624 if Container.Length <= 1 then
1628 pragma Assert (Container.First.Prev = null);
1629 pragma Assert (Container.Last.Next = null);
1631 if Container.Busy > 0 then
1632 raise Program_Error with
1633 "attempt to tamper with cursors (list is busy)";
1636 Container.First := J;
1637 Container.Last := I;
1639 Swap (L => I, R => J);
1647 Swap (L => J, R => I);
1656 pragma Assert (Container.First.Prev = null);
1657 pragma Assert (Container.Last.Next = null);
1658 end Reverse_Elements;
1664 function Reverse_Find
1666 Item : Element_Type;
1667 Position : Cursor := No_Element) return Cursor
1669 Node : Node_Access := Position.Node;
1673 Node := Container.Last;
1676 if Position.Container /= Container'Unrestricted_Access then
1677 raise Program_Error with
1678 "Position cursor designates wrong container";
1680 pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1684 -- Per AI05-0022, the container implementation is required to detect
1685 -- element tampering by a generic actual subprogram.
1688 B : Natural renames Container'Unrestricted_Access.Busy;
1689 L : Natural renames Container'Unrestricted_Access.Lock;
1691 Result : Node_Access;
1698 while Node /= null loop
1699 if Node.Element = Item then
1710 if Result = null then
1713 return Cursor'(Container'Unrestricted_Access, Result);
1724 ---------------------
1725 -- Reverse_Iterate --
1726 ---------------------
1728 procedure Reverse_Iterate
1730 Process : not null access procedure (Position : Cursor))
1732 C : List renames Container'Unrestricted_Access.all;
1733 B : Natural renames C.Busy;
1735 Node : Node_Access := Container.Last;
1741 while Node /= null loop
1742 Process (Cursor'(Container'Unrestricted_Access, Node));
1752 end Reverse_Iterate;
1759 (Target : in out List;
1761 Source : in out List)
1764 if Before.Container /= null then
1765 if Before.Container /= Target'Unrestricted_Access then
1766 raise Program_Error with
1767 "Before cursor designates wrong container";
1769 pragma Assert (Vet (Before), "bad cursor in Splice");
1773 if Target'Address = Source'Address or else Source.Length = 0 then
1776 elsif Target.Length > Count_Type'Last - Source.Length then
1777 raise Constraint_Error with "new length exceeds maximum";
1779 elsif Target.Busy > 0 then
1780 raise Program_Error with
1781 "attempt to tamper with cursors of Target (list is busy)";
1783 elsif Source.Busy > 0 then
1784 raise Program_Error with
1785 "attempt to tamper with cursors of Source (list is busy)";
1788 Splice_Internal (Target, Before.Node, Source);
1793 (Container : in out List;
1798 if Before.Container /= null then
1799 if Before.Container /= Container'Unchecked_Access then
1800 raise Program_Error with
1801 "Before cursor designates wrong container";
1803 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1807 if Position.Node = null then
1808 raise Constraint_Error with "Position cursor has no element";
1811 if Position.Container /= Container'Unrestricted_Access then
1812 raise Program_Error with
1813 "Position cursor designates wrong container";
1816 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1818 if Position.Node = Before.Node
1819 or else Position.Node.Next = Before.Node
1824 pragma Assert (Container.Length >= 2);
1826 if Container.Busy > 0 then
1827 raise Program_Error with
1828 "attempt to tamper with cursors (list is busy)";
1831 if Before.Node = null then
1832 pragma Assert (Position.Node /= Container.Last);
1834 if Position.Node = Container.First then
1835 Container.First := Position.Node.Next;
1836 Container.First.Prev := null;
1838 Position.Node.Prev.Next := Position.Node.Next;
1839 Position.Node.Next.Prev := Position.Node.Prev;
1842 Container.Last.Next := Position.Node;
1843 Position.Node.Prev := Container.Last;
1845 Container.Last := Position.Node;
1846 Container.Last.Next := null;
1851 if Before.Node = Container.First then
1852 pragma Assert (Position.Node /= Container.First);
1854 if Position.Node = Container.Last then
1855 Container.Last := Position.Node.Prev;
1856 Container.Last.Next := null;
1858 Position.Node.Prev.Next := Position.Node.Next;
1859 Position.Node.Next.Prev := Position.Node.Prev;
1862 Container.First.Prev := Position.Node;
1863 Position.Node.Next := Container.First;
1865 Container.First := Position.Node;
1866 Container.First.Prev := null;
1871 if Position.Node = Container.First then
1872 Container.First := Position.Node.Next;
1873 Container.First.Prev := null;
1875 elsif Position.Node = Container.Last then
1876 Container.Last := Position.Node.Prev;
1877 Container.Last.Next := null;
1880 Position.Node.Prev.Next := Position.Node.Next;
1881 Position.Node.Next.Prev := Position.Node.Prev;
1884 Before.Node.Prev.Next := Position.Node;
1885 Position.Node.Prev := Before.Node.Prev;
1887 Before.Node.Prev := Position.Node;
1888 Position.Node.Next := Before.Node;
1890 pragma Assert (Container.First.Prev = null);
1891 pragma Assert (Container.Last.Next = null);
1895 (Target : in out List;
1897 Source : in out List;
1898 Position : in out Cursor)
1901 if Target'Address = Source'Address then
1902 Splice (Target, Before, Position);
1906 if Before.Container /= null then
1907 if Before.Container /= Target'Unrestricted_Access then
1908 raise Program_Error with
1909 "Before cursor designates wrong container";
1911 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1915 if Position.Node = null then
1916 raise Constraint_Error with "Position cursor has no element";
1918 elsif Position.Container /= Source'Unrestricted_Access then
1919 raise Program_Error with
1920 "Position cursor designates wrong container";
1923 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1925 if Target.Length = Count_Type'Last then
1926 raise Constraint_Error with "Target is full";
1928 elsif Target.Busy > 0 then
1929 raise Program_Error with
1930 "attempt to tamper with cursors of Target (list is busy)";
1932 elsif Source.Busy > 0 then
1933 raise Program_Error with
1934 "attempt to tamper with cursors of Source (list is busy)";
1937 Splice_Internal (Target, Before.Node, Source, Position.Node);
1938 Position.Container := Target'Unchecked_Access;
1943 ---------------------
1944 -- Splice_Internal --
1945 ---------------------
1947 procedure Splice_Internal
1948 (Target : in out List;
1949 Before : Node_Access;
1950 Source : in out List)
1953 -- This implements the corresponding Splice operation, after the
1954 -- parameters have been vetted, and corner-cases disposed of.
1956 pragma Assert (Target'Address /= Source'Address);
1957 pragma Assert (Source.Length > 0);
1958 pragma Assert (Source.First /= null);
1959 pragma Assert (Source.First.Prev = null);
1960 pragma Assert (Source.Last /= null);
1961 pragma Assert (Source.Last.Next = null);
1962 pragma Assert (Target.Length <= Count_Type'Last - Source.Length);
1964 if Target.Length = 0 then
1965 pragma Assert (Target.First = null);
1966 pragma Assert (Target.Last = null);
1967 pragma Assert (Before = null);
1969 Target.First := Source.First;
1970 Target.Last := Source.Last;
1972 elsif Before = null then
1973 pragma Assert (Target.Last.Next = null);
1975 Target.Last.Next := Source.First;
1976 Source.First.Prev := Target.Last;
1978 Target.Last := Source.Last;
1980 elsif Before = Target.First then
1981 pragma Assert (Target.First.Prev = null);
1983 Source.Last.Next := Target.First;
1984 Target.First.Prev := Source.Last;
1986 Target.First := Source.First;
1989 pragma Assert (Target.Length >= 2);
1991 Before.Prev.Next := Source.First;
1992 Source.First.Prev := Before.Prev;
1994 Before.Prev := Source.Last;
1995 Source.Last.Next := Before;
1998 Source.First := null;
1999 Source.Last := null;
2001 Target.Length := Target.Length + Source.Length;
2003 end Splice_Internal;
2005 procedure Splice_Internal
2006 (Target : in out List;
2007 Before : Node_Access; -- node of Target
2008 Source : in out List;
2009 Position : Node_Access) -- node of Source
2012 -- This implements the corresponding Splice operation, after the
2013 -- parameters have been vetted.
2015 pragma Assert (Target'Address /= Source'Address);
2016 pragma Assert (Target.Length < Count_Type'Last);
2017 pragma Assert (Source.Length > 0);
2018 pragma Assert (Source.First /= null);
2019 pragma Assert (Source.First.Prev = null);
2020 pragma Assert (Source.Last /= null);
2021 pragma Assert (Source.Last.Next = null);
2022 pragma Assert (Position /= null);
2024 if Position = Source.First then
2025 Source.First := Position.Next;
2027 if Position = Source.Last then
2028 pragma Assert (Source.First = null);
2029 pragma Assert (Source.Length = 1);
2030 Source.Last := null;
2033 Source.First.Prev := null;
2036 elsif Position = Source.Last then
2037 pragma Assert (Source.Length >= 2);
2038 Source.Last := Position.Prev;
2039 Source.Last.Next := null;
2042 pragma Assert (Source.Length >= 3);
2043 Position.Prev.Next := Position.Next;
2044 Position.Next.Prev := Position.Prev;
2047 if Target.Length = 0 then
2048 pragma Assert (Target.First = null);
2049 pragma Assert (Target.Last = null);
2050 pragma Assert (Before = null);
2052 Target.First := Position;
2053 Target.Last := Position;
2055 Target.First.Prev := null;
2056 Target.Last.Next := null;
2058 elsif Before = null then
2059 pragma Assert (Target.Last.Next = null);
2060 Target.Last.Next := Position;
2061 Position.Prev := Target.Last;
2063 Target.Last := Position;
2064 Target.Last.Next := null;
2066 elsif Before = Target.First then
2067 pragma Assert (Target.First.Prev = null);
2068 Target.First.Prev := Position;
2069 Position.Next := Target.First;
2071 Target.First := Position;
2072 Target.First.Prev := null;
2075 pragma Assert (Target.Length >= 2);
2076 Before.Prev.Next := Position;
2077 Position.Prev := Before.Prev;
2079 Before.Prev := Position;
2080 Position.Next := Before;
2083 Target.Length := Target.Length + 1;
2084 Source.Length := Source.Length - 1;
2085 end Splice_Internal;
2092 (Container : in out List;
2096 if I.Node = null then
2097 raise Constraint_Error with "I cursor has no element";
2100 if J.Node = null then
2101 raise Constraint_Error with "J cursor has no element";
2104 if I.Container /= Container'Unchecked_Access then
2105 raise Program_Error with "I cursor designates wrong container";
2108 if J.Container /= Container'Unchecked_Access then
2109 raise Program_Error with "J cursor designates wrong container";
2112 if I.Node = J.Node then
2116 if Container.Lock > 0 then
2117 raise Program_Error with
2118 "attempt to tamper with elements (list is locked)";
2121 pragma Assert (Vet (I), "bad I cursor in Swap");
2122 pragma Assert (Vet (J), "bad J cursor in Swap");
2125 EI : Element_Type renames I.Node.Element;
2126 EJ : Element_Type renames J.Node.Element;
2128 EI_Copy : constant Element_Type := EI;
2140 procedure Swap_Links
2141 (Container : in out List;
2145 if I.Node = null then
2146 raise Constraint_Error with "I cursor has no element";
2149 if J.Node = null then
2150 raise Constraint_Error with "J cursor has no element";
2153 if I.Container /= Container'Unrestricted_Access then
2154 raise Program_Error with "I cursor designates wrong container";
2157 if J.Container /= Container'Unrestricted_Access then
2158 raise Program_Error with "J cursor designates wrong container";
2161 if I.Node = J.Node then
2165 if Container.Busy > 0 then
2166 raise Program_Error with
2167 "attempt to tamper with cursors (list is busy)";
2170 pragma Assert (Vet (I), "bad I cursor in Swap_Links");
2171 pragma Assert (Vet (J), "bad J cursor in Swap_Links");
2174 I_Next : constant Cursor := Next (I);
2178 Splice (Container, Before => I, Position => J);
2182 J_Next : constant Cursor := Next (J);
2186 Splice (Container, Before => J, Position => I);
2189 pragma Assert (Container.Length >= 3);
2191 Splice (Container, Before => I_Next, Position => J);
2192 Splice (Container, Before => J_Next, Position => I);
2199 --------------------
2200 -- Update_Element --
2201 --------------------
2203 procedure Update_Element
2204 (Container : in out List;
2206 Process : not null access procedure (Element : in out Element_Type))
2209 if Position.Node = null then
2210 raise Constraint_Error with "Position cursor has no element";
2212 elsif Position.Container /= Container'Unchecked_Access then
2213 raise Program_Error with
2214 "Position cursor designates wrong container";
2217 pragma Assert (Vet (Position), "bad cursor in Update_Element");
2220 B : Natural renames Container.Busy;
2221 L : Natural renames Container.Lock;
2228 Process (Position.Node.Element);
2246 function Vet (Position : Cursor) return Boolean is
2248 if Position.Node = null then
2249 return Position.Container = null;
2252 if Position.Container = null then
2256 -- An invariant of a node is that its Previous and Next components can
2257 -- be null, or designate a different node. Operation Free sets the
2258 -- access value components of the node to designate the node itself
2259 -- before actually deallocating the node, thus deliberately violating
2260 -- the node invariant. This gives us a simple way to detect a dangling
2261 -- reference to a node.
2263 if Position.Node.Next = Position.Node then
2267 if Position.Node.Prev = Position.Node then
2271 -- In practice the tests above will detect most instances of a dangling
2272 -- reference. If we get here, it means that the invariants of the
2273 -- designated node are satisfied (they at least appear to be satisfied),
2274 -- so we perform some more tests, to determine whether invariants of the
2275 -- designated list are satisfied too.
2278 L : List renames Position.Container.all;
2281 if L.Length = 0 then
2285 if L.First = null then
2289 if L.Last = null then
2293 if L.First.Prev /= null then
2297 if L.Last.Next /= null then
2301 if Position.Node.Prev = null and then Position.Node /= L.First then
2306 (Position.Node.Prev /= null or else Position.Node = L.First);
2308 if Position.Node.Next = null and then Position.Node /= L.Last then
2313 (Position.Node.Next /= null
2314 or else Position.Node = L.Last);
2316 if L.Length = 1 then
2317 return L.First = L.Last;
2320 if L.First = L.Last then
2324 if L.First.Next = null then
2328 if L.Last.Prev = null then
2332 if L.First.Next.Prev /= L.First then
2336 if L.Last.Prev.Next /= L.Last then
2340 if L.Length = 2 then
2341 if L.First.Next /= L.Last then
2343 elsif L.Last.Prev /= L.First then
2350 if L.First.Next = L.Last then
2354 if L.Last.Prev = L.First then
2358 -- Eliminate earlier possibility
2360 if Position.Node = L.First then
2364 pragma Assert (Position.Node.Prev /= null);
2366 -- Eliminate earlier possibility
2368 if Position.Node = L.Last then
2372 pragma Assert (Position.Node.Next /= null);
2374 if Position.Node.Next.Prev /= Position.Node then
2378 if Position.Node.Prev.Next /= Position.Node then
2382 if L.Length = 3 then
2383 if L.First.Next /= Position.Node then
2385 elsif L.Last.Prev /= Position.Node then
2399 (Stream : not null access Root_Stream_Type'Class;
2405 Count_Type'Base'Write (Stream, Item.Length);
2408 while Node /= null loop
2409 Element_Type'Write (Stream, Node.Element);
2415 (Stream : not null access Root_Stream_Type'Class;
2419 raise Program_Error with "attempt to stream list cursor";
2423 (Stream : not null access Root_Stream_Type'Class;
2424 Item : Reference_Type)
2427 raise Program_Error with "attempt to stream reference";
2431 (Stream : not null access Root_Stream_Type'Class;
2432 Item : Constant_Reference_Type)
2435 raise Program_Error with "attempt to stream reference";
2438 end Ada.Containers.Doubly_Linked_Lists;