1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS --
9 -- Copyright (C) 2004-2012, 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 function Vet (Position : Cursor) return Boolean;
71 -- Checks invariants of the cursor and its designated container, as a
72 -- simple way of detecting dangling references (see operation Free for a
73 -- description of the detection mechanism), returning True if all checks
74 -- pass. Invocations of Vet are used here as the argument of pragma Assert,
75 -- so the checks are performed only when assertions are enabled.
81 function "=" (Left, Right : List) return Boolean is
86 if Left'Address = Right'Address then
90 if Left.Length /= Right.Length then
96 for J in 1 .. Left.Length loop
97 if L.Element.all /= R.Element.all then
112 procedure Adjust (Container : in out List) is
113 Src : Node_Access := Container.First;
118 pragma Assert (Container.Last = null);
119 pragma Assert (Container.Length = 0);
120 pragma Assert (Container.Busy = 0);
121 pragma Assert (Container.Lock = 0);
125 pragma Assert (Container.First.Prev = null);
126 pragma Assert (Container.Last.Next = null);
127 pragma Assert (Container.Length > 0);
129 Container.First := null;
130 Container.Last := null;
131 Container.Length := 0;
136 Element : Element_Access := new Element_Type'(Src.Element.all);
138 Dst := new Node_Type'(Element, null, null);
145 Container.First := Dst;
146 Container.Last := Dst;
147 Container.Length := 1;
150 while Src /= null loop
152 Element : Element_Access := new Element_Type'(Src.Element.all);
154 Dst := new Node_Type'(Element, null, Prev => Container.Last);
161 Container.Last.Next := Dst;
162 Container.Last := Dst;
163 Container.Length := Container.Length + 1;
169 procedure Adjust (Control : in out Reference_Control_Type) is
171 if Control.Container /= null then
173 C : List renames Control.Container.all;
174 B : Natural renames C.Busy;
175 L : Natural renames C.Lock;
188 (Container : in out List;
189 New_Item : Element_Type;
190 Count : Count_Type := 1)
193 Insert (Container, No_Element, New_Item, Count);
200 procedure Assign (Target : in out List; Source : List) is
204 if Target'Address = Source'Address then
210 Node := Source.First;
211 while Node /= null loop
212 Target.Append (Node.Element.all);
221 procedure Clear (Container : in out List) is
223 pragma Warnings (Off, X);
226 if Container.Length = 0 then
227 pragma Assert (Container.First = null);
228 pragma Assert (Container.Last = null);
229 pragma Assert (Container.Busy = 0);
230 pragma Assert (Container.Lock = 0);
234 pragma Assert (Container.First.Prev = null);
235 pragma Assert (Container.Last.Next = null);
237 if Container.Busy > 0 then
238 raise Program_Error with
239 "attempt to tamper with cursors (list is busy)";
242 while Container.Length > 1 loop
243 X := Container.First;
244 pragma Assert (X.Next.Prev = Container.First);
246 Container.First := X.Next;
247 Container.First.Prev := null;
249 Container.Length := Container.Length - 1;
254 X := Container.First;
255 pragma Assert (X = Container.Last);
257 Container.First := null;
258 Container.Last := null;
259 Container.Length := 0;
264 ------------------------
265 -- Constant_Reference --
266 ------------------------
268 function Constant_Reference
269 (Container : aliased List;
270 Position : Cursor) return Constant_Reference_Type
273 if Position.Container = null then
274 raise Constraint_Error with "Position cursor has no element";
277 if Position.Container /= Container'Unrestricted_Access then
278 raise Program_Error with
279 "Position cursor designates wrong container";
282 if Position.Node.Element = null then
283 raise Program_Error with "Node has no element";
286 pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
289 C : List renames Position.Container.all;
290 B : Natural renames C.Busy;
291 L : Natural renames C.Lock;
293 return R : constant Constant_Reference_Type :=
294 (Element => Position.Node.Element.all'Access,
295 Control => (Controlled with Position.Container))
301 end Constant_Reference;
309 Item : Element_Type) return Boolean
312 return Find (Container, Item) /= No_Element;
319 function Copy (Source : List) return List is
321 return Target : List do
322 Target.Assign (Source);
331 (Container : in out List;
332 Position : in out Cursor;
333 Count : Count_Type := 1)
338 if Position.Node = null then
339 raise Constraint_Error with
340 "Position cursor has no element";
343 if Position.Node.Element = null then
344 raise Program_Error with
345 "Position cursor has no element";
348 if Position.Container /= Container'Unrestricted_Access then
349 raise Program_Error with
350 "Position cursor designates wrong container";
353 pragma Assert (Vet (Position), "bad cursor in Delete");
355 if Position.Node = Container.First then
356 Delete_First (Container, Count);
357 Position := No_Element; -- Post-York behavior
362 Position := No_Element; -- Post-York behavior
366 if Container.Busy > 0 then
367 raise Program_Error with
368 "attempt to tamper with cursors (list is busy)";
371 for Index in 1 .. Count loop
373 Container.Length := Container.Length - 1;
375 if X = Container.Last then
376 Position := No_Element;
378 Container.Last := X.Prev;
379 Container.Last.Next := null;
385 Position.Node := X.Next;
387 X.Next.Prev := X.Prev;
388 X.Prev.Next := X.Next;
393 Position := No_Element; -- Post-York behavior
400 procedure Delete_First
401 (Container : in out List;
402 Count : Count_Type := 1)
407 if Count >= Container.Length then
416 if Container.Busy > 0 then
417 raise Program_Error with
418 "attempt to tamper with cursors (list is busy)";
421 for I in 1 .. Count loop
422 X := Container.First;
423 pragma Assert (X.Next.Prev = Container.First);
425 Container.First := X.Next;
426 Container.First.Prev := null;
428 Container.Length := Container.Length - 1;
438 procedure Delete_Last
439 (Container : in out List;
440 Count : Count_Type := 1)
445 if Count >= Container.Length then
454 if Container.Busy > 0 then
455 raise Program_Error with
456 "attempt to tamper with cursors (list is busy)";
459 for I in 1 .. Count loop
461 pragma Assert (X.Prev.Next = Container.Last);
463 Container.Last := X.Prev;
464 Container.Last.Next := null;
466 Container.Length := Container.Length - 1;
476 function Element (Position : Cursor) return Element_Type is
478 if Position.Node = null then
479 raise Constraint_Error with
480 "Position cursor has no element";
483 if Position.Node.Element = null then
484 raise Program_Error with
485 "Position cursor has no element";
488 pragma Assert (Vet (Position), "bad cursor in Element");
490 return Position.Node.Element.all;
497 procedure Finalize (Object : in out Iterator) is
499 if Object.Container /= null then
501 B : Natural renames Object.Container.all.Busy;
508 procedure Finalize (Control : in out Reference_Control_Type) is
510 if Control.Container /= null then
512 C : List renames Control.Container.all;
513 B : Natural renames C.Busy;
514 L : Natural renames C.Lock;
520 Control.Container := null;
531 Position : Cursor := No_Element) return Cursor
533 Node : Node_Access := Position.Node;
537 Node := Container.First;
540 if Node.Element = null then
544 if Position.Container /= Container'Unrestricted_Access then
545 raise Program_Error with
546 "Position cursor designates wrong container";
549 pragma Assert (Vet (Position), "bad cursor in Find");
552 while Node /= null loop
553 if Node.Element.all = Item then
554 return Cursor'(Container'Unrestricted_Access, Node);
567 function First (Container : List) return Cursor is
569 if Container.First = null then
573 return Cursor'(Container'Unrestricted_Access, Container.First);
576 function First (Object : Iterator) return Cursor is
578 -- The value of the iterator object's Node component influences the
579 -- behavior of the First (and Last) selector function.
581 -- When the Node component is null, this means the iterator object was
582 -- constructed without a start expression, in which case the (forward)
583 -- iteration starts from the (logical) beginning of the entire sequence
584 -- of items (corresponding to Container.First, for a forward iterator).
586 -- Otherwise, this is iteration over a partial sequence of items. When
587 -- the Node component is non-null, the iterator object was constructed
588 -- with a start expression, that specifies the position from which the
589 -- (forward) partial iteration begins.
591 if Object.Node = null then
592 return Indefinite_Doubly_Linked_Lists.First (Object.Container.all);
594 return Cursor'(Object.Container, Object.Node);
602 function First_Element (Container : List) return Element_Type is
604 if Container.First = null then
605 raise Constraint_Error with "list is empty";
608 return Container.First.Element.all;
615 procedure Free (X : in out Node_Access) is
616 procedure Deallocate is
617 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
620 -- While a node is in use, as an active link in a list, its Previous and
621 -- Next components must be null, or designate a different node; this is
622 -- a node invariant. For this indefinite list, there is an additional
623 -- invariant: that the element access value be non-null. Before actually
624 -- deallocating the node, we set the node access value components of the
625 -- node to point to the node itself, and set the element access value to
626 -- null (by deallocating the node's element), thus falsifying the node
627 -- invariant. Subprogram Vet inspects the value of the node components
628 -- when interrogating the node, in order to detect whether the cursor's
629 -- node access value is dangling.
631 -- Note that we have no guarantee that the storage for the node isn't
632 -- modified when it is deallocated, but there are other tests that Vet
633 -- does if node invariants appear to be satisifed. However, in practice
634 -- this simple test works well enough, detecting dangling references
635 -- immediately, without needing further interrogation.
652 ---------------------
653 -- Generic_Sorting --
654 ---------------------
656 package body Generic_Sorting is
662 function Is_Sorted (Container : List) return Boolean is
663 Node : Node_Access := Container.First;
666 for I in 2 .. Container.Length loop
667 if Node.Next.Element.all < Node.Element.all then
682 (Target : in out List;
683 Source : in out List)
689 -- The semantics of Merge changed slightly per AI05-0021. It was
690 -- originally the case that if Target and Source denoted the same
691 -- container object, then the GNAT implementation of Merge did
692 -- nothing. However, it was argued that RM05 did not precisely
693 -- specify the semantics for this corner case. The decision of the
694 -- ARG was that if Target and Source denote the same non-empty
695 -- container object, then Program_Error is raised.
697 if Source.Is_Empty then
701 if Target'Address = Source'Address then
702 raise Program_Error with
703 "Target and Source denote same non-empty container";
706 if Target.Busy > 0 then
707 raise Program_Error with
708 "attempt to tamper with cursors of Target (list is busy)";
711 if Source.Busy > 0 then
712 raise Program_Error with
713 "attempt to tamper with cursors of Source (list is busy)";
716 LI := First (Target);
717 RI := First (Source);
718 while RI.Node /= null loop
719 pragma Assert (RI.Node.Next = null
720 or else not (RI.Node.Next.Element.all <
721 RI.Node.Element.all));
723 if LI.Node = null then
724 Splice (Target, No_Element, Source);
728 pragma Assert (LI.Node.Next = null
729 or else not (LI.Node.Next.Element.all <
730 LI.Node.Element.all));
732 if RI.Node.Element.all < LI.Node.Element.all then
735 pragma Warnings (Off, RJ);
737 RI.Node := RI.Node.Next;
738 Splice (Target, LI, Source, RJ);
742 LI.Node := LI.Node.Next;
751 procedure Sort (Container : in out List) is
752 procedure Partition (Pivot : Node_Access; Back : Node_Access);
754 procedure Sort (Front, Back : Node_Access);
760 procedure Partition (Pivot : Node_Access; Back : Node_Access) is
761 Node : Node_Access := Pivot.Next;
764 while Node /= Back loop
765 if Node.Element.all < Pivot.Element.all then
767 Prev : constant Node_Access := Node.Prev;
768 Next : constant Node_Access := Node.Next;
773 Container.Last := Prev;
779 Node.Prev := Pivot.Prev;
783 if Node.Prev = null then
784 Container.First := Node;
786 Node.Prev.Next := Node;
802 procedure Sort (Front, Back : Node_Access) is
803 Pivot : constant Node_Access :=
804 (if Front = null then Container.First else Front.Next);
806 if Pivot /= Back then
807 Partition (Pivot, Back);
813 -- Start of processing for Sort
816 if Container.Length <= 1 then
820 pragma Assert (Container.First.Prev = null);
821 pragma Assert (Container.Last.Next = null);
823 if Container.Busy > 0 then
824 raise Program_Error with
825 "attempt to tamper with cursors (list is busy)";
828 Sort (Front => null, Back => null);
830 pragma Assert (Container.First.Prev = null);
831 pragma Assert (Container.Last.Next = null);
840 function Has_Element (Position : Cursor) return Boolean is
842 pragma Assert (Vet (Position), "bad cursor in Has_Element");
843 return Position.Node /= null;
851 (Container : in out List;
853 New_Item : Element_Type;
854 Position : out Cursor;
855 Count : Count_Type := 1)
857 New_Node : Node_Access;
860 if Before.Container /= null then
861 if Before.Container /= Container'Unrestricted_Access then
862 raise Program_Error with
863 "attempt to tamper with cursors (list is busy)";
866 if Before.Node = null
867 or else Before.Node.Element = null
869 raise Program_Error with
870 "Before cursor has no element";
873 pragma Assert (Vet (Before), "bad cursor in Insert");
881 if Container.Length > Count_Type'Last - Count then
882 raise Constraint_Error with "new length exceeds maximum";
885 if Container.Busy > 0 then
886 raise Program_Error with
887 "attempt to tamper with cursors (list is busy)";
891 Element : Element_Access := new Element_Type'(New_Item);
893 New_Node := new Node_Type'(Element, null, null);
900 Insert_Internal (Container, Before.Node, New_Node);
901 Position := Cursor'(Container'Unchecked_Access, New_Node);
903 for J in Count_Type'(2) .. Count loop
906 Element : Element_Access := new Element_Type'(New_Item);
908 New_Node := new Node_Type'(Element, null, null);
915 Insert_Internal (Container, Before.Node, New_Node);
920 (Container : in out List;
922 New_Item : Element_Type;
923 Count : Count_Type := 1)
926 pragma Unreferenced (Position);
928 Insert (Container, Before, New_Item, Position, Count);
931 ---------------------
932 -- Insert_Internal --
933 ---------------------
935 procedure Insert_Internal
936 (Container : in out List;
937 Before : Node_Access;
938 New_Node : Node_Access)
941 if Container.Length = 0 then
942 pragma Assert (Before = null);
943 pragma Assert (Container.First = null);
944 pragma Assert (Container.Last = null);
946 Container.First := New_Node;
947 Container.Last := New_Node;
949 elsif Before = null then
950 pragma Assert (Container.Last.Next = null);
952 Container.Last.Next := New_Node;
953 New_Node.Prev := Container.Last;
955 Container.Last := New_Node;
957 elsif Before = Container.First then
958 pragma Assert (Container.First.Prev = null);
960 Container.First.Prev := New_Node;
961 New_Node.Next := Container.First;
963 Container.First := New_Node;
966 pragma Assert (Container.First.Prev = null);
967 pragma Assert (Container.Last.Next = null);
969 New_Node.Next := Before;
970 New_Node.Prev := Before.Prev;
972 Before.Prev.Next := New_Node;
973 Before.Prev := New_Node;
976 Container.Length := Container.Length + 1;
983 function Is_Empty (Container : List) return Boolean is
985 return Container.Length = 0;
994 Process : not null access procedure (Position : Cursor))
996 B : Natural renames Container'Unrestricted_Access.all.Busy;
997 Node : Node_Access := Container.First;
1003 while Node /= null loop
1004 Process (Cursor'(Container'Unrestricted_Access, Node));
1018 return List_Iterator_Interfaces.Reversible_Iterator'class
1020 B : Natural renames Container'Unrestricted_Access.all.Busy;
1023 -- The value of the Node component influences the behavior of the First
1024 -- and Last selector functions of the iterator object. When the Node
1025 -- component is null (as is the case here), this means the iterator
1026 -- object was constructed without a start expression. This is a
1027 -- complete iterator, meaning that the iteration starts from the
1028 -- (logical) beginning of the sequence of items.
1030 -- Note: For a forward iterator, Container.First is the beginning, and
1031 -- for a reverse iterator, Container.Last is the beginning.
1033 return It : constant Iterator :=
1034 Iterator'(Limited_Controlled with
1035 Container => Container'Unrestricted_Access,
1045 return List_Iterator_Interfaces.Reversible_Iterator'Class
1047 B : Natural renames Container'Unrestricted_Access.all.Busy;
1050 -- It was formerly the case that when Start = No_Element, the partial
1051 -- iterator was defined to behave the same as for a complete iterator,
1052 -- and iterate over the entire sequence of items. However, those
1053 -- semantics were unintuitive and arguably error-prone (it is too easy
1054 -- to accidentally create an endless loop), and so they were changed,
1055 -- per the ARG meeting in Denver on 2011/11. However, there was no
1056 -- consensus about what positive meaning this corner case should have,
1057 -- and so it was decided to simply raise an exception. This does imply,
1058 -- however, that it is not possible to use a partial iterator to specify
1059 -- an empty sequence of items.
1061 if Start = No_Element then
1062 raise Constraint_Error with
1063 "Start position for iterator equals No_Element";
1066 if Start.Container /= Container'Unrestricted_Access then
1067 raise Program_Error with
1068 "Start cursor of Iterate designates wrong list";
1071 pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
1073 -- The value of the Node component influences the behavior of the First
1074 -- and Last selector functions of the iterator object. When the Node
1075 -- component is non-null (as is the case here), it means that this
1076 -- is a partial iteration, over a subset of the complete sequence of
1077 -- items. The iterator object was constructed with a start expression,
1078 -- indicating the position from which the iteration begins. Note that
1079 -- the start position has the same value irrespective of whether this
1080 -- is a forward or reverse iteration.
1082 return It : constant Iterator :=
1083 Iterator'(Limited_Controlled with
1084 Container => Container'Unrestricted_Access,
1095 function Last (Container : List) return Cursor is
1097 if Container.Last = null then
1101 return Cursor'(Container'Unrestricted_Access, Container.Last);
1104 function Last (Object : Iterator) return Cursor is
1106 -- The value of the iterator object's Node component influences the
1107 -- behavior of the Last (and First) selector function.
1109 -- When the Node component is null, this means the iterator object was
1110 -- constructed without a start expression, in which case the (reverse)
1111 -- iteration starts from the (logical) beginning of the entire sequence
1112 -- (corresponding to Container.Last, for a reverse iterator).
1114 -- Otherwise, this is iteration over a partial sequence of items. When
1115 -- the Node component is non-null, the iterator object was constructed
1116 -- with a start expression, that specifies the position from which the
1117 -- (reverse) partial iteration begins.
1119 if Object.Node = null then
1120 return Indefinite_Doubly_Linked_Lists.Last (Object.Container.all);
1122 return Cursor'(Object.Container, Object.Node);
1130 function Last_Element (Container : List) return Element_Type is
1132 if Container.Last = null then
1133 raise Constraint_Error with "list is empty";
1136 return Container.Last.Element.all;
1143 function Length (Container : List) return Count_Type is
1145 return Container.Length;
1152 procedure Move (Target : in out List; Source : in out List) is
1154 if Target'Address = Source'Address then
1158 if Source.Busy > 0 then
1159 raise Program_Error with
1160 "attempt to tamper with cursors of Source (list is busy)";
1165 Target.First := Source.First;
1166 Source.First := null;
1168 Target.Last := Source.Last;
1169 Source.Last := null;
1171 Target.Length := Source.Length;
1179 procedure Next (Position : in out Cursor) is
1181 Position := Next (Position);
1184 function Next (Position : Cursor) return Cursor is
1186 if Position.Node = null then
1190 pragma Assert (Vet (Position), "bad cursor in Next");
1193 Next_Node : constant Node_Access := Position.Node.Next;
1195 if Next_Node = null then
1199 return Cursor'(Position.Container, Next_Node);
1203 function Next (Object : Iterator; Position : Cursor) return Cursor is
1205 if Position.Container = null then
1209 if Position.Container /= Object.Container then
1210 raise Program_Error with
1211 "Position cursor of Next designates wrong list";
1214 return Next (Position);
1222 (Container : in out List;
1223 New_Item : Element_Type;
1224 Count : Count_Type := 1)
1227 Insert (Container, First (Container), New_Item, Count);
1234 procedure Previous (Position : in out Cursor) is
1236 Position := Previous (Position);
1239 function Previous (Position : Cursor) return Cursor is
1241 if Position.Node = null then
1245 pragma Assert (Vet (Position), "bad cursor in Previous");
1248 Prev_Node : constant Node_Access := Position.Node.Prev;
1250 if Prev_Node = null then
1254 return Cursor'(Position.Container, Prev_Node);
1258 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1260 if Position.Container = null then
1264 if Position.Container /= Object.Container then
1265 raise Program_Error with
1266 "Position cursor of Previous designates wrong list";
1269 return Previous (Position);
1276 procedure Query_Element
1278 Process : not null access procedure (Element : Element_Type))
1281 if Position.Node = null then
1282 raise Constraint_Error with
1283 "Position cursor has no element";
1286 if Position.Node.Element = null then
1287 raise Program_Error with
1288 "Position cursor has no element";
1291 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1294 C : List renames Position.Container.all'Unrestricted_Access.all;
1295 B : Natural renames C.Busy;
1296 L : Natural renames C.Lock;
1303 Process (Position.Node.Element.all);
1321 (Stream : not null access Root_Stream_Type'Class;
1324 N : Count_Type'Base;
1330 Count_Type'Base'Read (Stream, N);
1337 Element : Element_Access :=
1338 new Element_Type'(Element_Type'Input (Stream));
1340 Dst := new Node_Type'(Element, null, null);
1351 while Item.Length < N loop
1353 Element : Element_Access :=
1354 new Element_Type'(Element_Type'Input (Stream));
1356 Dst := new Node_Type'(Element, Next => null, Prev => Item.Last);
1363 Item.Last.Next := Dst;
1365 Item.Length := Item.Length + 1;
1370 (Stream : not null access Root_Stream_Type'Class;
1374 raise Program_Error with "attempt to stream list cursor";
1378 (Stream : not null access Root_Stream_Type'Class;
1379 Item : out Reference_Type)
1382 raise Program_Error with "attempt to stream reference";
1386 (Stream : not null access Root_Stream_Type'Class;
1387 Item : out Constant_Reference_Type)
1390 raise Program_Error with "attempt to stream reference";
1398 (Container : aliased in out List;
1399 Position : Cursor) return Reference_Type
1402 if Position.Container = null then
1403 raise Constraint_Error with "Position cursor has no element";
1406 if Position.Container /= Container'Unrestricted_Access then
1407 raise Program_Error with
1408 "Position cursor designates wrong container";
1411 if Position.Node.Element = null then
1412 raise Program_Error with "Node has no element";
1415 pragma Assert (Vet (Position), "bad cursor in function Reference");
1418 C : List renames Position.Container.all;
1419 B : Natural renames C.Busy;
1420 L : Natural renames C.Lock;
1422 return R : constant Reference_Type :=
1423 (Element => Position.Node.Element.all'Access,
1424 Control => (Controlled with Position.Container))
1432 ---------------------
1433 -- Replace_Element --
1434 ---------------------
1436 procedure Replace_Element
1437 (Container : in out List;
1439 New_Item : Element_Type)
1442 if Position.Container = null then
1443 raise Constraint_Error with "Position cursor has no element";
1446 if Position.Container /= Container'Unchecked_Access then
1447 raise Program_Error with
1448 "Position cursor designates wrong container";
1451 if Container.Lock > 0 then
1452 raise Program_Error with
1453 "attempt to tamper with elements (list is locked)";
1456 if Position.Node.Element = null then
1457 raise Program_Error with
1458 "Position cursor has no element";
1461 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1464 X : Element_Access := Position.Node.Element;
1467 Position.Node.Element := new Element_Type'(New_Item);
1470 end Replace_Element;
1472 ----------------------
1473 -- Reverse_Elements --
1474 ----------------------
1476 procedure Reverse_Elements (Container : in out List) is
1477 I : Node_Access := Container.First;
1478 J : Node_Access := Container.Last;
1480 procedure Swap (L, R : Node_Access);
1486 procedure Swap (L, R : Node_Access) is
1487 LN : constant Node_Access := L.Next;
1488 LP : constant Node_Access := L.Prev;
1490 RN : constant Node_Access := R.Next;
1491 RP : constant Node_Access := R.Prev;
1506 pragma Assert (RP = L);
1520 -- Start of processing for Reverse_Elements
1523 if Container.Length <= 1 then
1527 pragma Assert (Container.First.Prev = null);
1528 pragma Assert (Container.Last.Next = null);
1530 if Container.Busy > 0 then
1531 raise Program_Error with
1532 "attempt to tamper with cursors (list is busy)";
1535 Container.First := J;
1536 Container.Last := I;
1538 Swap (L => I, R => J);
1546 Swap (L => J, R => I);
1555 pragma Assert (Container.First.Prev = null);
1556 pragma Assert (Container.Last.Next = null);
1557 end Reverse_Elements;
1563 function Reverse_Find
1565 Item : Element_Type;
1566 Position : Cursor := No_Element) return Cursor
1568 Node : Node_Access := Position.Node;
1572 Node := Container.Last;
1575 if Node.Element = null then
1576 raise Program_Error with "Position cursor has no element";
1579 if Position.Container /= Container'Unrestricted_Access then
1580 raise Program_Error with
1581 "Position cursor designates wrong container";
1584 pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1587 while Node /= null loop
1588 if Node.Element.all = Item then
1589 return Cursor'(Container'Unrestricted_Access, Node);
1598 ---------------------
1599 -- Reverse_Iterate --
1600 ---------------------
1602 procedure Reverse_Iterate
1604 Process : not null access procedure (Position : Cursor))
1606 C : List renames Container'Unrestricted_Access.all;
1607 B : Natural renames C.Busy;
1609 Node : Node_Access := Container.Last;
1615 while Node /= null loop
1616 Process (Cursor'(Container'Unrestricted_Access, Node));
1626 end Reverse_Iterate;
1633 (Target : in out List;
1635 Source : in out List)
1638 if Before.Container /= null then
1639 if Before.Container /= Target'Unrestricted_Access then
1640 raise Program_Error with
1641 "Before cursor designates wrong container";
1644 if Before.Node = null
1645 or else Before.Node.Element = null
1647 raise Program_Error with
1648 "Before cursor has no element";
1651 pragma Assert (Vet (Before), "bad cursor in Splice");
1654 if Target'Address = Source'Address
1655 or else Source.Length = 0
1660 pragma Assert (Source.First.Prev = null);
1661 pragma Assert (Source.Last.Next = null);
1663 if Target.Length > Count_Type'Last - Source.Length then
1664 raise Constraint_Error with "new length exceeds maximum";
1667 if Target.Busy > 0 then
1668 raise Program_Error with
1669 "attempt to tamper with cursors of Target (list is busy)";
1672 if Source.Busy > 0 then
1673 raise Program_Error with
1674 "attempt to tamper with cursors of Source (list is busy)";
1677 if Target.Length = 0 then
1678 pragma Assert (Before = No_Element);
1679 pragma Assert (Target.First = null);
1680 pragma Assert (Target.Last = null);
1682 Target.First := Source.First;
1683 Target.Last := Source.Last;
1685 elsif Before.Node = null then
1686 pragma Assert (Target.Last.Next = null);
1688 Target.Last.Next := Source.First;
1689 Source.First.Prev := Target.Last;
1691 Target.Last := Source.Last;
1693 elsif Before.Node = Target.First then
1694 pragma Assert (Target.First.Prev = null);
1696 Source.Last.Next := Target.First;
1697 Target.First.Prev := Source.Last;
1699 Target.First := Source.First;
1702 pragma Assert (Target.Length >= 2);
1703 Before.Node.Prev.Next := Source.First;
1704 Source.First.Prev := Before.Node.Prev;
1706 Before.Node.Prev := Source.Last;
1707 Source.Last.Next := Before.Node;
1710 Source.First := null;
1711 Source.Last := null;
1713 Target.Length := Target.Length + Source.Length;
1718 (Container : in out List;
1723 if Before.Container /= null then
1724 if Before.Container /= Container'Unchecked_Access then
1725 raise Program_Error with
1726 "Before cursor designates wrong container";
1729 if Before.Node = null
1730 or else Before.Node.Element = null
1732 raise Program_Error with
1733 "Before cursor has no element";
1736 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1739 if Position.Node = null then
1740 raise Constraint_Error with "Position cursor has no element";
1743 if Position.Node.Element = null then
1744 raise Program_Error with "Position cursor has no element";
1747 if Position.Container /= Container'Unrestricted_Access then
1748 raise Program_Error with
1749 "Position cursor designates wrong container";
1752 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1754 if Position.Node = Before.Node
1755 or else Position.Node.Next = Before.Node
1760 pragma Assert (Container.Length >= 2);
1762 if Container.Busy > 0 then
1763 raise Program_Error with
1764 "attempt to tamper with cursors (list is busy)";
1767 if Before.Node = null then
1768 pragma Assert (Position.Node /= Container.Last);
1770 if Position.Node = Container.First then
1771 Container.First := Position.Node.Next;
1772 Container.First.Prev := null;
1774 Position.Node.Prev.Next := Position.Node.Next;
1775 Position.Node.Next.Prev := Position.Node.Prev;
1778 Container.Last.Next := Position.Node;
1779 Position.Node.Prev := Container.Last;
1781 Container.Last := Position.Node;
1782 Container.Last.Next := null;
1787 if Before.Node = Container.First then
1788 pragma Assert (Position.Node /= Container.First);
1790 if Position.Node = Container.Last then
1791 Container.Last := Position.Node.Prev;
1792 Container.Last.Next := null;
1794 Position.Node.Prev.Next := Position.Node.Next;
1795 Position.Node.Next.Prev := Position.Node.Prev;
1798 Container.First.Prev := Position.Node;
1799 Position.Node.Next := Container.First;
1801 Container.First := Position.Node;
1802 Container.First.Prev := null;
1807 if Position.Node = Container.First then
1808 Container.First := Position.Node.Next;
1809 Container.First.Prev := null;
1811 elsif Position.Node = Container.Last then
1812 Container.Last := Position.Node.Prev;
1813 Container.Last.Next := null;
1816 Position.Node.Prev.Next := Position.Node.Next;
1817 Position.Node.Next.Prev := Position.Node.Prev;
1820 Before.Node.Prev.Next := Position.Node;
1821 Position.Node.Prev := Before.Node.Prev;
1823 Before.Node.Prev := Position.Node;
1824 Position.Node.Next := Before.Node;
1826 pragma Assert (Container.First.Prev = null);
1827 pragma Assert (Container.Last.Next = null);
1831 (Target : in out List;
1833 Source : in out List;
1834 Position : in out Cursor)
1837 if Target'Address = Source'Address then
1838 Splice (Target, Before, Position);
1842 if Before.Container /= null then
1843 if Before.Container /= Target'Unrestricted_Access then
1844 raise Program_Error with
1845 "Before cursor designates wrong container";
1848 if Before.Node = null
1849 or else Before.Node.Element = null
1851 raise Program_Error with
1852 "Before cursor has no element";
1855 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1858 if Position.Node = null then
1859 raise Constraint_Error with "Position cursor has no element";
1862 if Position.Node.Element = null then
1863 raise Program_Error with
1864 "Position cursor has no element";
1867 if Position.Container /= Source'Unrestricted_Access then
1868 raise Program_Error with
1869 "Position cursor designates wrong container";
1872 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1874 if Target.Length = Count_Type'Last then
1875 raise Constraint_Error with "Target is full";
1878 if Target.Busy > 0 then
1879 raise Program_Error with
1880 "attempt to tamper with cursors of Target (list is busy)";
1883 if Source.Busy > 0 then
1884 raise Program_Error with
1885 "attempt to tamper with cursors of Source (list is busy)";
1888 if Position.Node = Source.First then
1889 Source.First := Position.Node.Next;
1891 if Position.Node = Source.Last then
1892 pragma Assert (Source.First = null);
1893 pragma Assert (Source.Length = 1);
1894 Source.Last := null;
1897 Source.First.Prev := null;
1900 elsif Position.Node = Source.Last then
1901 pragma Assert (Source.Length >= 2);
1902 Source.Last := Position.Node.Prev;
1903 Source.Last.Next := null;
1906 pragma Assert (Source.Length >= 3);
1907 Position.Node.Prev.Next := Position.Node.Next;
1908 Position.Node.Next.Prev := Position.Node.Prev;
1911 if Target.Length = 0 then
1912 pragma Assert (Before = No_Element);
1913 pragma Assert (Target.First = null);
1914 pragma Assert (Target.Last = null);
1916 Target.First := Position.Node;
1917 Target.Last := Position.Node;
1919 Target.First.Prev := null;
1920 Target.Last.Next := null;
1922 elsif Before.Node = null then
1923 pragma Assert (Target.Last.Next = null);
1924 Target.Last.Next := Position.Node;
1925 Position.Node.Prev := Target.Last;
1927 Target.Last := Position.Node;
1928 Target.Last.Next := null;
1930 elsif Before.Node = Target.First then
1931 pragma Assert (Target.First.Prev = null);
1932 Target.First.Prev := Position.Node;
1933 Position.Node.Next := Target.First;
1935 Target.First := Position.Node;
1936 Target.First.Prev := null;
1939 pragma Assert (Target.Length >= 2);
1940 Before.Node.Prev.Next := Position.Node;
1941 Position.Node.Prev := Before.Node.Prev;
1943 Before.Node.Prev := Position.Node;
1944 Position.Node.Next := Before.Node;
1947 Target.Length := Target.Length + 1;
1948 Source.Length := Source.Length - 1;
1950 Position.Container := Target'Unchecked_Access;
1958 (Container : in out List;
1962 if I.Node = null then
1963 raise Constraint_Error with "I cursor has no element";
1966 if J.Node = null then
1967 raise Constraint_Error with "J cursor has no element";
1970 if I.Container /= Container'Unchecked_Access then
1971 raise Program_Error with "I cursor designates wrong container";
1974 if J.Container /= Container'Unchecked_Access then
1975 raise Program_Error with "J cursor designates wrong container";
1978 if I.Node = J.Node then
1982 if Container.Lock > 0 then
1983 raise Program_Error with
1984 "attempt to tamper with elements (list is locked)";
1987 pragma Assert (Vet (I), "bad I cursor in Swap");
1988 pragma Assert (Vet (J), "bad J cursor in Swap");
1991 EI_Copy : constant Element_Access := I.Node.Element;
1994 I.Node.Element := J.Node.Element;
1995 J.Node.Element := EI_Copy;
2003 procedure Swap_Links
2004 (Container : in out List;
2008 if I.Node = null then
2009 raise Constraint_Error with "I cursor has no element";
2012 if J.Node = null then
2013 raise Constraint_Error with "J cursor has no element";
2016 if I.Container /= Container'Unrestricted_Access then
2017 raise Program_Error with "I cursor designates wrong container";
2020 if J.Container /= Container'Unrestricted_Access then
2021 raise Program_Error with "J cursor designates wrong container";
2024 if I.Node = J.Node then
2028 if Container.Busy > 0 then
2029 raise Program_Error with
2030 "attempt to tamper with cursors (list is busy)";
2033 pragma Assert (Vet (I), "bad I cursor in Swap_Links");
2034 pragma Assert (Vet (J), "bad J cursor in Swap_Links");
2037 I_Next : constant Cursor := Next (I);
2041 Splice (Container, Before => I, Position => J);
2045 J_Next : constant Cursor := Next (J);
2049 Splice (Container, Before => J, Position => I);
2052 pragma Assert (Container.Length >= 3);
2054 Splice (Container, Before => I_Next, Position => J);
2055 Splice (Container, Before => J_Next, Position => I);
2061 pragma Assert (Container.First.Prev = null);
2062 pragma Assert (Container.Last.Next = null);
2065 --------------------
2066 -- Update_Element --
2067 --------------------
2069 procedure Update_Element
2070 (Container : in out List;
2072 Process : not null access procedure (Element : in out Element_Type))
2075 if Position.Node = null then
2076 raise Constraint_Error with "Position cursor has no element";
2079 if Position.Node.Element = null then
2080 raise Program_Error with
2081 "Position cursor has no element";
2084 if Position.Container /= Container'Unchecked_Access then
2085 raise Program_Error with
2086 "Position cursor designates wrong container";
2089 pragma Assert (Vet (Position), "bad cursor in Update_Element");
2092 B : Natural renames Container.Busy;
2093 L : Natural renames Container.Lock;
2100 Process (Position.Node.Element.all);
2117 function Vet (Position : Cursor) return Boolean is
2119 if Position.Node = null then
2120 return Position.Container = null;
2123 if Position.Container = null then
2127 -- An invariant of a node is that its Previous and Next components can
2128 -- be null, or designate a different node. Also, its element access
2129 -- value must be non-null. Operation Free sets the node access value
2130 -- components of the node to designate the node itself, and the element
2131 -- access value to null, before actually deallocating the node, thus
2132 -- deliberately violating the node invariant. This gives us a simple way
2133 -- to detect a dangling reference to a node.
2135 if Position.Node.Next = Position.Node then
2139 if Position.Node.Prev = Position.Node then
2143 if Position.Node.Element = null then
2147 -- In practice the tests above will detect most instances of a dangling
2148 -- reference. If we get here, it means that the invariants of the
2149 -- designated node are satisfied (they at least appear to be satisfied),
2150 -- so we perform some more tests, to determine whether invariants of the
2151 -- designated list are satisfied too.
2154 L : List renames Position.Container.all;
2157 if L.Length = 0 then
2161 if L.First = null then
2165 if L.Last = null then
2169 if L.First.Prev /= null then
2173 if L.Last.Next /= null then
2177 if Position.Node.Prev = null and then Position.Node /= L.First then
2181 if Position.Node.Next = null and then Position.Node /= L.Last then
2185 if L.Length = 1 then
2186 return L.First = L.Last;
2189 if L.First = L.Last then
2193 if L.First.Next = null then
2197 if L.Last.Prev = null then
2201 if L.First.Next.Prev /= L.First then
2205 if L.Last.Prev.Next /= L.Last then
2209 if L.Length = 2 then
2210 if L.First.Next /= L.Last then
2214 if L.Last.Prev /= L.First then
2221 if L.First.Next = L.Last then
2225 if L.Last.Prev = L.First then
2229 if Position.Node = L.First then
2233 if Position.Node = L.Last then
2237 if Position.Node.Next = null then
2241 if Position.Node.Prev = null then
2245 if Position.Node.Next.Prev /= Position.Node then
2249 if Position.Node.Prev.Next /= Position.Node then
2253 if L.Length = 3 then
2254 if L.First.Next /= Position.Node then
2258 if L.Last.Prev /= Position.Node then
2272 (Stream : not null access Root_Stream_Type'Class;
2275 Node : Node_Access := Item.First;
2278 Count_Type'Base'Write (Stream, Item.Length);
2280 while Node /= null loop
2281 Element_Type'Output (Stream, Node.Element.all);
2287 (Stream : not null access Root_Stream_Type'Class;
2291 raise Program_Error with "attempt to stream list cursor";
2295 (Stream : not null access Root_Stream_Type'Class;
2296 Item : Reference_Type)
2299 raise Program_Error with "attempt to stream reference";
2303 (Stream : not null access Root_Stream_Type'Class;
2304 Item : Constant_Reference_Type)
2307 raise Program_Error with "attempt to stream reference";
2310 end Ada.Containers.Indefinite_Doubly_Linked_Lists;