1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.DOUBLY_LINKED_LISTS --
9 -- Copyright (C) 2004 Free Software Foundation, Inc. --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the contents of the part following the private keyword. --
15 -- GNAT is free software; you can redistribute it and/or modify it under --
16 -- terms of the GNU General Public License as published by the Free Soft- --
17 -- ware Foundation; either version 2, or (at your option) any later ver- --
18 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
21 -- for more details. You should have received a copy of the GNU General --
22 -- Public License distributed with GNAT; see file COPYING. If not, write --
23 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
24 -- MA 02111-1307, USA. --
26 -- As a special exception, if other files instantiate generics from this --
27 -- unit, or you link this unit with other files to produce an executable, --
28 -- this unit does not by itself cause the resulting executable to be --
29 -- covered by the GNU General Public License. This exception does not --
30 -- however invalidate any other reasons why the executable file might be --
31 -- covered by the GNU Public License. --
33 -- This unit was originally developed by Matthew J Heaney. --
34 ------------------------------------------------------------------------------
36 with System; use type System.Address;
37 with Ada.Unchecked_Deallocation;
39 package body Ada.Containers.Doubly_Linked_Lists is
42 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
49 (Container : in out List;
50 Node : in out Node_Access);
52 procedure Insert_Internal
53 (Container : in out List;
55 New_Node : Node_Access);
61 function "=" (Left, Right : List) return Boolean is
62 L : Node_Access := Left.First;
63 R : Node_Access := Right.First;
66 if Left'Address = Right'Address then
70 if Left.Length /= Right.Length then
74 for J in 1 .. Left.Length loop
75 if L.Element /= R.Element then
90 procedure Adjust (Container : in out List) is
91 Src : Node_Access := Container.First;
92 Length : constant Count_Type := Container.Length;
96 pragma Assert (Container.Last = null);
97 pragma Assert (Length = 0);
101 pragma Assert (Container.First.Prev = null);
102 pragma Assert (Container.Last.Next = null);
103 pragma Assert (Length > 0);
105 Container.First := null;
106 Container.Last := null;
107 Container.Length := 0;
109 Container.First := new Node_Type'(Src.Element, null, null);
111 Container.Last := Container.First;
113 Container.Length := Container.Length + 1;
115 exit when Src = null;
116 Container.Last.Next := new Node_Type'(Element => Src.Element,
117 Prev => Container.Last,
119 Container.Last := Container.Last.Next;
122 pragma Assert (Container.Length = Length);
130 (Container : in out List;
131 New_Item : Element_Type;
132 Count : Count_Type := 1)
135 Insert (Container, No_Element, New_Item, Count);
142 procedure Clear (Container : in out List) is
144 Delete_Last (Container, Count => Container.Length);
153 Item : Element_Type) return Boolean
156 return Find (Container, Item) /= No_Element;
164 (Container : in out List;
165 Position : in out Cursor;
166 Count : Count_Type := 1)
169 if Position = No_Element then
173 if Position.Container /= List_Access'(Container'Unchecked_Access) then
177 for Index in 1 .. Count loop
178 Delete_Node (Container, Position.Node);
180 if Position.Node = null then
181 Position.Container := null;
191 procedure Delete_First
192 (Container : in out List;
193 Count : Count_Type := 1)
195 Node : Node_Access := Container.First;
197 for J in 1 .. Count_Type'Min (Count, Container.Length) loop
198 Delete_Node (Container, Node);
206 procedure Delete_Last
207 (Container : in out List;
208 Count : Count_Type := 1)
212 for J in 1 .. Count_Type'Min (Count, Container.Length) loop
213 Node := Container.Last;
214 Delete_Node (Container, Node);
222 procedure Delete_Node
223 (Container : in out List;
224 Node : in out Node_Access)
226 X : Node_Access := Node;
230 Container.Length := Container.Length - 1;
232 if X = Container.First then
233 Container.First := X.Next;
235 if X = Container.Last then
236 pragma Assert (Container.First = null);
237 pragma Assert (Container.Length = 0);
238 Container.Last := null;
240 pragma Assert (Container.Length > 0);
241 Container.First.Prev := null;
244 elsif X = Container.Last then
245 pragma Assert (Container.Length > 0);
247 Container.Last := X.Prev;
248 Container.Last.Next := null;
251 pragma Assert (Container.Length > 0);
253 X.Next.Prev := X.Prev;
254 X.Prev.Next := X.Next;
264 function Element (Position : Cursor) return Element_Type is
266 return Position.Node.Element;
276 Position : Cursor := No_Element) return Cursor
278 Node : Node_Access := Position.Node;
282 Node := Container.First;
283 elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
287 while Node /= null loop
288 if Node.Element = Item then
289 return Cursor'(Container'Unchecked_Access, Node);
302 function First (Container : List) return Cursor is
304 if Container.First = null then
308 return Cursor'(Container'Unchecked_Access, Container.First);
315 function First_Element (Container : List) return Element_Type is
317 return Container.First.Element;
324 procedure Generic_Merge
325 (Target : in out List;
326 Source : in out List)
328 LI : Cursor := First (Target);
329 RI : Cursor := First (Source);
332 if Target'Address = Source'Address then
336 while RI.Node /= null loop
337 if LI.Node = null then
338 Splice (Target, No_Element, Source);
342 if RI.Node.Element < LI.Node.Element then
344 RJ : constant Cursor := RI;
346 RI.Node := RI.Node.Next;
347 Splice (Target, LI, Source, RJ);
351 LI.Node := LI.Node.Next;
360 procedure Generic_Sort (Container : in out List) is
363 (Pivot : in Node_Access;
364 Back : in Node_Access);
366 procedure Sort (Front, Back : Node_Access);
373 (Pivot : Node_Access;
376 Node : Node_Access := Pivot.Next;
379 while Node /= Back loop
380 if Node.Element < Pivot.Element then
382 Prev : constant Node_Access := Node.Prev;
383 Next : constant Node_Access := Node.Next;
389 Container.Last := Prev;
395 Node.Prev := Pivot.Prev;
399 if Node.Prev = null then
400 Container.First := Node;
402 Node.Prev.Next := Node;
418 procedure Sort (Front, Back : Node_Access) is
423 Pivot := Container.First;
428 if Pivot /= Back then
429 Partition (Pivot, Back);
435 -- Start of processing for Generic_Sort
438 Sort (Front => null, Back => null);
440 pragma Assert (Container.Length = 0
442 (Container.First.Prev = null
443 and then Container.Last.Next = null));
450 function Has_Element (Position : Cursor) return Boolean is
452 return Position.Container /= null and then Position.Node /= null;
460 (Container : in out List;
462 New_Item : Element_Type;
463 Position : out Cursor;
464 Count : Count_Type := 1)
466 New_Node : Node_Access;
469 if Before.Container /= null
470 and then Before.Container /= List_Access'(Container'Unchecked_Access)
480 New_Node := new Node_Type'(New_Item, null, null);
481 Insert_Internal (Container, Before.Node, New_Node);
483 Position := Cursor'(Before.Container, New_Node);
485 for J in Count_Type'(2) .. Count loop
486 New_Node := new Node_Type'(New_Item, null, null);
487 Insert_Internal (Container, Before.Node, New_Node);
492 (Container : in out List;
494 New_Item : Element_Type;
495 Count : Count_Type := 1)
499 Insert (Container, Before, New_Item, Position, Count);
503 (Container : in out List;
505 Position : out Cursor;
506 Count : Count_Type := 1)
508 New_Node : Node_Access;
511 if Before.Container /= null
512 and then Before.Container /= List_Access'(Container'Unchecked_Access)
522 New_Node := new Node_Type;
523 Insert_Internal (Container, Before.Node, New_Node);
525 Position := Cursor'(Before.Container, New_Node);
527 for J in Count_Type'(2) .. Count loop
528 New_Node := new Node_Type;
529 Insert_Internal (Container, Before.Node, New_Node);
533 ---------------------
534 -- Insert_Internal --
535 ---------------------
537 procedure Insert_Internal
538 (Container : in out List;
539 Before : Node_Access;
540 New_Node : Node_Access)
543 if Container.Length = 0 then
544 pragma Assert (Before = null);
545 pragma Assert (Container.First = null);
546 pragma Assert (Container.Last = null);
548 Container.First := New_Node;
549 Container.Last := New_Node;
551 elsif Before = null then
552 pragma Assert (Container.Last.Next = null);
554 Container.Last.Next := New_Node;
555 New_Node.Prev := Container.Last;
557 Container.Last := New_Node;
559 elsif Before = Container.First then
560 pragma Assert (Container.First.Prev = null);
562 Container.First.Prev := New_Node;
563 New_Node.Next := Container.First;
565 Container.First := New_Node;
568 pragma Assert (Container.First.Prev = null);
569 pragma Assert (Container.Last.Next = null);
571 New_Node.Next := Before;
572 New_Node.Prev := Before.Prev;
574 Before.Prev.Next := New_Node;
575 Before.Prev := New_Node;
578 Container.Length := Container.Length + 1;
585 function Is_Empty (Container : List) return Boolean is
587 return Container.Length = 0;
596 Process : not null access procedure (Position : Cursor))
598 Node : Node_Access := Container.First;
600 while Node /= null loop
601 Process (Cursor'(Container'Unchecked_Access, Node));
610 function Last (Container : List) return Cursor is
612 if Container.Last = null then
616 return Cursor'(Container'Unchecked_Access, Container.Last);
623 function Last_Element (Container : List) return Element_Type is
625 return Container.Last.Element;
632 function Length (Container : List) return Count_Type is
634 return Container.Length;
642 (Target : in out List;
643 Source : in out List)
646 if Target'Address = Source'Address then
650 if Target.Length > 0 then
651 raise Constraint_Error;
654 Target.First := Source.First;
655 Source.First := null;
657 Target.Last := Source.Last;
660 Target.Length := Source.Length;
668 procedure Next (Position : in out Cursor) is
670 if Position.Node = null then
674 Position.Node := Position.Node.Next;
676 if Position.Node = null then
677 Position.Container := null;
681 function Next (Position : Cursor) return Cursor is
683 if Position.Node = null then
688 Next_Node : constant Node_Access := Position.Node.Next;
690 if Next_Node = null then
694 return Cursor'(Position.Container, Next_Node);
703 (Container : in out List;
704 New_Item : Element_Type;
705 Count : Count_Type := 1)
708 Insert (Container, First (Container), New_Item, Count);
715 procedure Previous (Position : in out Cursor) is
717 if Position.Node = null then
721 Position.Node := Position.Node.Prev;
723 if Position.Node = null then
724 Position.Container := null;
728 function Previous (Position : Cursor) return Cursor is
730 if Position.Node = null then
735 Prev_Node : constant Node_Access := Position.Node.Prev;
737 if Prev_Node = null then
741 return Cursor'(Position.Container, Prev_Node);
749 procedure Query_Element
751 Process : not null access procedure (Element : in Element_Type))
754 Process (Position.Node.Element);
762 (Stream : access Root_Stream_Type'Class;
770 Count_Type'Base'Read (Stream, N);
779 Element_Type'Read (Stream, X.Element);
790 Item.Length := Item.Length + 1;
791 exit when Item.Length = N;
796 Element_Type'Read (Stream, X.Element);
809 ---------------------
810 -- Replace_Element --
811 ---------------------
813 procedure Replace_Element
818 Position.Node.Element := By;
825 function Reverse_Find
828 Position : Cursor := No_Element) return Cursor
830 Node : Node_Access := Position.Node;
834 Node := Container.Last;
835 elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
839 while Node /= null loop
840 if Node.Element = Item then
841 return Cursor'(Container'Unchecked_Access, Node);
850 ---------------------
851 -- Reverse_Iterate --
852 ---------------------
854 procedure Reverse_Iterate
856 Process : not null access procedure (Position : Cursor))
858 Node : Node_Access := Container.Last;
860 while Node /= null loop
861 Process (Cursor'(Container'Unchecked_Access, Node));
870 procedure Reverse_List (Container : in out List) is
871 I : Node_Access := Container.First;
872 J : Node_Access := Container.Last;
874 procedure Swap (L, R : Node_Access);
880 procedure Swap (L, R : Node_Access) is
881 LN : constant Node_Access := L.Next;
882 LP : constant Node_Access := L.Prev;
884 RN : constant Node_Access := R.Next;
885 RP : constant Node_Access := R.Prev;
900 pragma Assert (RP = L);
914 -- Start of processing for Reverse_List
917 if Container.Length <= 1 then
921 Container.First := J;
924 Swap (L => I, R => J);
932 Swap (L => J, R => I);
941 pragma Assert (Container.First.Prev = null);
942 pragma Assert (Container.Last.Next = null);
950 (Target : in out List;
952 Source : in out List)
955 if Before.Container /= null
956 and then Before.Container /= List_Access'(Target'Unchecked_Access)
961 if Target'Address = Source'Address
962 or else Source.Length = 0
967 if Target.Length = 0 then
968 pragma Assert (Before = No_Element);
970 Target.First := Source.First;
971 Target.Last := Source.Last;
973 elsif Before.Node = null then
974 pragma Assert (Target.Last.Next = null);
976 Target.Last.Next := Source.First;
977 Source.First.Prev := Target.Last;
979 Target.Last := Source.Last;
981 elsif Before.Node = Target.First then
982 pragma Assert (Target.First.Prev = null);
984 Source.Last.Next := Target.First;
985 Target.First.Prev := Source.Last;
987 Target.First := Source.First;
990 Before.Node.Prev.Next := Source.First;
991 Source.First.Prev := Before.Node.Prev;
993 Before.Node.Prev := Source.Last;
994 Source.Last.Next := Before.Node;
997 Source.First := null;
1000 Target.Length := Target.Length + Source.Length;
1005 (Target : in out List;
1009 X : Node_Access := Position.Node;
1012 if Before.Container /= null
1013 and then Before.Container /= List_Access'(Target'Unchecked_Access)
1015 raise Program_Error;
1018 if Position.Container /= null
1019 and then Position.Container /= List_Access'(Target'Unchecked_Access)
1021 raise Program_Error;
1025 or else X = Before.Node
1026 or else X.Next = Before.Node
1031 pragma Assert (Target.Length > 0);
1033 if Before.Node = null then
1034 pragma Assert (X /= Target.Last);
1036 if X = Target.First then
1037 Target.First := X.Next;
1038 Target.First.Prev := null;
1040 X.Prev.Next := X.Next;
1041 X.Next.Prev := X.Prev;
1044 Target.Last.Next := X;
1045 X.Prev := Target.Last;
1048 Target.Last.Next := null;
1053 if Before.Node = Target.First then
1054 pragma Assert (X /= Target.First);
1056 if X = Target.Last then
1057 Target.Last := X.Prev;
1058 Target.Last.Next := null;
1060 X.Prev.Next := X.Next;
1061 X.Next.Prev := X.Prev;
1064 Target.First.Prev := X;
1065 X.Next := Target.First;
1068 Target.First.Prev := null;
1073 if X = Target.First then
1074 Target.First := X.Next;
1075 Target.First.Prev := null;
1077 elsif X = Target.Last then
1078 Target.Last := X.Prev;
1079 Target.Last.Next := null;
1082 X.Prev.Next := X.Next;
1083 X.Next.Prev := X.Prev;
1086 Before.Node.Prev.Next := X;
1087 X.Prev := Before.Node.Prev;
1089 Before.Node.Prev := X;
1090 X.Next := Before.Node;
1094 (Target : in out List;
1096 Source : in out List;
1099 X : Node_Access := Position.Node;
1102 if Target'Address = Source'Address then
1103 Splice (Target, Before, Position);
1107 if Before.Container /= null
1108 and then Before.Container /= List_Access'(Target'Unchecked_Access)
1110 raise Program_Error;
1113 if Position.Container /= null
1114 and then Position.Container /= List_Access'(Source'Unchecked_Access)
1116 raise Program_Error;
1123 pragma Assert (Source.Length > 0);
1124 pragma Assert (Source.First.Prev = null);
1125 pragma Assert (Source.Last.Next = null);
1127 if X = Source.First then
1128 Source.First := X.Next;
1129 Source.First.Prev := null;
1131 if X = Source.Last then
1132 pragma Assert (Source.First = null);
1133 pragma Assert (Source.Length = 1);
1134 Source.Last := null;
1137 elsif X = Source.Last then
1138 Source.Last := X.Prev;
1139 Source.Last.Next := null;
1142 X.Prev.Next := X.Next;
1143 X.Next.Prev := X.Prev;
1146 if Target.Length = 0 then
1147 pragma Assert (Before = No_Element);
1148 pragma Assert (Target.First = null);
1149 pragma Assert (Target.Last = null);
1154 elsif Before.Node = null then
1155 Target.Last.Next := X;
1156 X.Next := Target.Last;
1159 Target.Last.Next := null;
1161 elsif Before.Node = Target.First then
1162 Target.First.Prev := X;
1163 X.Next := Target.First;
1166 Target.First.Prev := null;
1169 Before.Node.Prev.Next := X;
1170 X.Prev := Before.Node.Prev;
1172 Before.Node.Prev := X;
1173 X.Next := Before.Node;
1176 Target.Length := Target.Length + 1;
1177 Source.Length := Source.Length - 1;
1184 -- Is this defined when I and J designate elements in different containers,
1185 -- or should it raise an exception (Program_Error)???
1187 procedure Swap (I, J : in Cursor) is
1188 EI : constant Element_Type := I.Node.Element;
1190 I.Node.Element := J.Node.Element;
1191 J.Node.Element := EI;
1198 procedure Swap_Links
1199 (Container : in out List;
1204 or else J = No_Element
1206 raise Constraint_Error;
1209 if I.Container /= List_Access'(Container'Unchecked_Access) then
1210 raise Program_Error;
1213 if J.Container /= I.Container then
1214 raise Program_Error;
1217 pragma Assert (Container.Length >= 1);
1219 if I.Node = J.Node then
1223 pragma Assert (Container.Length >= 2);
1226 I_Next : constant Cursor := Next (I);
1230 Splice (Container, Before => I, Position => J);
1234 J_Next : constant Cursor := Next (J);
1238 Splice (Container, Before => J, Position => I);
1241 pragma Assert (Container.Length >= 3);
1243 Splice (Container, Before => I_Next, Position => J);
1244 Splice (Container, Before => J_Next, Position => I);
1251 --------------------
1252 -- Update_Element --
1253 --------------------
1255 procedure Update_Element
1257 Process : not null access procedure (Element : in out Element_Type)) is
1259 Process (Position.Node.Element);
1267 (Stream : access Root_Stream_Type'Class;
1270 Node : Node_Access := Item.First;
1273 Count_Type'Base'Write (Stream, Item.Length);
1275 while Node /= null loop
1276 Element_Type'Write (Stream, Node.Element);
1281 end Ada.Containers.Doubly_Linked_Lists;