File : a-cfdlli.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 ------------------------------------------------------------------------------
27
28 with System; use type System.Address;
29
30 package body Ada.Containers.Formal_Doubly_Linked_Lists with
31 SPARK_Mode => Off
32 is
33
34 -----------------------
35 -- Local Subprograms --
36 -----------------------
37
38 procedure Allocate
39 (Container : in out List;
40 New_Item : Element_Type;
41 New_Node : out Count_Type);
42
43 procedure Allocate
44 (Container : in out List;
45 New_Node : out Count_Type);
46
47 procedure Free
48 (Container : in out List;
49 X : Count_Type);
50
51 procedure Insert_Internal
52 (Container : in out List;
53 Before : Count_Type;
54 New_Node : Count_Type);
55
56 function Vet (L : List; Position : Cursor) return Boolean;
57
58 ---------
59 -- "=" --
60 ---------
61
62 function "=" (Left, Right : List) return Boolean is
63 LI, RI : Count_Type;
64
65 begin
66 if Left'Address = Right'Address then
67 return True;
68 end if;
69
70 if Left.Length /= Right.Length then
71 return False;
72 end if;
73
74 LI := Left.First;
75 RI := Left.First;
76 while LI /= 0 loop
77 if Left.Nodes (LI).Element /= Right.Nodes (LI).Element then
78 return False;
79 end if;
80
81 LI := Left.Nodes (LI).Next;
82 RI := Right.Nodes (RI).Next;
83 end loop;
84
85 return True;
86 end "=";
87
88 --------------
89 -- Allocate --
90 --------------
91
92 procedure Allocate
93 (Container : in out List;
94 New_Item : Element_Type;
95 New_Node : out Count_Type)
96 is
97 N : Node_Array renames Container.Nodes;
98
99 begin
100 if Container.Free >= 0 then
101 New_Node := Container.Free;
102 N (New_Node).Element := New_Item;
103 Container.Free := N (New_Node).Next;
104
105 else
106 New_Node := abs Container.Free;
107 N (New_Node).Element := New_Item;
108 Container.Free := Container.Free - 1;
109 end if;
110 end Allocate;
111
112 procedure Allocate
113 (Container : in out List;
114 New_Node : out Count_Type)
115 is
116 N : Node_Array renames Container.Nodes;
117
118 begin
119 if Container.Free >= 0 then
120 New_Node := Container.Free;
121 Container.Free := N (New_Node).Next;
122
123 else
124 New_Node := abs Container.Free;
125 Container.Free := Container.Free - 1;
126 end if;
127 end Allocate;
128
129 ------------
130 -- Append --
131 ------------
132
133 procedure Append
134 (Container : in out List;
135 New_Item : Element_Type;
136 Count : Count_Type := 1)
137 is
138 begin
139 Insert (Container, No_Element, New_Item, Count);
140 end Append;
141
142 ------------
143 -- Assign --
144 ------------
145
146 procedure Assign (Target : in out List; Source : List) is
147 N : Node_Array renames Source.Nodes;
148 J : Count_Type;
149
150 begin
151 if Target'Address = Source'Address then
152 return;
153 end if;
154
155 if Target.Capacity < Source.Length then
156 raise Constraint_Error with -- ???
157 "Source length exceeds Target capacity";
158 end if;
159
160 Clear (Target);
161
162 J := Source.First;
163 while J /= 0 loop
164 Append (Target, N (J).Element);
165 J := N (J).Next;
166 end loop;
167 end Assign;
168
169 -----------
170 -- Clear --
171 -----------
172
173 procedure Clear (Container : in out List) is
174 N : Node_Array renames Container.Nodes;
175 X : Count_Type;
176
177 begin
178 if Container.Length = 0 then
179 pragma Assert (Container.First = 0);
180 pragma Assert (Container.Last = 0);
181 return;
182 end if;
183
184 pragma Assert (Container.First >= 1);
185 pragma Assert (Container.Last >= 1);
186 pragma Assert (N (Container.First).Prev = 0);
187 pragma Assert (N (Container.Last).Next = 0);
188
189 while Container.Length > 1 loop
190 X := Container.First;
191
192 Container.First := N (X).Next;
193 N (Container.First).Prev := 0;
194
195 Container.Length := Container.Length - 1;
196
197 Free (Container, X);
198 end loop;
199
200 X := Container.First;
201
202 Container.First := 0;
203 Container.Last := 0;
204 Container.Length := 0;
205
206 Free (Container, X);
207 end Clear;
208
209 --------------
210 -- Contains --
211 --------------
212
213 function Contains
214 (Container : List;
215 Item : Element_Type) return Boolean
216 is
217 begin
218 return Find (Container, Item) /= No_Element;
219 end Contains;
220
221 ----------
222 -- Copy --
223 ----------
224
225 function Copy
226 (Source : List;
227 Capacity : Count_Type := 0) return List
228 is
229 C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity);
230 N : Count_Type;
231 P : List (C);
232
233 begin
234 if 0 < Capacity and then Capacity < Source.Capacity then
235 raise Capacity_Error;
236 end if;
237
238 N := 1;
239 while N <= Source.Capacity loop
240 P.Nodes (N).Prev := Source.Nodes (N).Prev;
241 P.Nodes (N).Next := Source.Nodes (N).Next;
242 P.Nodes (N).Element := Source.Nodes (N).Element;
243 N := N + 1;
244 end loop;
245
246 P.Free := Source.Free;
247 P.Length := Source.Length;
248 P.First := Source.First;
249 P.Last := Source.Last;
250
251 if P.Free >= 0 then
252 N := Source.Capacity + 1;
253 while N <= C loop
254 Free (P, N);
255 N := N + 1;
256 end loop;
257 end if;
258
259 return P;
260 end Copy;
261
262 ---------------------
263 -- Current_To_Last --
264 ---------------------
265
266 function Current_To_Last
267 (Container : List;
268 Current : Cursor) return List is
269 Curs : Cursor := First (Container);
270 C : List (Container.Capacity) := Copy (Container, Container.Capacity);
271 Node : Count_Type;
272
273 begin
274 if Curs = No_Element then
275 Clear (C);
276 return C;
277 end if;
278
279 if Current /= No_Element and not Has_Element (Container, Current) then
280 raise Constraint_Error;
281 end if;
282
283 while Curs.Node /= Current.Node loop
284 Node := Curs.Node;
285 Delete (C, Curs);
286 Curs := Next (Container, (Node => Node));
287 end loop;
288
289 return C;
290 end Current_To_Last;
291
292 ------------
293 -- Delete --
294 ------------
295
296 procedure Delete
297 (Container : in out List;
298 Position : in out Cursor;
299 Count : Count_Type := 1)
300 is
301 N : Node_Array renames Container.Nodes;
302 X : Count_Type;
303
304 begin
305 if not Has_Element (Container => Container,
306 Position => Position)
307 then
308 raise Constraint_Error with
309 "Position cursor has no element";
310 end if;
311
312 pragma Assert (Vet (Container, Position), "bad cursor in Delete");
313 pragma Assert (Container.First >= 1);
314 pragma Assert (Container.Last >= 1);
315 pragma Assert (N (Container.First).Prev = 0);
316 pragma Assert (N (Container.Last).Next = 0);
317
318 if Position.Node = Container.First then
319 Delete_First (Container, Count);
320 Position := No_Element;
321 return;
322 end if;
323
324 if Count = 0 then
325 Position := No_Element;
326 return;
327 end if;
328
329 for Index in 1 .. Count loop
330 pragma Assert (Container.Length >= 2);
331
332 X := Position.Node;
333 Container.Length := Container.Length - 1;
334
335 if X = Container.Last then
336 Position := No_Element;
337
338 Container.Last := N (X).Prev;
339 N (Container.Last).Next := 0;
340
341 Free (Container, X);
342 return;
343 end if;
344
345 Position.Node := N (X).Next;
346 pragma Assert (N (Position.Node).Prev >= 0);
347
348 N (N (X).Next).Prev := N (X).Prev;
349 N (N (X).Prev).Next := N (X).Next;
350
351 Free (Container, X);
352 end loop;
353 Position := No_Element;
354 end Delete;
355
356 ------------------
357 -- Delete_First --
358 ------------------
359
360 procedure Delete_First
361 (Container : in out List;
362 Count : Count_Type := 1)
363 is
364 N : Node_Array renames Container.Nodes;
365 X : Count_Type;
366
367 begin
368 if Count >= Container.Length then
369 Clear (Container);
370 return;
371 end if;
372
373 if Count = 0 then
374 return;
375 end if;
376
377 for J in 1 .. Count loop
378 X := Container.First;
379 pragma Assert (N (N (X).Next).Prev = Container.First);
380
381 Container.First := N (X).Next;
382 N (Container.First).Prev := 0;
383
384 Container.Length := Container.Length - 1;
385
386 Free (Container, X);
387 end loop;
388 end Delete_First;
389
390 -----------------
391 -- Delete_Last --
392 -----------------
393
394 procedure Delete_Last
395 (Container : in out List;
396 Count : Count_Type := 1)
397 is
398 N : Node_Array renames Container.Nodes;
399 X : Count_Type;
400
401 begin
402 if Count >= Container.Length then
403 Clear (Container);
404 return;
405 end if;
406
407 if Count = 0 then
408 return;
409 end if;
410
411 for J in 1 .. Count loop
412 X := Container.Last;
413 pragma Assert (N (N (X).Prev).Next = Container.Last);
414
415 Container.Last := N (X).Prev;
416 N (Container.Last).Next := 0;
417
418 Container.Length := Container.Length - 1;
419
420 Free (Container, X);
421 end loop;
422 end Delete_Last;
423
424 -------------
425 -- Element --
426 -------------
427
428 function Element
429 (Container : List;
430 Position : Cursor) return Element_Type
431 is
432 begin
433 if not Has_Element (Container => Container, Position => Position) then
434 raise Constraint_Error with
435 "Position cursor has no element";
436 end if;
437
438 return Container.Nodes (Position.Node).Element;
439 end Element;
440
441 ----------
442 -- Find --
443 ----------
444
445 function Find
446 (Container : List;
447 Item : Element_Type;
448 Position : Cursor := No_Element) return Cursor
449 is
450 From : Count_Type := Position.Node;
451
452 begin
453 if From = 0 and Container.Length = 0 then
454 return No_Element;
455 end if;
456
457 if From = 0 then
458 From := Container.First;
459 end if;
460
461 if Position.Node /= 0 and then
462 not Has_Element (Container, Position)
463 then
464 raise Constraint_Error with
465 "Position cursor has no element";
466 end if;
467
468 while From /= 0 loop
469 if Container.Nodes (From).Element = Item then
470 return (Node => From);
471 end if;
472
473 From := Container.Nodes (From).Next;
474 end loop;
475
476 return No_Element;
477 end Find;
478
479 -----------
480 -- First --
481 -----------
482
483 function First (Container : List) return Cursor is
484 begin
485 if Container.First = 0 then
486 return No_Element;
487 end if;
488
489 return (Node => Container.First);
490 end First;
491
492 -------------------
493 -- First_Element --
494 -------------------
495
496 function First_Element (Container : List) return Element_Type is
497 F : constant Count_Type := Container.First;
498 begin
499 if F = 0 then
500 raise Constraint_Error with "list is empty";
501 else
502 return Container.Nodes (F).Element;
503 end if;
504 end First_Element;
505
506 -----------------------
507 -- First_To_Previous --
508 -----------------------
509
510 function First_To_Previous
511 (Container : List;
512 Current : Cursor) return List
513 is
514 Curs : Cursor := Current;
515 C : List (Container.Capacity) := Copy (Container, Container.Capacity);
516 Node : Count_Type;
517
518 begin
519 if Curs = No_Element then
520 return C;
521
522 elsif not Has_Element (Container, Curs) then
523 raise Constraint_Error;
524
525 else
526 while Curs.Node /= 0 loop
527 Node := Curs.Node;
528 Delete (C, Curs);
529 Curs := Next (Container, (Node => Node));
530 end loop;
531
532 return C;
533 end if;
534 end First_To_Previous;
535
536 ----------
537 -- Free --
538 ----------
539
540 procedure Free
541 (Container : in out List;
542 X : Count_Type)
543 is
544 pragma Assert (X > 0);
545 pragma Assert (X <= Container.Capacity);
546
547 N : Node_Array renames Container.Nodes;
548
549 begin
550 N (X).Prev := -1; -- Node is deallocated (not on active list)
551
552 if Container.Free >= 0 then
553 N (X).Next := Container.Free;
554 Container.Free := X;
555
556 elsif X + 1 = abs Container.Free then
557 N (X).Next := 0; -- Not strictly necessary, but marginally safer
558 Container.Free := Container.Free + 1;
559
560 else
561 Container.Free := abs Container.Free;
562
563 if Container.Free > Container.Capacity then
564 Container.Free := 0;
565
566 else
567 for J in Container.Free .. Container.Capacity - 1 loop
568 N (J).Next := J + 1;
569 end loop;
570
571 N (Container.Capacity).Next := 0;
572 end if;
573
574 N (X).Next := Container.Free;
575 Container.Free := X;
576 end if;
577 end Free;
578
579 ---------------------
580 -- Generic_Sorting --
581 ---------------------
582
583 package body Generic_Sorting with SPARK_Mode => Off is
584
585 ---------------
586 -- Is_Sorted --
587 ---------------
588
589 function Is_Sorted (Container : List) return Boolean is
590 Nodes : Node_Array renames Container.Nodes;
591 Node : Count_Type := Container.First;
592
593 begin
594 for J in 2 .. Container.Length loop
595 if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
596 return False;
597 else
598 Node := Nodes (Node).Next;
599 end if;
600 end loop;
601
602 return True;
603 end Is_Sorted;
604
605 -----------
606 -- Merge --
607 -----------
608
609 procedure Merge
610 (Target : in out List;
611 Source : in out List)
612 is
613 LN : Node_Array renames Target.Nodes;
614 RN : Node_Array renames Source.Nodes;
615 LI : Cursor;
616 RI : Cursor;
617
618 begin
619 if Target'Address = Source'Address then
620 return;
621 end if;
622
623 LI := First (Target);
624 RI := First (Source);
625 while RI.Node /= 0 loop
626 pragma Assert (RN (RI.Node).Next = 0
627 or else not (RN (RN (RI.Node).Next).Element <
628 RN (RI.Node).Element));
629
630 if LI.Node = 0 then
631 Splice (Target, No_Element, Source);
632 return;
633 end if;
634
635 pragma Assert (LN (LI.Node).Next = 0
636 or else not (LN (LN (LI.Node).Next).Element <
637 LN (LI.Node).Element));
638
639 if RN (RI.Node).Element < LN (LI.Node).Element then
640 declare
641 RJ : Cursor := RI;
642 pragma Warnings (Off, RJ);
643 begin
644 RI.Node := RN (RI.Node).Next;
645 Splice (Target, LI, Source, RJ);
646 end;
647
648 else
649 LI.Node := LN (LI.Node).Next;
650 end if;
651 end loop;
652 end Merge;
653
654 ----------
655 -- Sort --
656 ----------
657
658 procedure Sort (Container : in out List) is
659 N : Node_Array renames Container.Nodes;
660
661 procedure Partition (Pivot, Back : Count_Type);
662 procedure Sort (Front, Back : Count_Type);
663
664 ---------------
665 -- Partition --
666 ---------------
667
668 procedure Partition (Pivot, Back : Count_Type) is
669 Node : Count_Type;
670
671 begin
672 Node := N (Pivot).Next;
673 while Node /= Back loop
674 if N (Node).Element < N (Pivot).Element then
675 declare
676 Prev : constant Count_Type := N (Node).Prev;
677 Next : constant Count_Type := N (Node).Next;
678
679 begin
680 N (Prev).Next := Next;
681
682 if Next = 0 then
683 Container.Last := Prev;
684 else
685 N (Next).Prev := Prev;
686 end if;
687
688 N (Node).Next := Pivot;
689 N (Node).Prev := N (Pivot).Prev;
690
691 N (Pivot).Prev := Node;
692
693 if N (Node).Prev = 0 then
694 Container.First := Node;
695 else
696 N (N (Node).Prev).Next := Node;
697 end if;
698
699 Node := Next;
700 end;
701
702 else
703 Node := N (Node).Next;
704 end if;
705 end loop;
706 end Partition;
707
708 ----------
709 -- Sort --
710 ----------
711
712 procedure Sort (Front, Back : Count_Type) is
713 Pivot : Count_Type;
714
715 begin
716 if Front = 0 then
717 Pivot := Container.First;
718 else
719 Pivot := N (Front).Next;
720 end if;
721
722 if Pivot /= Back then
723 Partition (Pivot, Back);
724 Sort (Front, Pivot);
725 Sort (Pivot, Back);
726 end if;
727 end Sort;
728
729 -- Start of processing for Sort
730
731 begin
732 if Container.Length <= 1 then
733 return;
734 end if;
735
736 pragma Assert (N (Container.First).Prev = 0);
737 pragma Assert (N (Container.Last).Next = 0);
738
739 Sort (Front => 0, Back => 0);
740
741 pragma Assert (N (Container.First).Prev = 0);
742 pragma Assert (N (Container.Last).Next = 0);
743 end Sort;
744
745 end Generic_Sorting;
746
747 -----------------
748 -- Has_Element --
749 -----------------
750
751 function Has_Element (Container : List; Position : Cursor) return Boolean is
752 begin
753 if Position.Node = 0 then
754 return False;
755 end if;
756
757 return Container.Nodes (Position.Node).Prev /= -1;
758 end Has_Element;
759
760 ------------
761 -- Insert --
762 ------------
763
764 procedure Insert
765 (Container : in out List;
766 Before : Cursor;
767 New_Item : Element_Type;
768 Position : out Cursor;
769 Count : Count_Type := 1)
770 is
771 J : Count_Type;
772
773 begin
774 if Before.Node /= 0 then
775 pragma Assert (Vet (Container, Before), "bad cursor in Insert");
776 end if;
777
778 if Count = 0 then
779 Position := Before;
780 return;
781 end if;
782
783 if Container.Length > Container.Capacity - Count then
784 raise Constraint_Error with "new length exceeds capacity";
785 end if;
786
787 Allocate (Container, New_Item, New_Node => J);
788 Insert_Internal (Container, Before.Node, New_Node => J);
789 Position := (Node => J);
790
791 for Index in 2 .. Count loop
792 Allocate (Container, New_Item, New_Node => J);
793 Insert_Internal (Container, Before.Node, New_Node => J);
794 end loop;
795 end Insert;
796
797 procedure Insert
798 (Container : in out List;
799 Before : Cursor;
800 New_Item : Element_Type;
801 Count : Count_Type := 1)
802 is
803 Position : Cursor;
804 begin
805 Insert (Container, Before, New_Item, Position, Count);
806 end Insert;
807
808 procedure Insert
809 (Container : in out List;
810 Before : Cursor;
811 Position : out Cursor;
812 Count : Count_Type := 1)
813 is
814 J : Count_Type;
815
816 begin
817 if Before.Node /= 0 then
818 pragma Assert (Vet (Container, Before), "bad cursor in Insert");
819 end if;
820
821 if Count = 0 then
822 Position := Before;
823 return;
824 end if;
825
826 if Container.Length > Container.Capacity - Count then
827 raise Constraint_Error with "new length exceeds capacity";
828 end if;
829
830 Allocate (Container, New_Node => J);
831 Insert_Internal (Container, Before.Node, New_Node => J);
832 Position := (Node => J);
833
834 for Index in 2 .. Count loop
835 Allocate (Container, New_Node => J);
836 Insert_Internal (Container, Before.Node, New_Node => J);
837 end loop;
838 end Insert;
839
840 ---------------------
841 -- Insert_Internal --
842 ---------------------
843
844 procedure Insert_Internal
845 (Container : in out List;
846 Before : Count_Type;
847 New_Node : Count_Type)
848 is
849 N : Node_Array renames Container.Nodes;
850
851 begin
852 if Container.Length = 0 then
853 pragma Assert (Before = 0);
854 pragma Assert (Container.First = 0);
855 pragma Assert (Container.Last = 0);
856
857 Container.First := New_Node;
858 Container.Last := New_Node;
859
860 N (Container.First).Prev := 0;
861 N (Container.Last).Next := 0;
862
863 elsif Before = 0 then
864 pragma Assert (N (Container.Last).Next = 0);
865
866 N (Container.Last).Next := New_Node;
867 N (New_Node).Prev := Container.Last;
868
869 Container.Last := New_Node;
870 N (Container.Last).Next := 0;
871
872 elsif Before = Container.First then
873 pragma Assert (N (Container.First).Prev = 0);
874
875 N (Container.First).Prev := New_Node;
876 N (New_Node).Next := Container.First;
877
878 Container.First := New_Node;
879 N (Container.First).Prev := 0;
880
881 else
882 pragma Assert (N (Container.First).Prev = 0);
883 pragma Assert (N (Container.Last).Next = 0);
884
885 N (New_Node).Next := Before;
886 N (New_Node).Prev := N (Before).Prev;
887
888 N (N (Before).Prev).Next := New_Node;
889 N (Before).Prev := New_Node;
890 end if;
891
892 Container.Length := Container.Length + 1;
893 end Insert_Internal;
894
895 --------------
896 -- Is_Empty --
897 --------------
898
899 function Is_Empty (Container : List) return Boolean is
900 begin
901 return Length (Container) = 0;
902 end Is_Empty;
903
904 ----------
905 -- Last --
906 ----------
907
908 function Last (Container : List) return Cursor is
909 begin
910 if Container.Last = 0 then
911 return No_Element;
912 end if;
913
914 return (Node => Container.Last);
915 end Last;
916
917 ------------------
918 -- Last_Element --
919 ------------------
920
921 function Last_Element (Container : List) return Element_Type is
922 L : constant Count_Type := Container.Last;
923 begin
924 if L = 0 then
925 raise Constraint_Error with "list is empty";
926 else
927 return Container.Nodes (L).Element;
928 end if;
929 end Last_Element;
930
931 ------------
932 -- Length --
933 ------------
934
935 function Length (Container : List) return Count_Type is
936 begin
937 return Container.Length;
938 end Length;
939
940 ----------
941 -- Move --
942 ----------
943
944 procedure Move
945 (Target : in out List;
946 Source : in out List)
947 is
948 N : Node_Array renames Source.Nodes;
949 X : Count_Type;
950
951 begin
952 if Target'Address = Source'Address then
953 return;
954 end if;
955
956 if Target.Capacity < Source.Length then
957 raise Constraint_Error with -- ???
958 "Source length exceeds Target capacity";
959 end if;
960
961 Clear (Target);
962
963 while Source.Length > 1 loop
964 pragma Assert (Source.First in 1 .. Source.Capacity);
965 pragma Assert (Source.Last /= Source.First);
966 pragma Assert (N (Source.First).Prev = 0);
967 pragma Assert (N (Source.Last).Next = 0);
968
969 -- Copy first element from Source to Target
970
971 X := Source.First;
972 Append (Target, N (X).Element); -- optimize away???
973
974 -- Unlink first node of Source
975
976 Source.First := N (X).Next;
977 N (Source.First).Prev := 0;
978
979 Source.Length := Source.Length - 1;
980
981 -- The representation invariants for Source have been restored. It is
982 -- now safe to free the unlinked node, without fear of corrupting the
983 -- active links of Source.
984
985 -- Note that the algorithm we use here models similar algorithms used
986 -- in the unbounded form of the doubly-linked list container. In that
987 -- case, Free is an instantation of Unchecked_Deallocation, which can
988 -- fail (because PE will be raised if controlled Finalize fails), so
989 -- we must defer the call until the last step. Here in the bounded
990 -- form, Free merely links the node we have just "deallocated" onto a
991 -- list of inactive nodes, so technically Free cannot fail. However,
992 -- for consistency, we handle Free the same way here as we do for the
993 -- unbounded form, with the pessimistic assumption that it can fail.
994
995 Free (Source, X);
996 end loop;
997
998 if Source.Length = 1 then
999 pragma Assert (Source.First in 1 .. Source.Capacity);
1000 pragma Assert (Source.Last = Source.First);
1001 pragma Assert (N (Source.First).Prev = 0);
1002 pragma Assert (N (Source.Last).Next = 0);
1003
1004 -- Copy element from Source to Target
1005
1006 X := Source.First;
1007 Append (Target, N (X).Element);
1008
1009 -- Unlink node of Source
1010
1011 Source.First := 0;
1012 Source.Last := 0;
1013 Source.Length := 0;
1014
1015 -- Return the unlinked node to the free store
1016
1017 Free (Source, X);
1018 end if;
1019 end Move;
1020
1021 ----------
1022 -- Next --
1023 ----------
1024
1025 procedure Next (Container : List; Position : in out Cursor) is
1026 begin
1027 Position := Next (Container, Position);
1028 end Next;
1029
1030 function Next (Container : List; Position : Cursor) return Cursor is
1031 begin
1032 if Position.Node = 0 then
1033 return No_Element;
1034 end if;
1035
1036 if not Has_Element (Container, Position) then
1037 raise Program_Error with "Position cursor has no element";
1038 end if;
1039
1040 return (Node => Container.Nodes (Position.Node).Next);
1041 end Next;
1042
1043 -------------
1044 -- Prepend --
1045 -------------
1046
1047 procedure Prepend
1048 (Container : in out List;
1049 New_Item : Element_Type;
1050 Count : Count_Type := 1)
1051 is
1052 begin
1053 Insert (Container, First (Container), New_Item, Count);
1054 end Prepend;
1055
1056 --------------
1057 -- Previous --
1058 --------------
1059
1060 procedure Previous (Container : List; Position : in out Cursor) is
1061 begin
1062 Position := Previous (Container, Position);
1063 end Previous;
1064
1065 function Previous (Container : List; Position : Cursor) return Cursor is
1066 begin
1067 if Position.Node = 0 then
1068 return No_Element;
1069 end if;
1070
1071 if not Has_Element (Container, Position) then
1072 raise Program_Error with "Position cursor has no element";
1073 end if;
1074
1075 return (Node => Container.Nodes (Position.Node).Prev);
1076 end Previous;
1077
1078 ---------------------
1079 -- Replace_Element --
1080 ---------------------
1081
1082 procedure Replace_Element
1083 (Container : in out List;
1084 Position : Cursor;
1085 New_Item : Element_Type)
1086 is
1087 begin
1088 if not Has_Element (Container, Position) then
1089 raise Constraint_Error with "Position cursor has no element";
1090 end if;
1091
1092 pragma Assert
1093 (Vet (Container, Position), "bad cursor in Replace_Element");
1094
1095 Container.Nodes (Position.Node).Element := New_Item;
1096 end Replace_Element;
1097
1098 ----------------------
1099 -- Reverse_Elements --
1100 ----------------------
1101
1102 procedure Reverse_Elements (Container : in out List) is
1103 N : Node_Array renames Container.Nodes;
1104 I : Count_Type := Container.First;
1105 J : Count_Type := Container.Last;
1106
1107 procedure Swap (L, R : Count_Type);
1108
1109 ----------
1110 -- Swap --
1111 ----------
1112
1113 procedure Swap (L, R : Count_Type) is
1114 LN : constant Count_Type := N (L).Next;
1115 LP : constant Count_Type := N (L).Prev;
1116
1117 RN : constant Count_Type := N (R).Next;
1118 RP : constant Count_Type := N (R).Prev;
1119
1120 begin
1121 if LP /= 0 then
1122 N (LP).Next := R;
1123 end if;
1124
1125 if RN /= 0 then
1126 N (RN).Prev := L;
1127 end if;
1128
1129 N (L).Next := RN;
1130 N (R).Prev := LP;
1131
1132 if LN = R then
1133 pragma Assert (RP = L);
1134
1135 N (L).Prev := R;
1136 N (R).Next := L;
1137
1138 else
1139 N (L).Prev := RP;
1140 N (RP).Next := L;
1141
1142 N (R).Next := LN;
1143 N (LN).Prev := R;
1144 end if;
1145 end Swap;
1146
1147 -- Start of processing for Reverse_Elements
1148
1149 begin
1150 if Container.Length <= 1 then
1151 return;
1152 end if;
1153
1154 pragma Assert (N (Container.First).Prev = 0);
1155 pragma Assert (N (Container.Last).Next = 0);
1156
1157 Container.First := J;
1158 Container.Last := I;
1159 loop
1160 Swap (L => I, R => J);
1161
1162 J := N (J).Next;
1163 exit when I = J;
1164
1165 I := N (I).Prev;
1166 exit when I = J;
1167
1168 Swap (L => J, R => I);
1169
1170 I := N (I).Next;
1171 exit when I = J;
1172
1173 J := N (J).Prev;
1174 exit when I = J;
1175 end loop;
1176
1177 pragma Assert (N (Container.First).Prev = 0);
1178 pragma Assert (N (Container.Last).Next = 0);
1179 end Reverse_Elements;
1180
1181 ------------------
1182 -- Reverse_Find --
1183 ------------------
1184
1185 function Reverse_Find
1186 (Container : List;
1187 Item : Element_Type;
1188 Position : Cursor := No_Element) return Cursor
1189 is
1190 CFirst : Count_Type := Position.Node;
1191
1192 begin
1193 if CFirst = 0 then
1194 CFirst := Container.First;
1195 end if;
1196
1197 if Container.Length = 0 then
1198 return No_Element;
1199
1200 else
1201 while CFirst /= 0 loop
1202 if Container.Nodes (CFirst).Element = Item then
1203 return (Node => CFirst);
1204 else
1205 CFirst := Container.Nodes (CFirst).Prev;
1206 end if;
1207 end loop;
1208
1209 return No_Element;
1210 end if;
1211 end Reverse_Find;
1212
1213 ------------
1214 -- Splice --
1215 ------------
1216
1217 procedure Splice
1218 (Target : in out List;
1219 Before : Cursor;
1220 Source : in out List)
1221 is
1222 SN : Node_Array renames Source.Nodes;
1223
1224 begin
1225 if Before.Node /= 0 then
1226 pragma Assert (Vet (Target, Before), "bad cursor in Splice");
1227 end if;
1228
1229 if Target'Address = Source'Address
1230 or else Source.Length = 0
1231 then
1232 return;
1233 end if;
1234
1235 pragma Assert (SN (Source.First).Prev = 0);
1236 pragma Assert (SN (Source.Last).Next = 0);
1237
1238 if Target.Length > Count_Type'Base'Last - Source.Length then
1239 raise Constraint_Error with "new length exceeds maximum";
1240 end if;
1241
1242 if Target.Length + Source.Length > Target.Capacity then
1243 raise Constraint_Error;
1244 end if;
1245
1246 loop
1247 Insert (Target, Before, SN (Source.Last).Element);
1248 Delete_Last (Source);
1249 exit when Is_Empty (Source);
1250 end loop;
1251 end Splice;
1252
1253 procedure Splice
1254 (Target : in out List;
1255 Before : Cursor;
1256 Source : in out List;
1257 Position : in out Cursor)
1258 is
1259 Target_Position : Cursor;
1260
1261 begin
1262 if Target'Address = Source'Address then
1263 Splice (Target, Before, Position);
1264 return;
1265 end if;
1266
1267 if Position.Node = 0 then
1268 raise Constraint_Error with "Position cursor has no element";
1269 end if;
1270
1271 pragma Assert (Vet (Source, Position), "bad Position cursor in Splice");
1272
1273 if Target.Length >= Target.Capacity then
1274 raise Constraint_Error;
1275 end if;
1276
1277 Insert
1278 (Container => Target,
1279 Before => Before,
1280 New_Item => Source.Nodes (Position.Node).Element,
1281 Position => Target_Position);
1282
1283 Delete (Source, Position);
1284 Position := Target_Position;
1285 end Splice;
1286
1287 procedure Splice
1288 (Container : in out List;
1289 Before : Cursor;
1290 Position : Cursor)
1291 is
1292 N : Node_Array renames Container.Nodes;
1293
1294 begin
1295 if Before.Node /= 0 then
1296 pragma Assert
1297 (Vet (Container, Before), "bad Before cursor in Splice");
1298 end if;
1299
1300 if Position.Node = 0 then
1301 raise Constraint_Error with "Position cursor has no element";
1302 end if;
1303
1304 pragma Assert
1305 (Vet (Container, Position), "bad Position cursor in Splice");
1306
1307 if Position.Node = Before.Node
1308 or else N (Position.Node).Next = Before.Node
1309 then
1310 return;
1311 end if;
1312
1313 pragma Assert (Container.Length >= 2);
1314
1315 if Before.Node = 0 then
1316 pragma Assert (Position.Node /= Container.Last);
1317
1318 if Position.Node = Container.First then
1319 Container.First := N (Position.Node).Next;
1320 N (Container.First).Prev := 0;
1321
1322 else
1323 N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1324 N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1325 end if;
1326
1327 N (Container.Last).Next := Position.Node;
1328 N (Position.Node).Prev := Container.Last;
1329
1330 Container.Last := Position.Node;
1331 N (Container.Last).Next := 0;
1332
1333 return;
1334 end if;
1335
1336 if Before.Node = Container.First then
1337 pragma Assert (Position.Node /= Container.First);
1338
1339 if Position.Node = Container.Last then
1340 Container.Last := N (Position.Node).Prev;
1341 N (Container.Last).Next := 0;
1342
1343 else
1344 N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1345 N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1346 end if;
1347
1348 N (Container.First).Prev := Position.Node;
1349 N (Position.Node).Next := Container.First;
1350
1351 Container.First := Position.Node;
1352 N (Container.First).Prev := 0;
1353
1354 return;
1355 end if;
1356
1357 if Position.Node = Container.First then
1358 Container.First := N (Position.Node).Next;
1359 N (Container.First).Prev := 0;
1360
1361 elsif Position.Node = Container.Last then
1362 Container.Last := N (Position.Node).Prev;
1363 N (Container.Last).Next := 0;
1364
1365 else
1366 N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1367 N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1368 end if;
1369
1370 N (N (Before.Node).Prev).Next := Position.Node;
1371 N (Position.Node).Prev := N (Before.Node).Prev;
1372
1373 N (Before.Node).Prev := Position.Node;
1374 N (Position.Node).Next := Before.Node;
1375
1376 pragma Assert (N (Container.First).Prev = 0);
1377 pragma Assert (N (Container.Last).Next = 0);
1378 end Splice;
1379
1380 ------------------
1381 -- Strict_Equal --
1382 ------------------
1383
1384 function Strict_Equal (Left, Right : List) return Boolean is
1385 CL : Count_Type := Left.First;
1386 CR : Count_Type := Right.First;
1387
1388 begin
1389 while CL /= 0 or CR /= 0 loop
1390 if CL /= CR or else
1391 Left.Nodes (CL).Element /= Right.Nodes (CL).Element
1392 then
1393 return False;
1394 end if;
1395
1396 CL := Left.Nodes (CL).Next;
1397 CR := Right.Nodes (CR).Next;
1398 end loop;
1399
1400 return True;
1401 end Strict_Equal;
1402
1403 ----------
1404 -- Swap --
1405 ----------
1406
1407 procedure Swap
1408 (Container : in out List;
1409 I, J : Cursor)
1410 is
1411 begin
1412 if I.Node = 0 then
1413 raise Constraint_Error with "I cursor has no element";
1414 end if;
1415
1416 if J.Node = 0 then
1417 raise Constraint_Error with "J cursor has no element";
1418 end if;
1419
1420 if I.Node = J.Node then
1421 return;
1422 end if;
1423
1424 pragma Assert (Vet (Container, I), "bad I cursor in Swap");
1425 pragma Assert (Vet (Container, J), "bad J cursor in Swap");
1426
1427 declare
1428 NN : Node_Array renames Container.Nodes;
1429 NI : Node_Type renames NN (I.Node);
1430 NJ : Node_Type renames NN (J.Node);
1431
1432 EI_Copy : constant Element_Type := NI.Element;
1433
1434 begin
1435 NI.Element := NJ.Element;
1436 NJ.Element := EI_Copy;
1437 end;
1438 end Swap;
1439
1440 ----------------
1441 -- Swap_Links --
1442 ----------------
1443
1444 procedure Swap_Links
1445 (Container : in out List;
1446 I, J : Cursor)
1447 is
1448 I_Next, J_Next : Cursor;
1449
1450 begin
1451 if I.Node = 0 then
1452 raise Constraint_Error with "I cursor has no element";
1453 end if;
1454
1455 if J.Node = 0 then
1456 raise Constraint_Error with "J cursor has no element";
1457 end if;
1458
1459 if I.Node = J.Node then
1460 return;
1461 end if;
1462
1463 pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links");
1464 pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links");
1465
1466 I_Next := Next (Container, I);
1467
1468 if I_Next = J then
1469 Splice (Container, Before => I, Position => J);
1470
1471 else
1472 J_Next := Next (Container, J);
1473
1474 if J_Next = I then
1475 Splice (Container, Before => J, Position => I);
1476
1477 else
1478 pragma Assert (Container.Length >= 3);
1479 Splice (Container, Before => I_Next, Position => J);
1480 Splice (Container, Before => J_Next, Position => I);
1481 end if;
1482 end if;
1483 end Swap_Links;
1484
1485 ---------
1486 -- Vet --
1487 ---------
1488
1489 function Vet (L : List; Position : Cursor) return Boolean is
1490 N : Node_Array renames L.Nodes;
1491
1492 begin
1493 if L.Length = 0 then
1494 return False;
1495 end if;
1496
1497 if L.First = 0 then
1498 return False;
1499 end if;
1500
1501 if L.Last = 0 then
1502 return False;
1503 end if;
1504
1505 if Position.Node > L.Capacity then
1506 return False;
1507 end if;
1508
1509 if N (Position.Node).Prev < 0
1510 or else N (Position.Node).Prev > L.Capacity
1511 then
1512 return False;
1513 end if;
1514
1515 if N (Position.Node).Next > L.Capacity then
1516 return False;
1517 end if;
1518
1519 if N (L.First).Prev /= 0 then
1520 return False;
1521 end if;
1522
1523 if N (L.Last).Next /= 0 then
1524 return False;
1525 end if;
1526
1527 if N (Position.Node).Prev = 0
1528 and then Position.Node /= L.First
1529 then
1530 return False;
1531 end if;
1532
1533 if N (Position.Node).Next = 0
1534 and then Position.Node /= L.Last
1535 then
1536 return False;
1537 end if;
1538
1539 if L.Length = 1 then
1540 return L.First = L.Last;
1541 end if;
1542
1543 if L.First = L.Last then
1544 return False;
1545 end if;
1546
1547 if N (L.First).Next = 0 then
1548 return False;
1549 end if;
1550
1551 if N (L.Last).Prev = 0 then
1552 return False;
1553 end if;
1554
1555 if N (N (L.First).Next).Prev /= L.First then
1556 return False;
1557 end if;
1558
1559 if N (N (L.Last).Prev).Next /= L.Last then
1560 return False;
1561 end if;
1562
1563 if L.Length = 2 then
1564 if N (L.First).Next /= L.Last then
1565 return False;
1566 end if;
1567
1568 if N (L.Last).Prev /= L.First then
1569 return False;
1570 end if;
1571
1572 return True;
1573 end if;
1574
1575 if N (L.First).Next = L.Last then
1576 return False;
1577 end if;
1578
1579 if N (L.Last).Prev = L.First then
1580 return False;
1581 end if;
1582
1583 if Position.Node = L.First then
1584 return True;
1585 end if;
1586
1587 if Position.Node = L.Last then
1588 return True;
1589 end if;
1590
1591 if N (Position.Node).Next = 0 then
1592 return False;
1593 end if;
1594
1595 if N (Position.Node).Prev = 0 then
1596 return False;
1597 end if;
1598
1599 if N (N (Position.Node).Next).Prev /= Position.Node then
1600 return False;
1601 end if;
1602
1603 if N (N (Position.Node).Prev).Next /= Position.Node then
1604 return False;
1605 end if;
1606
1607 if L.Length = 3 then
1608 if N (L.First).Next /= Position.Node then
1609 return False;
1610 end if;
1611
1612 if N (L.Last).Prev /= Position.Node then
1613 return False;
1614 end if;
1615 end if;
1616
1617 return True;
1618 end Vet;
1619
1620 end Ada.Containers.Formal_Doubly_Linked_Lists;