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 type Iterator is new Limited_Controlled and
40 List_Iterator_Interfaces.Reversible_Iterator with
42 Container : List_Access;
46 overriding procedure Finalize (Object : in out Iterator);
48 overriding function First (Object : Iterator) return Cursor;
49 overriding function Last (Object : Iterator) return Cursor;
51 overriding function Next
53 Position : Cursor) return Cursor;
55 overriding function Previous
57 Position : Cursor) return Cursor;
59 -----------------------
60 -- Local Subprograms --
61 -----------------------
63 procedure Free (X : in out Node_Access);
65 procedure Insert_Internal
66 (Container : in out List;
68 New_Node : Node_Access);
70 procedure Splice_Internal
71 (Target : in out List;
73 Source : in out List);
75 procedure Splice_Internal
76 (Target : in out List;
79 Position : Node_Access);
81 function Vet (Position : Cursor) return Boolean;
82 -- Checks invariants of the cursor and its designated container, as a
83 -- simple way of detecting dangling references (see operation Free for a
84 -- description of the detection mechanism), returning True if all checks
85 -- pass. Invocations of Vet are used here as the argument of pragma Assert,
86 -- so the checks are performed only when assertions are enabled.
92 function "=" (Left, Right : List) return Boolean is
93 BL : Natural renames Left'Unrestricted_Access.Busy;
94 LL : Natural renames Left'Unrestricted_Access.Lock;
96 BR : Natural renames Right'Unrestricted_Access.Busy;
97 LR : Natural renames Right'Unrestricted_Access.Lock;
104 if Left'Address = Right'Address then
108 if Left.Length /= Right.Length then
112 -- Per AI05-0022, the container implementation is required to detect
113 -- element tampering by a generic actual subprogram.
124 for J in 1 .. Left.Length loop
125 if L.Element.all /= R.Element.all then
156 procedure Adjust (Container : in out List) is
157 Src : Node_Access := Container.First;
162 pragma Assert (Container.Last = null);
163 pragma Assert (Container.Length = 0);
164 pragma Assert (Container.Busy = 0);
165 pragma Assert (Container.Lock = 0);
169 pragma Assert (Container.First.Prev = null);
170 pragma Assert (Container.Last.Next = null);
171 pragma Assert (Container.Length > 0);
173 Container.First := null;
174 Container.Last := null;
175 Container.Length := 0;
180 Element : Element_Access := new Element_Type'(Src.Element.all);
182 Dst := new Node_Type'(Element, null, null);
189 Container.First := Dst;
190 Container.Last := Dst;
191 Container.Length := 1;
194 while Src /= null loop
196 Element : Element_Access := new Element_Type'(Src.Element.all);
198 Dst := new Node_Type'(Element, null, Prev => Container.Last);
205 Container.Last.Next := Dst;
206 Container.Last := Dst;
207 Container.Length := Container.Length + 1;
213 procedure Adjust (Control : in out Reference_Control_Type) is
215 if Control.Container /= null then
217 C : List renames Control.Container.all;
218 B : Natural renames C.Busy;
219 L : Natural renames C.Lock;
232 (Container : in out List;
233 New_Item : Element_Type;
234 Count : Count_Type := 1)
237 Insert (Container, No_Element, New_Item, Count);
244 procedure Assign (Target : in out List; Source : List) is
248 if Target'Address = Source'Address then
254 Node := Source.First;
255 while Node /= null loop
256 Target.Append (Node.Element.all);
265 procedure Clear (Container : in out List) is
267 pragma Warnings (Off, X);
270 if Container.Length = 0 then
271 pragma Assert (Container.First = null);
272 pragma Assert (Container.Last = null);
273 pragma Assert (Container.Busy = 0);
274 pragma Assert (Container.Lock = 0);
278 pragma Assert (Container.First.Prev = null);
279 pragma Assert (Container.Last.Next = null);
281 if Container.Busy > 0 then
282 raise Program_Error with
283 "attempt to tamper with cursors (list is busy)";
286 while Container.Length > 1 loop
287 X := Container.First;
288 pragma Assert (X.Next.Prev = Container.First);
290 Container.First := X.Next;
291 Container.First.Prev := null;
293 Container.Length := Container.Length - 1;
298 X := Container.First;
299 pragma Assert (X = Container.Last);
301 Container.First := null;
302 Container.Last := null;
303 Container.Length := 0;
308 ------------------------
309 -- Constant_Reference --
310 ------------------------
312 function Constant_Reference
313 (Container : aliased List;
314 Position : Cursor) return Constant_Reference_Type
317 if Position.Container = null then
318 raise Constraint_Error with "Position cursor has no element";
321 if Position.Container /= Container'Unrestricted_Access then
322 raise Program_Error with
323 "Position cursor designates wrong container";
326 if Position.Node.Element = null then
327 raise Program_Error with "Node has no element";
330 pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
333 C : List renames Position.Container.all;
334 B : Natural renames C.Busy;
335 L : Natural renames C.Lock;
337 return R : constant Constant_Reference_Type :=
338 (Element => Position.Node.Element.all'Access,
339 Control => (Controlled with Position.Container))
345 end Constant_Reference;
353 Item : Element_Type) return Boolean
356 return Find (Container, Item) /= No_Element;
363 function Copy (Source : List) return List is
365 return Target : List do
366 Target.Assign (Source);
375 (Container : in out List;
376 Position : in out Cursor;
377 Count : Count_Type := 1)
382 if Position.Node = null then
383 raise Constraint_Error with
384 "Position cursor has no element";
387 if Position.Node.Element = null then
388 raise Program_Error with
389 "Position cursor has no element";
392 if Position.Container /= Container'Unrestricted_Access then
393 raise Program_Error with
394 "Position cursor designates wrong container";
397 pragma Assert (Vet (Position), "bad cursor in Delete");
399 if Position.Node = Container.First then
400 Delete_First (Container, Count);
401 Position := No_Element; -- Post-York behavior
406 Position := No_Element; -- Post-York behavior
410 if Container.Busy > 0 then
411 raise Program_Error with
412 "attempt to tamper with cursors (list is busy)";
415 for Index in 1 .. Count loop
417 Container.Length := Container.Length - 1;
419 if X = Container.Last then
420 Position := No_Element;
422 Container.Last := X.Prev;
423 Container.Last.Next := null;
429 Position.Node := X.Next;
431 X.Next.Prev := X.Prev;
432 X.Prev.Next := X.Next;
437 Position := No_Element; -- Post-York behavior
444 procedure Delete_First
445 (Container : in out List;
446 Count : Count_Type := 1)
451 if Count >= Container.Length then
460 if Container.Busy > 0 then
461 raise Program_Error with
462 "attempt to tamper with cursors (list is busy)";
465 for I in 1 .. Count loop
466 X := Container.First;
467 pragma Assert (X.Next.Prev = Container.First);
469 Container.First := X.Next;
470 Container.First.Prev := null;
472 Container.Length := Container.Length - 1;
482 procedure Delete_Last
483 (Container : in out List;
484 Count : Count_Type := 1)
489 if Count >= Container.Length then
498 if Container.Busy > 0 then
499 raise Program_Error with
500 "attempt to tamper with cursors (list is busy)";
503 for I in 1 .. Count loop
505 pragma Assert (X.Prev.Next = Container.Last);
507 Container.Last := X.Prev;
508 Container.Last.Next := null;
510 Container.Length := Container.Length - 1;
520 function Element (Position : Cursor) return Element_Type is
522 if Position.Node = null then
523 raise Constraint_Error with
524 "Position cursor has no element";
527 if Position.Node.Element = null then
528 raise Program_Error with
529 "Position cursor has no element";
532 pragma Assert (Vet (Position), "bad cursor in Element");
534 return Position.Node.Element.all;
541 procedure Finalize (Object : in out Iterator) is
543 if Object.Container /= null then
545 B : Natural renames Object.Container.all.Busy;
552 procedure Finalize (Control : in out Reference_Control_Type) is
554 if Control.Container /= null then
556 C : List renames Control.Container.all;
557 B : Natural renames C.Busy;
558 L : Natural renames C.Lock;
564 Control.Container := null;
575 Position : Cursor := No_Element) return Cursor
577 Node : Node_Access := Position.Node;
581 Node := Container.First;
584 if Node.Element = null then
588 if Position.Container /= Container'Unrestricted_Access then
589 raise Program_Error with
590 "Position cursor designates wrong container";
593 pragma Assert (Vet (Position), "bad cursor in Find");
596 -- Per AI05-0022, the container implementation is required to detect
597 -- element tampering by a generic actual subprogram.
600 B : Natural renames Container'Unrestricted_Access.Busy;
601 L : Natural renames Container'Unrestricted_Access.Lock;
603 Result : Node_Access;
610 while Node /= null loop
611 if Node.Element.all = Item then
622 if Result = null then
625 return Cursor'(Container'Unrestricted_Access, Result);
639 function First (Container : List) return Cursor is
641 if Container.First = null then
645 return Cursor'(Container'Unrestricted_Access, Container.First);
648 function First (Object : Iterator) return Cursor is
650 -- The value of the iterator object's Node component influences the
651 -- behavior of the First (and Last) selector function.
653 -- When the Node component is null, this means the iterator object was
654 -- constructed without a start expression, in which case the (forward)
655 -- iteration starts from the (logical) beginning of the entire sequence
656 -- of items (corresponding to Container.First, for a forward iterator).
658 -- Otherwise, this is iteration over a partial sequence of items. When
659 -- the Node component is non-null, the iterator object was constructed
660 -- with a start expression, that specifies the position from which the
661 -- (forward) partial iteration begins.
663 if Object.Node = null then
664 return Indefinite_Doubly_Linked_Lists.First (Object.Container.all);
666 return Cursor'(Object.Container, Object.Node);
674 function First_Element (Container : List) return Element_Type is
676 if Container.First = null then
677 raise Constraint_Error with "list is empty";
680 return Container.First.Element.all;
687 procedure Free (X : in out Node_Access) is
688 procedure Deallocate is
689 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
692 -- While a node is in use, as an active link in a list, its Previous and
693 -- Next components must be null, or designate a different node; this is
694 -- a node invariant. For this indefinite list, there is an additional
695 -- invariant: that the element access value be non-null. Before actually
696 -- deallocating the node, we set the node access value components of the
697 -- node to point to the node itself, and set the element access value to
698 -- null (by deallocating the node's element), thus falsifying the node
699 -- invariant. Subprogram Vet inspects the value of the node components
700 -- when interrogating the node, in order to detect whether the cursor's
701 -- node access value is dangling.
703 -- Note that we have no guarantee that the storage for the node isn't
704 -- modified when it is deallocated, but there are other tests that Vet
705 -- does if node invariants appear to be satisifed. However, in practice
706 -- this simple test works well enough, detecting dangling references
707 -- immediately, without needing further interrogation.
724 ---------------------
725 -- Generic_Sorting --
726 ---------------------
728 package body Generic_Sorting is
734 function Is_Sorted (Container : List) return Boolean is
735 B : Natural renames Container'Unrestricted_Access.Busy;
736 L : Natural renames Container'Unrestricted_Access.Lock;
742 -- Per AI05-0022, the container implementation is required to detect
743 -- element tampering by a generic actual subprogram.
748 Node := Container.First;
750 for I in 2 .. Container.Length loop
751 if Node.Next.Element.all < Node.Element.all then
775 (Target : in out List;
776 Source : in out List)
779 -- The semantics of Merge changed slightly per AI05-0021. It was
780 -- originally the case that if Target and Source denoted the same
781 -- container object, then the GNAT implementation of Merge did
782 -- nothing. However, it was argued that RM05 did not precisely
783 -- specify the semantics for this corner case. The decision of the
784 -- ARG was that if Target and Source denote the same non-empty
785 -- container object, then Program_Error is raised.
787 if Source.Is_Empty then
791 if Target'Address = Source'Address then
792 raise Program_Error with
793 "Target and Source denote same non-empty container";
796 if Target.Length > Count_Type'Last - Source.Length then
797 raise Constraint_Error with "new length exceeds maximum";
800 if Target.Busy > 0 then
801 raise Program_Error with
802 "attempt to tamper with cursors of Target (list is busy)";
805 if Source.Busy > 0 then
806 raise Program_Error with
807 "attempt to tamper with cursors of Source (list is busy)";
811 TB : Natural renames Target.Busy;
812 TL : Natural renames Target.Lock;
814 SB : Natural renames Source.Busy;
815 SL : Natural renames Source.Lock;
817 LI, RI, RJ : Node_Access;
828 while RI /= null loop
829 pragma Assert (RI.Next = null
830 or else not (RI.Next.Element.all <
834 Splice_Internal (Target, null, Source);
838 pragma Assert (LI.Next = null
839 or else not (LI.Next.Element.all <
842 if RI.Element.all < LI.Element.all then
845 Splice_Internal (Target, LI, Source, RJ);
873 procedure Sort (Container : in out List) is
874 procedure Partition (Pivot : Node_Access; Back : Node_Access);
876 procedure Sort (Front, Back : Node_Access);
882 procedure Partition (Pivot : Node_Access; Back : Node_Access) is
883 Node : Node_Access := Pivot.Next;
886 while Node /= Back loop
887 if Node.Element.all < Pivot.Element.all then
889 Prev : constant Node_Access := Node.Prev;
890 Next : constant Node_Access := Node.Next;
895 Container.Last := Prev;
901 Node.Prev := Pivot.Prev;
905 if Node.Prev = null then
906 Container.First := Node;
908 Node.Prev.Next := Node;
924 procedure Sort (Front, Back : Node_Access) is
925 Pivot : constant Node_Access :=
926 (if Front = null then Container.First else Front.Next);
928 if Pivot /= Back then
929 Partition (Pivot, Back);
935 -- Start of processing for Sort
938 if Container.Length <= 1 then
942 pragma Assert (Container.First.Prev = null);
943 pragma Assert (Container.Last.Next = null);
945 if Container.Busy > 0 then
946 raise Program_Error with
947 "attempt to tamper with cursors (list is busy)";
950 -- Per AI05-0022, the container implementation is required to detect
951 -- element tampering by a generic actual subprogram.
954 B : Natural renames Container.Busy;
955 L : Natural renames Container.Lock;
961 Sort (Front => null, Back => null);
972 pragma Assert (Container.First.Prev = null);
973 pragma Assert (Container.Last.Next = null);
982 function Has_Element (Position : Cursor) return Boolean is
984 pragma Assert (Vet (Position), "bad cursor in Has_Element");
985 return Position.Node /= null;
993 (Container : in out List;
995 New_Item : Element_Type;
996 Position : out Cursor;
997 Count : Count_Type := 1)
999 New_Node : Node_Access;
1002 if Before.Container /= null then
1003 if Before.Container /= Container'Unrestricted_Access then
1004 raise Program_Error with
1005 "attempt to tamper with cursors (list is busy)";
1008 if Before.Node = null
1009 or else Before.Node.Element = null
1011 raise Program_Error with
1012 "Before cursor has no element";
1015 pragma Assert (Vet (Before), "bad cursor in Insert");
1023 if Container.Length > Count_Type'Last - Count then
1024 raise Constraint_Error with "new length exceeds maximum";
1027 if Container.Busy > 0 then
1028 raise Program_Error with
1029 "attempt to tamper with cursors (list is busy)";
1033 -- The element allocator may need an accessibility check in the case
1034 -- the actual type is class-wide or has access discriminants (see
1035 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
1036 -- allocator in the loop below, because the one in this block would
1037 -- have failed already.
1039 pragma Unsuppress (Accessibility_Check);
1041 Element : Element_Access := new Element_Type'(New_Item);
1044 New_Node := new Node_Type'(Element, null, null);
1052 Insert_Internal (Container, Before.Node, New_Node);
1053 Position := Cursor'(Container'Unchecked_Access, New_Node);
1055 for J in Count_Type'(2) .. Count loop
1058 Element : Element_Access := new Element_Type'(New_Item);
1060 New_Node := new Node_Type'(Element, null, null);
1067 Insert_Internal (Container, Before.Node, New_Node);
1072 (Container : in out List;
1074 New_Item : Element_Type;
1075 Count : Count_Type := 1)
1078 pragma Unreferenced (Position);
1080 Insert (Container, Before, New_Item, Position, Count);
1083 ---------------------
1084 -- Insert_Internal --
1085 ---------------------
1087 procedure Insert_Internal
1088 (Container : in out List;
1089 Before : Node_Access;
1090 New_Node : Node_Access)
1093 if Container.Length = 0 then
1094 pragma Assert (Before = null);
1095 pragma Assert (Container.First = null);
1096 pragma Assert (Container.Last = null);
1098 Container.First := New_Node;
1099 Container.Last := New_Node;
1101 elsif Before = null then
1102 pragma Assert (Container.Last.Next = null);
1104 Container.Last.Next := New_Node;
1105 New_Node.Prev := Container.Last;
1107 Container.Last := New_Node;
1109 elsif Before = Container.First then
1110 pragma Assert (Container.First.Prev = null);
1112 Container.First.Prev := New_Node;
1113 New_Node.Next := Container.First;
1115 Container.First := New_Node;
1118 pragma Assert (Container.First.Prev = null);
1119 pragma Assert (Container.Last.Next = null);
1121 New_Node.Next := Before;
1122 New_Node.Prev := Before.Prev;
1124 Before.Prev.Next := New_Node;
1125 Before.Prev := New_Node;
1128 Container.Length := Container.Length + 1;
1129 end Insert_Internal;
1135 function Is_Empty (Container : List) return Boolean is
1137 return Container.Length = 0;
1146 Process : not null access procedure (Position : Cursor))
1148 B : Natural renames Container'Unrestricted_Access.all.Busy;
1149 Node : Node_Access := Container.First;
1155 while Node /= null loop
1156 Process (Cursor'(Container'Unrestricted_Access, Node));
1170 return List_Iterator_Interfaces.Reversible_Iterator'class
1172 B : Natural renames Container'Unrestricted_Access.all.Busy;
1175 -- The value of the Node component influences the behavior of the First
1176 -- and Last selector functions of the iterator object. When the Node
1177 -- component is null (as is the case here), this means the iterator
1178 -- object was constructed without a start expression. This is a
1179 -- complete iterator, meaning that the iteration starts from the
1180 -- (logical) beginning of the sequence of items.
1182 -- Note: For a forward iterator, Container.First is the beginning, and
1183 -- for a reverse iterator, Container.Last is the beginning.
1185 return It : constant Iterator :=
1186 Iterator'(Limited_Controlled with
1187 Container => Container'Unrestricted_Access,
1197 return List_Iterator_Interfaces.Reversible_Iterator'Class
1199 B : Natural renames Container'Unrestricted_Access.all.Busy;
1202 -- It was formerly the case that when Start = No_Element, the partial
1203 -- iterator was defined to behave the same as for a complete iterator,
1204 -- and iterate over the entire sequence of items. However, those
1205 -- semantics were unintuitive and arguably error-prone (it is too easy
1206 -- to accidentally create an endless loop), and so they were changed,
1207 -- per the ARG meeting in Denver on 2011/11. However, there was no
1208 -- consensus about what positive meaning this corner case should have,
1209 -- and so it was decided to simply raise an exception. This does imply,
1210 -- however, that it is not possible to use a partial iterator to specify
1211 -- an empty sequence of items.
1213 if Start = No_Element then
1214 raise Constraint_Error with
1215 "Start position for iterator equals No_Element";
1218 if Start.Container /= Container'Unrestricted_Access then
1219 raise Program_Error with
1220 "Start cursor of Iterate designates wrong list";
1223 pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
1225 -- The value of the Node component influences the behavior of the First
1226 -- and Last selector functions of the iterator object. When the Node
1227 -- component is non-null (as is the case here), it means that this
1228 -- is a partial iteration, over a subset of the complete sequence of
1229 -- items. The iterator object was constructed with a start expression,
1230 -- indicating the position from which the iteration begins. Note that
1231 -- the start position has the same value irrespective of whether this
1232 -- is a forward or reverse iteration.
1234 return It : constant Iterator :=
1235 Iterator'(Limited_Controlled with
1236 Container => Container'Unrestricted_Access,
1247 function Last (Container : List) return Cursor is
1249 if Container.Last = null then
1253 return Cursor'(Container'Unrestricted_Access, Container.Last);
1256 function Last (Object : Iterator) return Cursor is
1258 -- The value of the iterator object's Node component influences the
1259 -- behavior of the Last (and First) selector function.
1261 -- When the Node component is null, this means the iterator object was
1262 -- constructed without a start expression, in which case the (reverse)
1263 -- iteration starts from the (logical) beginning of the entire sequence
1264 -- (corresponding to Container.Last, for a reverse iterator).
1266 -- Otherwise, this is iteration over a partial sequence of items. When
1267 -- the Node component is non-null, the iterator object was constructed
1268 -- with a start expression, that specifies the position from which the
1269 -- (reverse) partial iteration begins.
1271 if Object.Node = null then
1272 return Indefinite_Doubly_Linked_Lists.Last (Object.Container.all);
1274 return Cursor'(Object.Container, Object.Node);
1282 function Last_Element (Container : List) return Element_Type is
1284 if Container.Last = null then
1285 raise Constraint_Error with "list is empty";
1288 return Container.Last.Element.all;
1295 function Length (Container : List) return Count_Type is
1297 return Container.Length;
1304 procedure Move (Target : in out List; Source : in out List) is
1306 if Target'Address = Source'Address then
1310 if Source.Busy > 0 then
1311 raise Program_Error with
1312 "attempt to tamper with cursors of Source (list is busy)";
1317 Target.First := Source.First;
1318 Source.First := null;
1320 Target.Last := Source.Last;
1321 Source.Last := null;
1323 Target.Length := Source.Length;
1331 procedure Next (Position : in out Cursor) is
1333 Position := Next (Position);
1336 function Next (Position : Cursor) return Cursor is
1338 if Position.Node = null then
1342 pragma Assert (Vet (Position), "bad cursor in Next");
1345 Next_Node : constant Node_Access := Position.Node.Next;
1347 if Next_Node = null then
1351 return Cursor'(Position.Container, Next_Node);
1355 function Next (Object : Iterator; Position : Cursor) return Cursor is
1357 if Position.Container = null then
1361 if Position.Container /= Object.Container then
1362 raise Program_Error with
1363 "Position cursor of Next designates wrong list";
1366 return Next (Position);
1374 (Container : in out List;
1375 New_Item : Element_Type;
1376 Count : Count_Type := 1)
1379 Insert (Container, First (Container), New_Item, Count);
1386 procedure Previous (Position : in out Cursor) is
1388 Position := Previous (Position);
1391 function Previous (Position : Cursor) return Cursor is
1393 if Position.Node = null then
1397 pragma Assert (Vet (Position), "bad cursor in Previous");
1400 Prev_Node : constant Node_Access := Position.Node.Prev;
1402 if Prev_Node = null then
1406 return Cursor'(Position.Container, Prev_Node);
1410 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1412 if Position.Container = null then
1416 if Position.Container /= Object.Container then
1417 raise Program_Error with
1418 "Position cursor of Previous designates wrong list";
1421 return Previous (Position);
1428 procedure Query_Element
1430 Process : not null access procedure (Element : Element_Type))
1433 if Position.Node = null then
1434 raise Constraint_Error with
1435 "Position cursor has no element";
1438 if Position.Node.Element = null then
1439 raise Program_Error with
1440 "Position cursor has no element";
1443 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1446 C : List renames Position.Container.all'Unrestricted_Access.all;
1447 B : Natural renames C.Busy;
1448 L : Natural renames C.Lock;
1455 Process (Position.Node.Element.all);
1473 (Stream : not null access Root_Stream_Type'Class;
1476 N : Count_Type'Base;
1482 Count_Type'Base'Read (Stream, N);
1489 Element : Element_Access :=
1490 new Element_Type'(Element_Type'Input (Stream));
1492 Dst := new Node_Type'(Element, null, null);
1503 while Item.Length < N loop
1505 Element : Element_Access :=
1506 new Element_Type'(Element_Type'Input (Stream));
1508 Dst := new Node_Type'(Element, Next => null, Prev => Item.Last);
1515 Item.Last.Next := Dst;
1517 Item.Length := Item.Length + 1;
1522 (Stream : not null access Root_Stream_Type'Class;
1526 raise Program_Error with "attempt to stream list cursor";
1530 (Stream : not null access Root_Stream_Type'Class;
1531 Item : out Reference_Type)
1534 raise Program_Error with "attempt to stream reference";
1538 (Stream : not null access Root_Stream_Type'Class;
1539 Item : out Constant_Reference_Type)
1542 raise Program_Error with "attempt to stream reference";
1550 (Container : aliased in out List;
1551 Position : Cursor) return Reference_Type
1554 if Position.Container = null then
1555 raise Constraint_Error with "Position cursor has no element";
1558 if Position.Container /= Container'Unrestricted_Access then
1559 raise Program_Error with
1560 "Position cursor designates wrong container";
1563 if Position.Node.Element = null then
1564 raise Program_Error with "Node has no element";
1567 pragma Assert (Vet (Position), "bad cursor in function Reference");
1570 C : List renames Position.Container.all;
1571 B : Natural renames C.Busy;
1572 L : Natural renames C.Lock;
1574 return R : constant Reference_Type :=
1575 (Element => Position.Node.Element.all'Access,
1576 Control => (Controlled with Position.Container))
1584 ---------------------
1585 -- Replace_Element --
1586 ---------------------
1588 procedure Replace_Element
1589 (Container : in out List;
1591 New_Item : Element_Type)
1594 if Position.Container = null then
1595 raise Constraint_Error with "Position cursor has no element";
1598 if Position.Container /= Container'Unchecked_Access then
1599 raise Program_Error with
1600 "Position cursor designates wrong container";
1603 if Container.Lock > 0 then
1604 raise Program_Error with
1605 "attempt to tamper with elements (list is locked)";
1608 if Position.Node.Element = null then
1609 raise Program_Error with
1610 "Position cursor has no element";
1613 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1616 -- The element allocator may need an accessibility check in the case
1617 -- the actual type is class-wide or has access discriminants (see
1618 -- RM 4.8(10.1) and AI12-0035).
1620 pragma Unsuppress (Accessibility_Check);
1622 X : Element_Access := Position.Node.Element;
1625 Position.Node.Element := new Element_Type'(New_Item);
1628 end Replace_Element;
1630 ----------------------
1631 -- Reverse_Elements --
1632 ----------------------
1634 procedure Reverse_Elements (Container : in out List) is
1635 I : Node_Access := Container.First;
1636 J : Node_Access := Container.Last;
1638 procedure Swap (L, R : Node_Access);
1644 procedure Swap (L, R : Node_Access) is
1645 LN : constant Node_Access := L.Next;
1646 LP : constant Node_Access := L.Prev;
1648 RN : constant Node_Access := R.Next;
1649 RP : constant Node_Access := R.Prev;
1664 pragma Assert (RP = L);
1678 -- Start of processing for Reverse_Elements
1681 if Container.Length <= 1 then
1685 pragma Assert (Container.First.Prev = null);
1686 pragma Assert (Container.Last.Next = null);
1688 if Container.Busy > 0 then
1689 raise Program_Error with
1690 "attempt to tamper with cursors (list is busy)";
1693 Container.First := J;
1694 Container.Last := I;
1696 Swap (L => I, R => J);
1704 Swap (L => J, R => I);
1713 pragma Assert (Container.First.Prev = null);
1714 pragma Assert (Container.Last.Next = null);
1715 end Reverse_Elements;
1721 function Reverse_Find
1723 Item : Element_Type;
1724 Position : Cursor := No_Element) return Cursor
1726 Node : Node_Access := Position.Node;
1730 Node := Container.Last;
1733 if Node.Element = null then
1734 raise Program_Error with "Position cursor has no element";
1737 if Position.Container /= Container'Unrestricted_Access then
1738 raise Program_Error with
1739 "Position cursor designates wrong container";
1742 pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1745 -- Per AI05-0022, the container implementation is required to detect
1746 -- element tampering by a generic actual subprogram.
1749 B : Natural renames Container'Unrestricted_Access.Busy;
1750 L : Natural renames Container'Unrestricted_Access.Lock;
1752 Result : Node_Access;
1759 while Node /= null loop
1760 if Node.Element.all = Item then
1771 if Result = null then
1774 return Cursor'(Container'Unrestricted_Access, Result);
1784 ---------------------
1785 -- Reverse_Iterate --
1786 ---------------------
1788 procedure Reverse_Iterate
1790 Process : not null access procedure (Position : Cursor))
1792 C : List renames Container'Unrestricted_Access.all;
1793 B : Natural renames C.Busy;
1795 Node : Node_Access := Container.Last;
1801 while Node /= null loop
1802 Process (Cursor'(Container'Unrestricted_Access, Node));
1812 end Reverse_Iterate;
1819 (Target : in out List;
1821 Source : in out List)
1824 if Before.Container /= null then
1825 if Before.Container /= Target'Unrestricted_Access then
1826 raise Program_Error with
1827 "Before cursor designates wrong container";
1830 if Before.Node = null
1831 or else Before.Node.Element = null
1833 raise Program_Error with
1834 "Before cursor has no element";
1837 pragma Assert (Vet (Before), "bad cursor in Splice");
1840 if Target'Address = Source'Address
1841 or else Source.Length = 0
1846 if Target.Length > Count_Type'Last - Source.Length then
1847 raise Constraint_Error with "new length exceeds maximum";
1850 if Target.Busy > 0 then
1851 raise Program_Error with
1852 "attempt to tamper with cursors of Target (list is busy)";
1855 if Source.Busy > 0 then
1856 raise Program_Error with
1857 "attempt to tamper with cursors of Source (list is busy)";
1860 Splice_Internal (Target, Before.Node, Source);
1864 (Container : in out List;
1869 if Before.Container /= null then
1870 if Before.Container /= Container'Unchecked_Access then
1871 raise Program_Error with
1872 "Before cursor designates wrong container";
1875 if Before.Node = null
1876 or else Before.Node.Element = null
1878 raise Program_Error with
1879 "Before cursor has no element";
1882 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1885 if Position.Node = null then
1886 raise Constraint_Error with "Position cursor has no element";
1889 if Position.Node.Element = null then
1890 raise Program_Error with "Position cursor has no element";
1893 if Position.Container /= Container'Unrestricted_Access then
1894 raise Program_Error with
1895 "Position cursor designates wrong container";
1898 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1900 if Position.Node = Before.Node
1901 or else Position.Node.Next = Before.Node
1906 pragma Assert (Container.Length >= 2);
1908 if Container.Busy > 0 then
1909 raise Program_Error with
1910 "attempt to tamper with cursors (list is busy)";
1913 if Before.Node = null then
1914 pragma Assert (Position.Node /= Container.Last);
1916 if Position.Node = Container.First then
1917 Container.First := Position.Node.Next;
1918 Container.First.Prev := null;
1920 Position.Node.Prev.Next := Position.Node.Next;
1921 Position.Node.Next.Prev := Position.Node.Prev;
1924 Container.Last.Next := Position.Node;
1925 Position.Node.Prev := Container.Last;
1927 Container.Last := Position.Node;
1928 Container.Last.Next := null;
1933 if Before.Node = Container.First then
1934 pragma Assert (Position.Node /= Container.First);
1936 if Position.Node = Container.Last then
1937 Container.Last := Position.Node.Prev;
1938 Container.Last.Next := null;
1940 Position.Node.Prev.Next := Position.Node.Next;
1941 Position.Node.Next.Prev := Position.Node.Prev;
1944 Container.First.Prev := Position.Node;
1945 Position.Node.Next := Container.First;
1947 Container.First := Position.Node;
1948 Container.First.Prev := null;
1953 if Position.Node = Container.First then
1954 Container.First := Position.Node.Next;
1955 Container.First.Prev := null;
1957 elsif Position.Node = Container.Last then
1958 Container.Last := Position.Node.Prev;
1959 Container.Last.Next := null;
1962 Position.Node.Prev.Next := Position.Node.Next;
1963 Position.Node.Next.Prev := Position.Node.Prev;
1966 Before.Node.Prev.Next := Position.Node;
1967 Position.Node.Prev := Before.Node.Prev;
1969 Before.Node.Prev := Position.Node;
1970 Position.Node.Next := Before.Node;
1972 pragma Assert (Container.First.Prev = null);
1973 pragma Assert (Container.Last.Next = null);
1977 (Target : in out List;
1979 Source : in out List;
1980 Position : in out Cursor)
1983 if Target'Address = Source'Address then
1984 Splice (Target, Before, Position);
1988 if Before.Container /= null then
1989 if Before.Container /= Target'Unrestricted_Access then
1990 raise Program_Error with
1991 "Before cursor designates wrong container";
1994 if Before.Node = null
1995 or else Before.Node.Element = null
1997 raise Program_Error with
1998 "Before cursor has no element";
2001 pragma Assert (Vet (Before), "bad Before cursor in Splice");
2004 if Position.Node = null then
2005 raise Constraint_Error with "Position cursor has no element";
2008 if Position.Node.Element = null then
2009 raise Program_Error with
2010 "Position cursor has no element";
2013 if Position.Container /= Source'Unrestricted_Access then
2014 raise Program_Error with
2015 "Position cursor designates wrong container";
2018 pragma Assert (Vet (Position), "bad Position cursor in Splice");
2020 if Target.Length = Count_Type'Last then
2021 raise Constraint_Error with "Target is full";
2024 if Target.Busy > 0 then
2025 raise Program_Error with
2026 "attempt to tamper with cursors of Target (list is busy)";
2029 if Source.Busy > 0 then
2030 raise Program_Error with
2031 "attempt to tamper with cursors of Source (list is busy)";
2034 Splice_Internal (Target, Before.Node, Source, Position.Node);
2035 Position.Container := Target'Unchecked_Access;
2038 ---------------------
2039 -- Splice_Internal --
2040 ---------------------
2042 procedure Splice_Internal
2043 (Target : in out List;
2044 Before : Node_Access;
2045 Source : in out List)
2048 -- This implements the corresponding Splice operation, after the
2049 -- parameters have been vetted, and corner-cases disposed of.
2051 pragma Assert (Target'Address /= Source'Address);
2052 pragma Assert (Source.Length > 0);
2053 pragma Assert (Source.First /= null);
2054 pragma Assert (Source.First.Prev = null);
2055 pragma Assert (Source.Last /= null);
2056 pragma Assert (Source.Last.Next = null);
2057 pragma Assert (Target.Length <= Count_Type'Last - Source.Length);
2059 if Target.Length = 0 then
2060 pragma Assert (Before = null);
2061 pragma Assert (Target.First = null);
2062 pragma Assert (Target.Last = null);
2064 Target.First := Source.First;
2065 Target.Last := Source.Last;
2067 elsif Before = null then
2068 pragma Assert (Target.Last.Next = null);
2070 Target.Last.Next := Source.First;
2071 Source.First.Prev := Target.Last;
2073 Target.Last := Source.Last;
2075 elsif Before = Target.First then
2076 pragma Assert (Target.First.Prev = null);
2078 Source.Last.Next := Target.First;
2079 Target.First.Prev := Source.Last;
2081 Target.First := Source.First;
2084 pragma Assert (Target.Length >= 2);
2085 Before.Prev.Next := Source.First;
2086 Source.First.Prev := Before.Prev;
2088 Before.Prev := Source.Last;
2089 Source.Last.Next := Before;
2092 Source.First := null;
2093 Source.Last := null;
2095 Target.Length := Target.Length + Source.Length;
2097 end Splice_Internal;
2099 procedure Splice_Internal
2100 (Target : in out List;
2101 Before : Node_Access; -- node of Target
2102 Source : in out List;
2103 Position : Node_Access) -- node of Source
2106 -- This implements the corresponding Splice operation, after the
2107 -- parameters have been vetted.
2109 pragma Assert (Target'Address /= Source'Address);
2110 pragma Assert (Target.Length < Count_Type'Last);
2111 pragma Assert (Source.Length > 0);
2112 pragma Assert (Source.First /= null);
2113 pragma Assert (Source.First.Prev = null);
2114 pragma Assert (Source.Last /= null);
2115 pragma Assert (Source.Last.Next = null);
2116 pragma Assert (Position /= null);
2118 if Position = Source.First then
2119 Source.First := Position.Next;
2121 if Position = Source.Last then
2122 pragma Assert (Source.First = null);
2123 pragma Assert (Source.Length = 1);
2124 Source.Last := null;
2127 Source.First.Prev := null;
2130 elsif Position = Source.Last then
2131 pragma Assert (Source.Length >= 2);
2132 Source.Last := Position.Prev;
2133 Source.Last.Next := null;
2136 pragma Assert (Source.Length >= 3);
2137 Position.Prev.Next := Position.Next;
2138 Position.Next.Prev := Position.Prev;
2141 if Target.Length = 0 then
2142 pragma Assert (Before = null);
2143 pragma Assert (Target.First = null);
2144 pragma Assert (Target.Last = null);
2146 Target.First := Position;
2147 Target.Last := Position;
2149 Target.First.Prev := null;
2150 Target.Last.Next := null;
2152 elsif Before = null then
2153 pragma Assert (Target.Last.Next = null);
2154 Target.Last.Next := Position;
2155 Position.Prev := Target.Last;
2157 Target.Last := Position;
2158 Target.Last.Next := null;
2160 elsif Before = Target.First then
2161 pragma Assert (Target.First.Prev = null);
2162 Target.First.Prev := Position;
2163 Position.Next := Target.First;
2165 Target.First := Position;
2166 Target.First.Prev := null;
2169 pragma Assert (Target.Length >= 2);
2170 Before.Prev.Next := Position;
2171 Position.Prev := Before.Prev;
2173 Before.Prev := Position;
2174 Position.Next := Before;
2177 Target.Length := Target.Length + 1;
2178 Source.Length := Source.Length - 1;
2179 end Splice_Internal;
2186 (Container : in out List;
2190 if I.Node = null then
2191 raise Constraint_Error with "I cursor has no element";
2194 if J.Node = null then
2195 raise Constraint_Error with "J cursor has no element";
2198 if I.Container /= Container'Unchecked_Access then
2199 raise Program_Error with "I cursor designates wrong container";
2202 if J.Container /= Container'Unchecked_Access then
2203 raise Program_Error with "J cursor designates wrong container";
2206 if I.Node = J.Node then
2210 if Container.Lock > 0 then
2211 raise Program_Error with
2212 "attempt to tamper with elements (list is locked)";
2215 pragma Assert (Vet (I), "bad I cursor in Swap");
2216 pragma Assert (Vet (J), "bad J cursor in Swap");
2219 EI_Copy : constant Element_Access := I.Node.Element;
2222 I.Node.Element := J.Node.Element;
2223 J.Node.Element := EI_Copy;
2231 procedure Swap_Links
2232 (Container : in out List;
2236 if I.Node = null then
2237 raise Constraint_Error with "I cursor has no element";
2240 if J.Node = null then
2241 raise Constraint_Error with "J cursor has no element";
2244 if I.Container /= Container'Unrestricted_Access then
2245 raise Program_Error with "I cursor designates wrong container";
2248 if J.Container /= Container'Unrestricted_Access then
2249 raise Program_Error with "J cursor designates wrong container";
2252 if I.Node = J.Node then
2256 if Container.Busy > 0 then
2257 raise Program_Error with
2258 "attempt to tamper with cursors (list is busy)";
2261 pragma Assert (Vet (I), "bad I cursor in Swap_Links");
2262 pragma Assert (Vet (J), "bad J cursor in Swap_Links");
2265 I_Next : constant Cursor := Next (I);
2269 Splice (Container, Before => I, Position => J);
2273 J_Next : constant Cursor := Next (J);
2277 Splice (Container, Before => J, Position => I);
2280 pragma Assert (Container.Length >= 3);
2282 Splice (Container, Before => I_Next, Position => J);
2283 Splice (Container, Before => J_Next, Position => I);
2289 pragma Assert (Container.First.Prev = null);
2290 pragma Assert (Container.Last.Next = null);
2293 --------------------
2294 -- Update_Element --
2295 --------------------
2297 procedure Update_Element
2298 (Container : in out List;
2300 Process : not null access procedure (Element : in out Element_Type))
2303 if Position.Node = null then
2304 raise Constraint_Error with "Position cursor has no element";
2307 if Position.Node.Element = null then
2308 raise Program_Error with
2309 "Position cursor has no element";
2312 if Position.Container /= Container'Unchecked_Access then
2313 raise Program_Error with
2314 "Position cursor designates wrong container";
2317 pragma Assert (Vet (Position), "bad cursor in Update_Element");
2320 B : Natural renames Container.Busy;
2321 L : Natural renames Container.Lock;
2328 Process (Position.Node.Element.all);
2345 function Vet (Position : Cursor) return Boolean is
2347 if Position.Node = null then
2348 return Position.Container = null;
2351 if Position.Container = null then
2355 -- An invariant of a node is that its Previous and Next components can
2356 -- be null, or designate a different node. Also, its element access
2357 -- value must be non-null. Operation Free sets the node access value
2358 -- components of the node to designate the node itself, and the element
2359 -- access value to null, before actually deallocating the node, thus
2360 -- deliberately violating the node invariant. This gives us a simple way
2361 -- to detect a dangling reference to a node.
2363 if Position.Node.Next = Position.Node then
2367 if Position.Node.Prev = Position.Node then
2371 if Position.Node.Element = null then
2375 -- In practice the tests above will detect most instances of a dangling
2376 -- reference. If we get here, it means that the invariants of the
2377 -- designated node are satisfied (they at least appear to be satisfied),
2378 -- so we perform some more tests, to determine whether invariants of the
2379 -- designated list are satisfied too.
2382 L : List renames Position.Container.all;
2385 if L.Length = 0 then
2389 if L.First = null then
2393 if L.Last = null then
2397 if L.First.Prev /= null then
2401 if L.Last.Next /= null then
2405 if Position.Node.Prev = null and then Position.Node /= L.First then
2409 if Position.Node.Next = null and then Position.Node /= L.Last then
2413 if L.Length = 1 then
2414 return L.First = L.Last;
2417 if L.First = L.Last then
2421 if L.First.Next = null then
2425 if L.Last.Prev = null then
2429 if L.First.Next.Prev /= L.First then
2433 if L.Last.Prev.Next /= L.Last then
2437 if L.Length = 2 then
2438 if L.First.Next /= L.Last then
2442 if L.Last.Prev /= L.First then
2449 if L.First.Next = L.Last then
2453 if L.Last.Prev = L.First then
2457 if Position.Node = L.First then
2461 if Position.Node = L.Last then
2465 if Position.Node.Next = null then
2469 if Position.Node.Prev = null then
2473 if Position.Node.Next.Prev /= Position.Node then
2477 if Position.Node.Prev.Next /= Position.Node then
2481 if L.Length = 3 then
2482 if L.First.Next /= Position.Node then
2486 if L.Last.Prev /= Position.Node then
2500 (Stream : not null access Root_Stream_Type'Class;
2503 Node : Node_Access := Item.First;
2506 Count_Type'Base'Write (Stream, Item.Length);
2508 while Node /= null loop
2509 Element_Type'Output (Stream, Node.Element.all);
2515 (Stream : not null access Root_Stream_Type'Class;
2519 raise Program_Error with "attempt to stream list cursor";
2523 (Stream : not null access Root_Stream_Type'Class;
2524 Item : Reference_Type)
2527 raise Program_Error with "attempt to stream reference";
2531 (Stream : not null access Root_Stream_Type'Class;
2532 Item : Constant_Reference_Type)
2535 raise Program_Error with "attempt to stream reference";
2538 end Ada.Containers.Indefinite_Doubly_Linked_Lists;