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