1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_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
.Indefinite_Doubly_Linked_Lists
is
42 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
45 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
47 -----------------------
48 -- Local Subprograms --
49 -----------------------
52 (Container
: in out List
;
53 Node
: in out Node_Access
);
55 procedure Insert_Internal
56 (Container
: in out List
;
58 New_Node
: Node_Access
);
64 function "=" (Left
, Right
: List
) return Boolean is
69 if Left
'Address = Right
'Address then
73 if Left
.Length
/= Right
.Length
then
79 for J
in 1 .. Left
.Length
loop
80 if L
.Element
= null then
81 if R
.Element
/= null then
85 elsif R
.Element
= null then
88 elsif L
.Element
.all /= R
.Element
.all then
103 procedure Adjust
(Container
: in out List
) is
104 Src
: Node_Access
:= Container
.First
;
109 pragma Assert
(Container
.Last
= null);
110 pragma Assert
(Container
.Length
= 0);
114 pragma Assert
(Container
.First
.Prev
= null);
115 pragma Assert
(Container
.Last
.Next
= null);
116 pragma Assert
(Container
.Length
> 0);
118 Container
.First
:= null;
119 Container
.Last
:= null;
120 Container
.Length
:= 0;
122 Dst
:= new Node_Type
'(null, null, null);
124 if Src.Element /= null then
126 Dst.Element := new Element_Type'(Src
.Element
.all);
134 Container
.First
:= Dst
;
136 Container
.Last
:= Dst
;
138 Container
.Length
:= Container
.Length
+ 1;
140 exit when Src
= null;
142 Dst
:= new Node_Type
'(null, Prev => Container.Last, Next => null);
144 if Src.Element /= null then
146 Dst.Element := new Element_Type'(Src
.Element
.all);
154 Container
.Last
.Next
:= Dst
;
155 Container
.Last
:= Dst
;
164 (Container
: in out List
;
165 New_Item
: Element_Type
;
166 Count
: Count_Type
:= 1)
169 Insert
(Container
, No_Element
, New_Item
, Count
);
176 procedure Clear
(Container
: in out List
) is
178 Delete_Last
(Container
, Count
=> Container
.Length
);
187 Item
: Element_Type
) return Boolean is
189 return Find
(Container
, Item
) /= No_Element
;
197 (Container
: in out List
;
198 Position
: in out Cursor
;
199 Count
: Count_Type
:= 1)
202 if Position
= No_Element
then
206 if Position
.Container
/= List_Access
'(Container'Unchecked_Access) then
210 for Index in 1 .. Count loop
211 Delete_Node (Container, Position.Node);
213 if Position.Node = null then
214 Position.Container := null;
224 procedure Delete_First
225 (Container : in out List;
226 Count : Count_Type := 1)
228 Node : Node_Access := Container.First;
230 for J in 1 .. Count_Type'Min (Count, Container.Length) loop
231 Delete_Node (Container, Node);
239 procedure Delete_Last
240 (Container : in out List;
241 Count : Count_Type := 1)
245 for J in 1 .. Count_Type'Min (Count, Container.Length) loop
246 Node := Container.Last;
247 Delete_Node (Container, Node);
255 procedure Delete_Node
256 (Container : in out List;
257 Node : in out Node_Access)
259 X : Node_Access := Node;
263 Container.Length := Container.Length - 1;
265 if X = Container.First then
266 Container.First := X.Next;
268 if X = Container.Last then
269 pragma Assert (Container.First = null);
270 pragma Assert (Container.Length = 0);
271 Container.Last := null;
273 pragma Assert (Container.Length > 0);
274 Container.First.Prev := null;
277 elsif X = Container.Last then
278 pragma Assert (Container.Length > 0);
280 Container.Last := X.Prev;
281 Container.Last.Next := null;
284 pragma Assert (Container.Length > 0);
286 X.Next.Prev := X.Prev;
287 X.Prev.Next := X.Next;
299 function Element (Position : Cursor) return Element_Type is
301 return Position.Node.Element.all;
311 Position : Cursor := No_Element) return Cursor
313 Node : Node_Access := Position.Node;
317 Node := Container.First;
318 elsif Position.Container /= List_Access'(Container
'Unchecked_Access) then
322 while Node
/= null loop
323 if Node
.Element
/= null
324 and then Node
.Element
.all = Item
326 return Cursor
'(Container'Unchecked_Access, Node);
339 function First (Container : List) return Cursor is
341 if Container.First = null then
345 return Cursor'(Container
'Unchecked_Access, Container
.First
);
352 function First_Element
(Container
: List
) return Element_Type
is
354 return Container
.First
.Element
.all;
361 procedure Generic_Merge
362 (Target
: in out List
;
363 Source
: in out List
)
369 if Target
'Address = Source
'Address then
373 LI
:= First
(Target
);
374 RI
:= First
(Source
);
375 while RI
.Node
/= null loop
376 if LI
.Node
= null then
377 Splice
(Target
, No_Element
, Source
);
381 if LI
.Node
.Element
= null then
382 LI
.Node
:= LI
.Node
.Next
;
384 elsif RI
.Node
.Element
= null
385 or else RI
.Node
.Element
.all < LI
.Node
.Element
.all
388 RJ
: constant Cursor
:= RI
;
390 RI
.Node
:= RI
.Node
.Next
;
391 Splice
(Target
, LI
, Source
, RJ
);
395 LI
.Node
:= LI
.Node
.Next
;
404 procedure Generic_Sort
(Container
: in out List
) is
405 procedure Partition
(Pivot
: Node_Access
; Back
: Node_Access
);
407 procedure Sort
(Front
, Back
: Node_Access
);
413 procedure Partition
(Pivot
: Node_Access
; Back
: Node_Access
) is
414 Node
: Node_Access
:= Pivot
.Next
;
417 while Node
/= Back
loop
418 if Pivot
.Element
= null then
421 elsif Node
.Element
= null
422 or else Node
.Element
.all < Pivot
.Element
.all
425 Prev
: constant Node_Access
:= Node
.Prev
;
426 Next
: constant Node_Access
:= Node
.Next
;
431 Container
.Last
:= Prev
;
437 Node
.Prev
:= Pivot
.Prev
;
441 if Node
.Prev
= null then
442 Container
.First
:= Node
;
444 Node
.Prev
.Next
:= Node
;
460 procedure Sort
(Front
, Back
: Node_Access
) is
465 Pivot
:= Container
.First
;
470 if Pivot
/= Back
then
471 Partition
(Pivot
, Back
);
477 -- Start of processing for Generic_Sort
480 Sort
(Front
=> null, Back
=> null);
482 pragma Assert
(Container
.Length
= 0
483 or else (Container
.First
.Prev
= null
484 and Container
.Last
.Next
= null));
491 function Has_Element
(Position
: Cursor
) return Boolean is
493 return Position
.Container
/= null and then Position
.Node
/= null;
501 (Container
: in out List
;
503 New_Item
: Element_Type
;
504 Position
: out Cursor
;
505 Count
: Count_Type
:= 1)
507 New_Node
: Node_Access
;
510 if Before
.Container
/= null
511 and then Before
.Container
/= List_Access
'(Container'Unchecked_Access)
522 Element : Element_Access := new Element_Type'(New_Item
);
524 New_Node
:= new Node_Type
'(Element, null, null);
531 Insert_Internal (Container, Before.Node, New_Node);
532 Position := Cursor'(Before
.Container
, New_Node
);
534 for J
in Count_Type
'(2) .. Count loop
537 Element : Element_Access := new Element_Type'(New_Item
);
539 New_Node
:= new Node_Type
'(Element, null, null);
546 Insert_Internal (Container, Before.Node, New_Node);
551 (Container : in out List;
553 New_Item : Element_Type;
554 Count : Count_Type := 1)
558 Insert (Container, Before, New_Item, Position, Count);
561 ---------------------
562 -- Insert_Internal --
563 ---------------------
565 procedure Insert_Internal
566 (Container : in out List;
567 Before : Node_Access;
568 New_Node : Node_Access)
571 if Container.Length = 0 then
572 pragma Assert (Before = null);
573 pragma Assert (Container.First = null);
574 pragma Assert (Container.Last = null);
576 Container.First := New_Node;
577 Container.Last := New_Node;
579 elsif Before = null then
580 pragma Assert (Container.Last.Next = null);
582 Container.Last.Next := New_Node;
583 New_Node.Prev := Container.Last;
585 Container.Last := New_Node;
587 elsif Before = Container.First then
588 pragma Assert (Container.First.Prev = null);
590 Container.First.Prev := New_Node;
591 New_Node.Next := Container.First;
593 Container.First := New_Node;
596 pragma Assert (Container.First.Prev = null);
597 pragma Assert (Container.Last.Next = null);
599 New_Node.Next := Before;
600 New_Node.Prev := Before.Prev;
602 Before.Prev.Next := New_Node;
603 Before.Prev := New_Node;
606 Container.Length := Container.Length + 1;
613 function Is_Empty (Container : List) return Boolean is
615 return Container.Length = 0;
624 Process : not null access procedure (Position : in Cursor))
626 Node : Node_Access := Container.First;
628 while Node /= null loop
629 Process (Cursor'(Container
'Unchecked_Access, Node
));
638 procedure Move
(Target
: in out List
; Source
: in out List
) is
640 if Target
'Address = Source
'Address then
644 if Target
.Length
> 0 then
645 raise Constraint_Error
;
648 Target
.First
:= Source
.First
;
649 Source
.First
:= null;
651 Target
.Last
:= Source
.Last
;
654 Target
.Length
:= Source
.Length
;
662 function Last
(Container
: List
) return Cursor
is
664 if Container
.Last
= null then
668 return Cursor
'(Container'Unchecked_Access, Container.Last);
675 function Last_Element (Container : List) return Element_Type is
677 return Container.Last.Element.all;
684 function Length (Container : List) return Count_Type is
686 return Container.Length;
693 procedure Next (Position : in out Cursor) is
695 if Position.Node = null then
699 Position.Node := Position.Node.Next;
701 if Position.Node = null then
702 Position.Container := null;
706 function Next (Position : Cursor) return Cursor is
708 if Position.Node = null then
713 Next_Node : constant Node_Access := Position.Node.Next;
715 if Next_Node = null then
719 return Cursor'(Position
.Container
, Next_Node
);
728 (Container
: in out List
;
729 New_Item
: Element_Type
;
730 Count
: Count_Type
:= 1)
733 Insert
(Container
, First
(Container
), New_Item
, Count
);
740 procedure Previous
(Position
: in out Cursor
) is
742 if Position
.Node
= null then
746 Position
.Node
:= Position
.Node
.Prev
;
748 if Position
.Node
= null then
749 Position
.Container
:= null;
753 function Previous
(Position
: Cursor
) return Cursor
is
755 if Position
.Node
= null then
760 Prev_Node
: constant Node_Access
:= Position
.Node
.Prev
;
762 if Prev_Node
= null then
766 return Cursor
'(Position.Container, Prev_Node);
774 procedure Query_Element
776 Process : not null access procedure (Element : in Element_Type))
779 Process (Position.Node.Element.all);
787 (Stream : access Root_Stream_Type'Class;
796 Count_Type'Base'Read
(Stream
, N
);
805 X
.Element
:= new Element_Type
'(Element_Type'Input (Stream));
816 Item.Length := Item.Length + 1;
817 exit when Item.Length = N;
822 X.Element := new Element_Type'(Element_Type
'Input (Stream
));
835 ---------------------
836 -- Replace_Element --
837 ---------------------
839 procedure Replace_Element
843 X
: Element_Access
:= Position
.Node
.Element
;
845 Position
.Node
.Element
:= new Element_Type
'(By);
853 function Reverse_Find
856 Position : Cursor := No_Element) return Cursor
858 Node : Node_Access := Position.Node;
862 Node := Container.Last;
863 elsif Position.Container /= List_Access'(Container
'Unchecked_Access) then
867 while Node
/= null loop
868 if Node
.Element
/= null
869 and then Node
.Element
.all = Item
871 return Cursor
'(Container'Unchecked_Access, Node);
880 ---------------------
881 -- Reverse_Iterate --
882 ---------------------
884 procedure Reverse_Iterate
886 Process : not null access procedure (Position : in Cursor))
888 Node : Node_Access := Container.Last;
891 while Node /= null loop
892 Process (Cursor'(Container
'Unchecked_Access, Node
));
901 procedure Reverse_List
(Container
: in out List
) is
902 I
: Node_Access
:= Container
.First
;
903 J
: Node_Access
:= Container
.Last
;
905 procedure Swap
(L
, R
: Node_Access
);
911 procedure Swap
(L
, R
: Node_Access
) is
912 LN
: constant Node_Access
:= L
.Next
;
913 LP
: constant Node_Access
:= L
.Prev
;
915 RN
: constant Node_Access
:= R
.Next
;
916 RP
: constant Node_Access
:= R
.Prev
;
931 pragma Assert
(RP
= L
);
945 -- Start of processing for Reverse_List
948 if Container
.Length
<= 1 then
952 Container
.First
:= J
;
955 Swap
(L
=> I
, R
=> J
);
963 Swap
(L
=> J
, R
=> I
);
972 pragma Assert
(Container
.First
.Prev
= null);
973 pragma Assert
(Container
.Last
.Next
= null);
981 (Target
: in out List
;
983 Source
: in out List
)
986 if Before
.Container
/= null
987 and then Before
.Container
/= List_Access
'(Target'Unchecked_Access)
992 if Target'Address = Source'Address
993 or else Source.Length = 0
998 if Target.Length = 0 then
999 pragma Assert (Before = No_Element);
1001 Target.First := Source.First;
1002 Target.Last := Source.Last;
1004 elsif Before.Node = null then
1005 pragma Assert (Target.Last.Next = null);
1007 Target.Last.Next := Source.First;
1008 Source.First.Prev := Target.Last;
1010 Target.Last := Source.Last;
1012 elsif Before.Node = Target.First then
1013 pragma Assert (Target.First.Prev = null);
1015 Source.Last.Next := Target.First;
1016 Target.First.Prev := Source.Last;
1018 Target.First := Source.First;
1021 Before.Node.Prev.Next := Source.First;
1022 Source.First.Prev := Before.Node.Prev;
1024 Before.Node.Prev := Source.Last;
1025 Source.Last.Next := Before.Node;
1028 Source.First := null;
1029 Source.Last := null;
1031 Target.Length := Target.Length + Source.Length;
1036 (Target : in out List;
1040 X : Node_Access := Position.Node;
1043 if Before.Container /= null
1044 and then Before.Container /= List_Access'(Target
'Unchecked_Access)
1046 raise Program_Error
;
1049 if Position
.Container
/= null
1050 and then Position
.Container
/= List_Access
'(Target'Unchecked_Access)
1052 raise Program_Error;
1056 or else X = Before.Node
1057 or else X.Next = Before.Node
1062 pragma Assert (Target.Length > 0);
1064 if Before.Node = null then
1065 pragma Assert (X /= Target.Last);
1067 if X = Target.First then
1068 Target.First := X.Next;
1069 Target.First.Prev := null;
1071 X.Prev.Next := X.Next;
1072 X.Next.Prev := X.Prev;
1075 Target.Last.Next := X;
1076 X.Prev := Target.Last;
1079 Target.Last.Next := null;
1084 if Before.Node = Target.First then
1085 pragma Assert (X /= Target.First);
1087 if X = Target.Last then
1088 Target.Last := X.Prev;
1089 Target.Last.Next := null;
1091 X.Prev.Next := X.Next;
1092 X.Next.Prev := X.Prev;
1095 Target.First.Prev := X;
1096 X.Next := Target.First;
1099 Target.First.Prev := null;
1104 if X = Target.First then
1105 Target.First := X.Next;
1106 Target.First.Prev := null;
1108 elsif X = Target.Last then
1109 Target.Last := X.Prev;
1110 Target.Last.Next := null;
1113 X.Prev.Next := X.Next;
1114 X.Next.Prev := X.Prev;
1117 Before.Node.Prev.Next := X;
1118 X.Prev := Before.Node.Prev;
1120 Before.Node.Prev := X;
1121 X.Next := Before.Node;
1125 (Target : in out List;
1127 Source : in out List;
1130 X : Node_Access := Position.Node;
1133 if Target'Address = Source'Address then
1134 Splice (Target, Before, Position);
1138 if Before.Container /= null
1139 and then Before.Container /= List_Access'(Target
'Unchecked_Access)
1141 raise Program_Error
;
1144 if Position
.Container
/= null
1145 and then Position
.Container
/= List_Access
'(Source'Unchecked_Access)
1147 raise Program_Error;
1154 pragma Assert (Source.Length > 0);
1155 pragma Assert (Source.First.Prev = null);
1156 pragma Assert (Source.Last.Next = null);
1158 if X = Source.First then
1159 Source.First := X.Next;
1160 Source.First.Prev := null;
1162 if X = Source.Last then
1163 pragma Assert (Source.First = null);
1164 pragma Assert (Source.Length = 1);
1165 Source.Last := null;
1168 elsif X = Source.Last then
1169 Source.Last := X.Prev;
1170 Source.Last.Next := null;
1173 X.Prev.Next := X.Next;
1174 X.Next.Prev := X.Prev;
1177 if Target.Length = 0 then
1178 pragma Assert (Before = No_Element);
1179 pragma Assert (Target.First = null);
1180 pragma Assert (Target.Last = null);
1185 elsif Before.Node = null then
1186 Target.Last.Next := X;
1187 X.Next := Target.Last;
1190 Target.Last.Next := null;
1192 elsif Before.Node = Target.First then
1193 Target.First.Prev := X;
1194 X.Next := Target.First;
1197 Target.First.Prev := null;
1200 Before.Node.Prev.Next := X;
1201 X.Prev := Before.Node.Prev;
1203 Before.Node.Prev := X;
1204 X.Next := Before.Node;
1207 Target.Length := Target.Length + 1;
1208 Source.Length := Source.Length - 1;
1215 procedure Swap (I, J : Cursor) is
1217 -- Is this op legal when I and J designate elements in different
1218 -- containers, or should it raise an exception (e.g. Program_Error).
1220 EI : constant Element_Access := I.Node.Element;
1223 I.Node.Element := J.Node.Element;
1224 J.Node.Element := EI;
1231 procedure Swap_Links
1232 (Container : in out List;
1237 or else J = No_Element
1239 raise Constraint_Error;
1242 if I.Container /= List_Access'(Container
'Unchecked_Access) then
1243 raise Program_Error
;
1246 if J
.Container
/= I
.Container
then
1247 raise Program_Error
;
1250 pragma Assert
(Container
.Length
>= 1);
1252 if I
.Node
= J
.Node
then
1256 pragma Assert
(Container
.Length
>= 2);
1259 I_Next
: constant Cursor
:= Next
(I
);
1263 Splice
(Container
, Before
=> I
, Position
=> J
);
1267 J_Next
: constant Cursor
:= Next
(J
);
1270 Splice
(Container
, Before
=> J
, Position
=> I
);
1273 pragma Assert
(Container
.Length
>= 3);
1275 Splice
(Container
, Before
=> I_Next
, Position
=> J
);
1276 Splice
(Container
, Before
=> J_Next
, Position
=> I
);
1283 --------------------
1284 -- Update_Element --
1285 --------------------
1287 procedure Update_Element
1289 Process
: not null access procedure (Element
: in out Element_Type
))
1292 Process
(Position
.Node
.Element
.all);
1300 (Stream
: access Root_Stream_Type
'Class;
1303 Node
: Node_Access
:= Item
.First
;
1305 Count_Type
'Base'Write (Stream, Item.Length);
1306 while Node /= null loop
1307 Element_Type'Output (Stream, Node.Element.all); -- X.all
1312 end Ada.Containers.Indefinite_Doubly_Linked_Lists;