Mark ChangeLog
[official-gcc.git] / gcc / ada / a-cdlili.adb
blob435679d313deaa01386c3aca79bea4f7ab1315dc
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.DOUBLY_LINKED_LISTS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004 Free Software Foundation, Inc. --
10 -- --
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. --
14 -- --
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. --
25 -- --
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. --
32 -- --
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
41 procedure Free is
42 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
48 procedure Delete_Node
49 (Container : in out List;
50 Node : in out Node_Access);
52 procedure Insert_Internal
53 (Container : in out List;
54 Before : Node_Access;
55 New_Node : Node_Access);
57 ---------
58 -- "=" --
59 ---------
61 function "=" (Left, Right : List) return Boolean is
62 L : Node_Access := Left.First;
63 R : Node_Access := Right.First;
65 begin
66 if Left'Address = Right'Address then
67 return True;
68 end if;
70 if Left.Length /= Right.Length then
71 return False;
72 end if;
74 for J in 1 .. Left.Length loop
75 if L.Element /= R.Element then
76 return False;
77 end if;
79 L := L.Next;
80 R := R.Next;
81 end loop;
83 return True;
84 end "=";
86 ------------
87 -- Adjust --
88 ------------
90 procedure Adjust (Container : in out List) is
91 Src : Node_Access := Container.First;
92 Length : constant Count_Type := Container.Length;
94 begin
95 if Src = null then
96 pragma Assert (Container.Last = null);
97 pragma Assert (Length = 0);
98 return;
99 end if;
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;
112 loop
113 Container.Length := Container.Length + 1;
114 Src := Src.Next;
115 exit when Src = null;
116 Container.Last.Next := new Node_Type'(Element => Src.Element,
117 Prev => Container.Last,
118 Next => null);
119 Container.Last := Container.Last.Next;
120 end loop;
122 pragma Assert (Container.Length = Length);
123 end Adjust;
125 ------------
126 -- Append --
127 ------------
129 procedure Append
130 (Container : in out List;
131 New_Item : Element_Type;
132 Count : Count_Type := 1)
134 begin
135 Insert (Container, No_Element, New_Item, Count);
136 end Append;
138 -----------
139 -- Clear --
140 -----------
142 procedure Clear (Container : in out List) is
143 begin
144 Delete_Last (Container, Count => Container.Length);
145 end Clear;
147 --------------
148 -- Continue --
149 --------------
151 function Contains
152 (Container : List;
153 Item : Element_Type) return Boolean
155 begin
156 return Find (Container, Item) /= No_Element;
157 end Contains;
159 ------------
160 -- Delete --
161 ------------
163 procedure Delete
164 (Container : in out List;
165 Position : in out Cursor;
166 Count : Count_Type := 1)
168 begin
169 if Position = No_Element then
170 return;
171 end if;
173 if Position.Container /= List_Access'(Container'Unchecked_Access) then
174 raise Program_Error;
175 end if;
177 for Index in 1 .. Count loop
178 Delete_Node (Container, Position.Node);
180 if Position.Node = null then
181 Position.Container := null;
182 return;
183 end if;
184 end loop;
185 end Delete;
187 ------------------
188 -- Delete_First --
189 ------------------
191 procedure Delete_First
192 (Container : in out List;
193 Count : Count_Type := 1)
195 Node : Node_Access := Container.First;
196 begin
197 for J in 1 .. Count_Type'Min (Count, Container.Length) loop
198 Delete_Node (Container, Node);
199 end loop;
200 end Delete_First;
202 -----------------
203 -- Delete_Last --
204 -----------------
206 procedure Delete_Last
207 (Container : in out List;
208 Count : Count_Type := 1)
210 Node : Node_Access;
211 begin
212 for J in 1 .. Count_Type'Min (Count, Container.Length) loop
213 Node := Container.Last;
214 Delete_Node (Container, Node);
215 end loop;
216 end Delete_Last;
218 -----------------
219 -- Delete_Node --
220 -----------------
222 procedure Delete_Node
223 (Container : in out List;
224 Node : in out Node_Access)
226 X : Node_Access := Node;
228 begin
229 Node := X.Next;
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;
239 else
240 pragma Assert (Container.Length > 0);
241 Container.First.Prev := null;
242 end if;
244 elsif X = Container.Last then
245 pragma Assert (Container.Length > 0);
247 Container.Last := X.Prev;
248 Container.Last.Next := null;
250 else
251 pragma Assert (Container.Length > 0);
253 X.Next.Prev := X.Prev;
254 X.Prev.Next := X.Next;
255 end if;
257 Free (X);
258 end Delete_Node;
260 -------------
261 -- Element --
262 -------------
264 function Element (Position : Cursor) return Element_Type is
265 begin
266 return Position.Node.Element;
267 end Element;
269 ----------
270 -- Find --
271 ----------
273 function Find
274 (Container : List;
275 Item : Element_Type;
276 Position : Cursor := No_Element) return Cursor
278 Node : Node_Access := Position.Node;
280 begin
281 if Node = null then
282 Node := Container.First;
283 elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
284 raise Program_Error;
285 end if;
287 while Node /= null loop
288 if Node.Element = Item then
289 return Cursor'(Container'Unchecked_Access, Node);
290 end if;
292 Node := Node.Next;
293 end loop;
295 return No_Element;
296 end Find;
298 -----------
299 -- First --
300 -----------
302 function First (Container : List) return Cursor is
303 begin
304 if Container.First = null then
305 return No_Element;
306 end if;
308 return Cursor'(Container'Unchecked_Access, Container.First);
309 end First;
311 -------------------
312 -- First_Element --
313 -------------------
315 function First_Element (Container : List) return Element_Type is
316 begin
317 return Container.First.Element;
318 end First_Element;
320 -------------------
321 -- Generic_Merge --
322 -------------------
324 procedure Generic_Merge
325 (Target : in out List;
326 Source : in out List)
328 LI : Cursor := First (Target);
329 RI : Cursor := First (Source);
331 begin
332 if Target'Address = Source'Address then
333 return;
334 end if;
336 while RI.Node /= null loop
337 if LI.Node = null then
338 Splice (Target, No_Element, Source);
339 return;
340 end if;
342 if RI.Node.Element < LI.Node.Element then
343 declare
344 RJ : constant Cursor := RI;
345 begin
346 RI.Node := RI.Node.Next;
347 Splice (Target, LI, Source, RJ);
348 end;
350 else
351 LI.Node := LI.Node.Next;
352 end if;
353 end loop;
354 end Generic_Merge;
356 ------------------
357 -- Generic_Sort --
358 ------------------
360 procedure Generic_Sort (Container : in out List) is
362 procedure Partition
363 (Pivot : in Node_Access;
364 Back : in Node_Access);
366 procedure Sort (Front, Back : Node_Access);
368 ---------------
369 -- Partition --
370 ---------------
372 procedure Partition
373 (Pivot : Node_Access;
374 Back : Node_Access)
376 Node : Node_Access := Pivot.Next;
378 begin
379 while Node /= Back loop
380 if Node.Element < Pivot.Element then
381 declare
382 Prev : constant Node_Access := Node.Prev;
383 Next : constant Node_Access := Node.Next;
385 begin
386 Prev.Next := Next;
388 if Next = null then
389 Container.Last := Prev;
390 else
391 Next.Prev := Prev;
392 end if;
394 Node.Next := Pivot;
395 Node.Prev := Pivot.Prev;
397 Pivot.Prev := Node;
399 if Node.Prev = null then
400 Container.First := Node;
401 else
402 Node.Prev.Next := Node;
403 end if;
405 Node := Next;
406 end;
408 else
409 Node := Node.Next;
410 end if;
411 end loop;
412 end Partition;
414 ----------
415 -- Sort --
416 ----------
418 procedure Sort (Front, Back : Node_Access) is
419 Pivot : Node_Access;
421 begin
422 if Front = null then
423 Pivot := Container.First;
424 else
425 Pivot := Front.Next;
426 end if;
428 if Pivot /= Back then
429 Partition (Pivot, Back);
430 Sort (Front, Pivot);
431 Sort (Pivot, Back);
432 end if;
433 end Sort;
435 -- Start of processing for Generic_Sort
437 begin
438 Sort (Front => null, Back => null);
440 pragma Assert (Container.Length = 0
441 or else
442 (Container.First.Prev = null
443 and then Container.Last.Next = null));
444 end Generic_Sort;
446 -----------------
447 -- Has_Element --
448 -----------------
450 function Has_Element (Position : Cursor) return Boolean is
451 begin
452 return Position.Container /= null and then Position.Node /= null;
453 end Has_Element;
455 ------------
456 -- Insert --
457 ------------
459 procedure Insert
460 (Container : in out List;
461 Before : Cursor;
462 New_Item : Element_Type;
463 Position : out Cursor;
464 Count : Count_Type := 1)
466 New_Node : Node_Access;
468 begin
469 if Before.Container /= null
470 and then Before.Container /= List_Access'(Container'Unchecked_Access)
471 then
472 raise Program_Error;
473 end if;
475 if Count = 0 then
476 Position := Before;
477 return;
478 end if;
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);
488 end loop;
489 end Insert;
491 procedure Insert
492 (Container : in out List;
493 Before : Cursor;
494 New_Item : Element_Type;
495 Count : Count_Type := 1)
497 Position : Cursor;
498 begin
499 Insert (Container, Before, New_Item, Position, Count);
500 end Insert;
502 procedure Insert
503 (Container : in out List;
504 Before : Cursor;
505 Position : out Cursor;
506 Count : Count_Type := 1)
508 New_Node : Node_Access;
510 begin
511 if Before.Container /= null
512 and then Before.Container /= List_Access'(Container'Unchecked_Access)
513 then
514 raise Program_Error;
515 end if;
517 if Count = 0 then
518 Position := Before;
519 return;
520 end if;
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);
530 end loop;
531 end Insert;
533 ---------------------
534 -- Insert_Internal --
535 ---------------------
537 procedure Insert_Internal
538 (Container : in out List;
539 Before : Node_Access;
540 New_Node : Node_Access)
542 begin
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;
567 else
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;
576 end if;
578 Container.Length := Container.Length + 1;
579 end Insert_Internal;
581 --------------
582 -- Is_Empty --
583 --------------
585 function Is_Empty (Container : List) return Boolean is
586 begin
587 return Container.Length = 0;
588 end Is_Empty;
590 -------------
591 -- Iterate --
592 -------------
594 procedure Iterate
595 (Container : List;
596 Process : not null access procedure (Position : Cursor))
598 Node : Node_Access := Container.First;
599 begin
600 while Node /= null loop
601 Process (Cursor'(Container'Unchecked_Access, Node));
602 Node := Node.Next;
603 end loop;
604 end Iterate;
606 ----------
607 -- Last --
608 ----------
610 function Last (Container : List) return Cursor is
611 begin
612 if Container.Last = null then
613 return No_Element;
614 end if;
616 return Cursor'(Container'Unchecked_Access, Container.Last);
617 end Last;
619 ------------------
620 -- Last_Element --
621 ------------------
623 function Last_Element (Container : List) return Element_Type is
624 begin
625 return Container.Last.Element;
626 end Last_Element;
628 ------------
629 -- Length --
630 ------------
632 function Length (Container : List) return Count_Type is
633 begin
634 return Container.Length;
635 end Length;
637 ----------
638 -- Move --
639 ----------
641 procedure Move
642 (Target : in out List;
643 Source : in out List)
645 begin
646 if Target'Address = Source'Address then
647 return;
648 end if;
650 if Target.Length > 0 then
651 raise Constraint_Error;
652 end if;
654 Target.First := Source.First;
655 Source.First := null;
657 Target.Last := Source.Last;
658 Source.Last := null;
660 Target.Length := Source.Length;
661 Source.Length := 0;
662 end Move;
664 ----------
665 -- Next --
666 ----------
668 procedure Next (Position : in out Cursor) is
669 begin
670 if Position.Node = null then
671 return;
672 end if;
674 Position.Node := Position.Node.Next;
676 if Position.Node = null then
677 Position.Container := null;
678 end if;
679 end Next;
681 function Next (Position : Cursor) return Cursor is
682 begin
683 if Position.Node = null then
684 return No_Element;
685 end if;
687 declare
688 Next_Node : constant Node_Access := Position.Node.Next;
689 begin
690 if Next_Node = null then
691 return No_Element;
692 end if;
694 return Cursor'(Position.Container, Next_Node);
695 end;
696 end Next;
698 -------------
699 -- Prepend --
700 -------------
702 procedure Prepend
703 (Container : in out List;
704 New_Item : Element_Type;
705 Count : Count_Type := 1)
707 begin
708 Insert (Container, First (Container), New_Item, Count);
709 end Prepend;
711 --------------
712 -- Previous --
713 --------------
715 procedure Previous (Position : in out Cursor) is
716 begin
717 if Position.Node = null then
718 return;
719 end if;
721 Position.Node := Position.Node.Prev;
723 if Position.Node = null then
724 Position.Container := null;
725 end if;
726 end Previous;
728 function Previous (Position : Cursor) return Cursor is
729 begin
730 if Position.Node = null then
731 return No_Element;
732 end if;
734 declare
735 Prev_Node : constant Node_Access := Position.Node.Prev;
736 begin
737 if Prev_Node = null then
738 return No_Element;
739 end if;
741 return Cursor'(Position.Container, Prev_Node);
742 end;
743 end Previous;
745 -------------------
746 -- Query_Element --
747 -------------------
749 procedure Query_Element
750 (Position : Cursor;
751 Process : not null access procedure (Element : in Element_Type))
753 begin
754 Process (Position.Node.Element);
755 end Query_Element;
757 ----------
758 -- Read --
759 ----------
761 procedure Read
762 (Stream : access Root_Stream_Type'Class;
763 Item : out List)
765 N : Count_Type'Base;
766 X : Node_Access;
768 begin
769 Clear (Item); -- ???
770 Count_Type'Base'Read (Stream, N);
772 if N = 0 then
773 return;
774 end if;
776 X := new Node_Type;
778 begin
779 Element_Type'Read (Stream, X.Element);
780 exception
781 when others =>
782 Free (X);
783 raise;
784 end;
786 Item.First := X;
787 Item.Last := X;
789 loop
790 Item.Length := Item.Length + 1;
791 exit when Item.Length = N;
793 X := new Node_Type;
795 begin
796 Element_Type'Read (Stream, X.Element);
797 exception
798 when others =>
799 Free (X);
800 raise;
801 end;
803 X.Prev := Item.Last;
804 Item.Last.Next := X;
805 Item.Last := X;
806 end loop;
807 end Read;
809 ---------------------
810 -- Replace_Element --
811 ---------------------
813 procedure Replace_Element
814 (Position : Cursor;
815 By : Element_Type)
817 begin
818 Position.Node.Element := By;
819 end Replace_Element;
821 ------------------
822 -- Reverse_Find --
823 ------------------
825 function Reverse_Find
826 (Container : List;
827 Item : Element_Type;
828 Position : Cursor := No_Element) return Cursor
830 Node : Node_Access := Position.Node;
832 begin
833 if Node = null then
834 Node := Container.Last;
835 elsif Position.Container /= List_Access'(Container'Unchecked_Access) then
836 raise Program_Error;
837 end if;
839 while Node /= null loop
840 if Node.Element = Item then
841 return Cursor'(Container'Unchecked_Access, Node);
842 end if;
844 Node := Node.Prev;
845 end loop;
847 return No_Element;
848 end Reverse_Find;
850 ---------------------
851 -- Reverse_Iterate --
852 ---------------------
854 procedure Reverse_Iterate
855 (Container : List;
856 Process : not null access procedure (Position : Cursor))
858 Node : Node_Access := Container.Last;
859 begin
860 while Node /= null loop
861 Process (Cursor'(Container'Unchecked_Access, Node));
862 Node := Node.Prev;
863 end loop;
864 end Reverse_Iterate;
866 ------------------
867 -- Reverse_List --
868 ------------------
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);
876 ----------
877 -- Swap --
878 ----------
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;
887 begin
888 if LP /= null then
889 LP.Next := R;
890 end if;
892 if RN /= null then
893 RN.Prev := L;
894 end if;
896 L.Next := RN;
897 R.Prev := LP;
899 if LN = R then
900 pragma Assert (RP = L);
902 L.Prev := R;
903 R.Next := L;
905 else
906 L.Prev := RP;
907 RP.Next := L;
909 R.Next := LN;
910 LN.Prev := R;
911 end if;
912 end Swap;
914 -- Start of processing for Reverse_List
916 begin
917 if Container.Length <= 1 then
918 return;
919 end if;
921 Container.First := J;
922 Container.Last := I;
923 loop
924 Swap (L => I, R => J);
926 J := J.Next;
927 exit when I = J;
929 I := I.Prev;
930 exit when I = J;
932 Swap (L => J, R => I);
934 I := I.Next;
935 exit when I = J;
937 J := J.Prev;
938 exit when I = J;
939 end loop;
941 pragma Assert (Container.First.Prev = null);
942 pragma Assert (Container.Last.Next = null);
943 end Reverse_List;
945 ------------
946 -- Splice --
947 ------------
949 procedure Splice
950 (Target : in out List;
951 Before : Cursor;
952 Source : in out List)
954 begin
955 if Before.Container /= null
956 and then Before.Container /= List_Access'(Target'Unchecked_Access)
957 then
958 raise Program_Error;
959 end if;
961 if Target'Address = Source'Address
962 or else Source.Length = 0
963 then
964 return;
965 end if;
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;
989 else
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;
995 end if;
997 Source.First := null;
998 Source.Last := null;
1000 Target.Length := Target.Length + Source.Length;
1001 Source.Length := 0;
1002 end Splice;
1004 procedure Splice
1005 (Target : in out List;
1006 Before : Cursor;
1007 Position : Cursor)
1009 X : Node_Access := Position.Node;
1011 begin
1012 if Before.Container /= null
1013 and then Before.Container /= List_Access'(Target'Unchecked_Access)
1014 then
1015 raise Program_Error;
1016 end if;
1018 if Position.Container /= null
1019 and then Position.Container /= List_Access'(Target'Unchecked_Access)
1020 then
1021 raise Program_Error;
1022 end if;
1024 if X = null
1025 or else X = Before.Node
1026 or else X.Next = Before.Node
1027 then
1028 return;
1029 end if;
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;
1039 else
1040 X.Prev.Next := X.Next;
1041 X.Next.Prev := X.Prev;
1042 end if;
1044 Target.Last.Next := X;
1045 X.Prev := Target.Last;
1047 Target.Last := X;
1048 Target.Last.Next := null;
1050 return;
1051 end if;
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;
1059 else
1060 X.Prev.Next := X.Next;
1061 X.Next.Prev := X.Prev;
1062 end if;
1064 Target.First.Prev := X;
1065 X.Next := Target.First;
1067 Target.First := X;
1068 Target.First.Prev := null;
1070 return;
1071 end if;
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;
1081 else
1082 X.Prev.Next := X.Next;
1083 X.Next.Prev := X.Prev;
1084 end if;
1086 Before.Node.Prev.Next := X;
1087 X.Prev := Before.Node.Prev;
1089 Before.Node.Prev := X;
1090 X.Next := Before.Node;
1091 end Splice;
1093 procedure Splice
1094 (Target : in out List;
1095 Before : Cursor;
1096 Source : in out List;
1097 Position : Cursor)
1099 X : Node_Access := Position.Node;
1101 begin
1102 if Target'Address = Source'Address then
1103 Splice (Target, Before, Position);
1104 return;
1105 end if;
1107 if Before.Container /= null
1108 and then Before.Container /= List_Access'(Target'Unchecked_Access)
1109 then
1110 raise Program_Error;
1111 end if;
1113 if Position.Container /= null
1114 and then Position.Container /= List_Access'(Source'Unchecked_Access)
1115 then
1116 raise Program_Error;
1117 end if;
1119 if X = null then
1120 return;
1121 end if;
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;
1135 end if;
1137 elsif X = Source.Last then
1138 Source.Last := X.Prev;
1139 Source.Last.Next := null;
1141 else
1142 X.Prev.Next := X.Next;
1143 X.Next.Prev := X.Prev;
1144 end if;
1146 if Target.Length = 0 then
1147 pragma Assert (Before = No_Element);
1148 pragma Assert (Target.First = null);
1149 pragma Assert (Target.Last = null);
1151 Target.First := X;
1152 Target.Last := X;
1154 elsif Before.Node = null then
1155 Target.Last.Next := X;
1156 X.Next := Target.Last;
1158 Target.Last := X;
1159 Target.Last.Next := null;
1161 elsif Before.Node = Target.First then
1162 Target.First.Prev := X;
1163 X.Next := Target.First;
1165 Target.First := X;
1166 Target.First.Prev := null;
1168 else
1169 Before.Node.Prev.Next := X;
1170 X.Prev := Before.Node.Prev;
1172 Before.Node.Prev := X;
1173 X.Next := Before.Node;
1174 end if;
1176 Target.Length := Target.Length + 1;
1177 Source.Length := Source.Length - 1;
1178 end Splice;
1180 ----------
1181 -- Swap --
1182 ----------
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;
1189 begin
1190 I.Node.Element := J.Node.Element;
1191 J.Node.Element := EI;
1192 end Swap;
1194 ----------------
1195 -- Swap_Links --
1196 ----------------
1198 procedure Swap_Links
1199 (Container : in out List;
1200 I, J : Cursor)
1202 begin
1203 if I = No_Element
1204 or else J = No_Element
1205 then
1206 raise Constraint_Error;
1207 end if;
1209 if I.Container /= List_Access'(Container'Unchecked_Access) then
1210 raise Program_Error;
1211 end if;
1213 if J.Container /= I.Container then
1214 raise Program_Error;
1215 end if;
1217 pragma Assert (Container.Length >= 1);
1219 if I.Node = J.Node then
1220 return;
1221 end if;
1223 pragma Assert (Container.Length >= 2);
1225 declare
1226 I_Next : constant Cursor := Next (I);
1228 begin
1229 if I_Next = J then
1230 Splice (Container, Before => I, Position => J);
1232 else
1233 declare
1234 J_Next : constant Cursor := Next (J);
1236 begin
1237 if J_Next = I then
1238 Splice (Container, Before => J, Position => I);
1240 else
1241 pragma Assert (Container.Length >= 3);
1243 Splice (Container, Before => I_Next, Position => J);
1244 Splice (Container, Before => J_Next, Position => I);
1245 end if;
1246 end;
1247 end if;
1248 end;
1249 end Swap_Links;
1251 --------------------
1252 -- Update_Element --
1253 --------------------
1255 procedure Update_Element
1256 (Position : Cursor;
1257 Process : not null access procedure (Element : in out Element_Type)) is
1258 begin
1259 Process (Position.Node.Element);
1260 end Update_Element;
1262 -----------
1263 -- Write --
1264 -----------
1266 procedure Write
1267 (Stream : access Root_Stream_Type'Class;
1268 Item : List)
1270 Node : Node_Access := Item.First;
1272 begin
1273 Count_Type'Base'Write (Stream, Item.Length);
1275 while Node /= null loop
1276 Element_Type'Write (Stream, Node.Element);
1277 Node := Node.Next;
1278 end loop;
1279 end Write;
1281 end Ada.Containers.Doubly_Linked_Lists;