File : a-cdlili.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2015, 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 Ada.Unchecked_Deallocation;
31
32 with System; use type System.Address;
33
34 package body Ada.Containers.Doubly_Linked_Lists is
35
36 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
37 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
38 -- See comment in Ada.Containers.Helpers
39
40 -----------------------
41 -- Local Subprograms --
42 -----------------------
43
44 procedure Free (X : in out Node_Access);
45
46 procedure Insert_Internal
47 (Container : in out List;
48 Before : Node_Access;
49 New_Node : Node_Access);
50
51 procedure Splice_Internal
52 (Target : in out List;
53 Before : Node_Access;
54 Source : in out List);
55
56 procedure Splice_Internal
57 (Target : in out List;
58 Before : Node_Access;
59 Source : in out List;
60 Position : Node_Access);
61
62 function Vet (Position : Cursor) return Boolean;
63 -- Checks invariants of the cursor and its designated container, as a
64 -- simple way of detecting dangling references (see operation Free for a
65 -- description of the detection mechanism), returning True if all checks
66 -- pass. Invocations of Vet are used here as the argument of pragma Assert,
67 -- so the checks are performed only when assertions are enabled.
68
69 ---------
70 -- "=" --
71 ---------
72
73 function "=" (Left, Right : List) return Boolean is
74 begin
75 if Left.Length /= Right.Length then
76 return False;
77 end if;
78
79 if Left.Length = 0 then
80 return True;
81 end if;
82
83 declare
84 -- Per AI05-0022, the container implementation is required to detect
85 -- element tampering by a generic actual subprogram.
86
87 Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
88 Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
89
90 L : Node_Access := Left.First;
91 R : Node_Access := Right.First;
92 begin
93 for J in 1 .. Left.Length loop
94 if L.Element /= R.Element then
95 return False;
96 end if;
97
98 L := L.Next;
99 R := R.Next;
100 end loop;
101 end;
102
103 return True;
104 end "=";
105
106 ------------
107 -- Adjust --
108 ------------
109
110 procedure Adjust (Container : in out List) is
111 Src : Node_Access := Container.First;
112
113 begin
114 -- If the counts are nonzero, execution is technically erroneous, but
115 -- it seems friendly to allow things like concurrent "=" on shared
116 -- constants.
117
118 Zero_Counts (Container.TC);
119
120 if Src = null then
121 pragma Assert (Container.Last = null);
122 pragma Assert (Container.Length = 0);
123 return;
124 end if;
125
126 pragma Assert (Container.First.Prev = null);
127 pragma Assert (Container.Last.Next = null);
128 pragma Assert (Container.Length > 0);
129
130 Container.First := null;
131 Container.Last := null;
132 Container.Length := 0;
133 Zero_Counts (Container.TC);
134
135 Container.First := new Node_Type'(Src.Element, null, null);
136 Container.Last := Container.First;
137 Container.Length := 1;
138
139 Src := Src.Next;
140 while Src /= null loop
141 Container.Last.Next := new Node_Type'(Element => Src.Element,
142 Prev => Container.Last,
143 Next => null);
144 Container.Last := Container.Last.Next;
145 Container.Length := Container.Length + 1;
146
147 Src := Src.Next;
148 end loop;
149 end Adjust;
150
151 ------------
152 -- Append --
153 ------------
154
155 procedure Append
156 (Container : in out List;
157 New_Item : Element_Type;
158 Count : Count_Type := 1)
159 is
160 begin
161 Insert (Container, No_Element, New_Item, Count);
162 end Append;
163
164 ------------
165 -- Assign --
166 ------------
167
168 procedure Assign (Target : in out List; Source : List) is
169 Node : Node_Access;
170
171 begin
172 if Target'Address = Source'Address then
173 return;
174 end if;
175
176 Target.Clear;
177
178 Node := Source.First;
179 while Node /= null loop
180 Target.Append (Node.Element);
181 Node := Node.Next;
182 end loop;
183 end Assign;
184
185 -----------
186 -- Clear --
187 -----------
188
189 procedure Clear (Container : in out List) is
190 X : Node_Access;
191
192 begin
193 if Container.Length = 0 then
194 pragma Assert (Container.First = null);
195 pragma Assert (Container.Last = null);
196 pragma Assert (Container.TC = (Busy => 0, Lock => 0));
197 return;
198 end if;
199
200 pragma Assert (Container.First.Prev = null);
201 pragma Assert (Container.Last.Next = null);
202
203 TC_Check (Container.TC);
204
205 while Container.Length > 1 loop
206 X := Container.First;
207 pragma Assert (X.Next.Prev = Container.First);
208
209 Container.First := X.Next;
210 Container.First.Prev := null;
211
212 Container.Length := Container.Length - 1;
213
214 Free (X);
215 end loop;
216
217 X := Container.First;
218 pragma Assert (X = Container.Last);
219
220 Container.First := null;
221 Container.Last := null;
222 Container.Length := 0;
223
224 pragma Warnings (Off);
225 Free (X);
226 pragma Warnings (On);
227 end Clear;
228
229 ------------------------
230 -- Constant_Reference --
231 ------------------------
232
233 function Constant_Reference
234 (Container : aliased List;
235 Position : Cursor) return Constant_Reference_Type
236 is
237 begin
238 if Checks and then Position.Container = null then
239 raise Constraint_Error with "Position cursor has no element";
240 end if;
241
242 if Checks and then Position.Container /= Container'Unrestricted_Access
243 then
244 raise Program_Error with
245 "Position cursor designates wrong container";
246 end if;
247
248 pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
249
250 declare
251 TC : constant Tamper_Counts_Access :=
252 Container.TC'Unrestricted_Access;
253 begin
254 return R : constant Constant_Reference_Type :=
255 (Element => Position.Node.Element'Access,
256 Control => (Controlled with TC))
257 do
258 Lock (TC.all);
259 end return;
260 end;
261 end Constant_Reference;
262
263 --------------
264 -- Contains --
265 --------------
266
267 function Contains
268 (Container : List;
269 Item : Element_Type) return Boolean
270 is
271 begin
272 return Find (Container, Item) /= No_Element;
273 end Contains;
274
275 ----------
276 -- Copy --
277 ----------
278
279 function Copy (Source : List) return List is
280 begin
281 return Target : List do
282 Target.Assign (Source);
283 end return;
284 end Copy;
285
286 ------------
287 -- Delete --
288 ------------
289
290 procedure Delete
291 (Container : in out List;
292 Position : in out Cursor;
293 Count : Count_Type := 1)
294 is
295 X : Node_Access;
296
297 begin
298 if Checks and then Position.Node = null then
299 raise Constraint_Error with
300 "Position cursor has no element";
301 end if;
302
303 if Checks and then Position.Container /= Container'Unrestricted_Access
304 then
305 raise Program_Error with
306 "Position cursor designates wrong container";
307 end if;
308
309 pragma Assert (Vet (Position), "bad cursor in Delete");
310
311 if Position.Node = Container.First then
312 Delete_First (Container, Count);
313 Position := No_Element; -- Post-York behavior
314 return;
315 end if;
316
317 if Count = 0 then
318 Position := No_Element; -- Post-York behavior
319 return;
320 end if;
321
322 TC_Check (Container.TC);
323
324 for Index in 1 .. Count loop
325 X := Position.Node;
326 Container.Length := Container.Length - 1;
327
328 if X = Container.Last then
329 Position := No_Element;
330
331 Container.Last := X.Prev;
332 Container.Last.Next := null;
333
334 Free (X);
335 return;
336 end if;
337
338 Position.Node := X.Next;
339
340 X.Next.Prev := X.Prev;
341 X.Prev.Next := X.Next;
342
343 Free (X);
344 end loop;
345
346 -- The following comment is unacceptable, more detail needed ???
347
348 Position := No_Element; -- Post-York behavior
349 end Delete;
350
351 ------------------
352 -- Delete_First --
353 ------------------
354
355 procedure Delete_First
356 (Container : in out List;
357 Count : Count_Type := 1)
358 is
359 X : Node_Access;
360
361 begin
362 if Count >= Container.Length then
363 Clear (Container);
364 return;
365 end if;
366
367 if Count = 0 then
368 return;
369 end if;
370
371 TC_Check (Container.TC);
372
373 for J in 1 .. Count loop
374 X := Container.First;
375 pragma Assert (X.Next.Prev = Container.First);
376
377 Container.First := X.Next;
378 Container.First.Prev := null;
379
380 Container.Length := Container.Length - 1;
381
382 Free (X);
383 end loop;
384 end Delete_First;
385
386 -----------------
387 -- Delete_Last --
388 -----------------
389
390 procedure Delete_Last
391 (Container : in out List;
392 Count : Count_Type := 1)
393 is
394 X : Node_Access;
395
396 begin
397 if Count >= Container.Length then
398 Clear (Container);
399 return;
400 end if;
401
402 if Count = 0 then
403 return;
404 end if;
405
406 TC_Check (Container.TC);
407
408 for J in 1 .. Count loop
409 X := Container.Last;
410 pragma Assert (X.Prev.Next = Container.Last);
411
412 Container.Last := X.Prev;
413 Container.Last.Next := null;
414
415 Container.Length := Container.Length - 1;
416
417 Free (X);
418 end loop;
419 end Delete_Last;
420
421 -------------
422 -- Element --
423 -------------
424
425 function Element (Position : Cursor) return Element_Type is
426 begin
427 if Checks and then Position.Node = null then
428 raise Constraint_Error with
429 "Position cursor has no element";
430 end if;
431
432 pragma Assert (Vet (Position), "bad cursor in Element");
433
434 return Position.Node.Element;
435 end Element;
436
437 --------------
438 -- Finalize --
439 --------------
440
441 procedure Finalize (Object : in out Iterator) is
442 begin
443 if Object.Container /= null then
444 Unbusy (Object.Container.TC);
445 end if;
446 end Finalize;
447
448 ----------
449 -- Find --
450 ----------
451
452 function Find
453 (Container : List;
454 Item : Element_Type;
455 Position : Cursor := No_Element) return Cursor
456 is
457 Node : Node_Access := Position.Node;
458
459 begin
460 if Node = null then
461 Node := Container.First;
462
463 else
464 if Checks and then Position.Container /= Container'Unrestricted_Access
465 then
466 raise Program_Error with
467 "Position cursor designates wrong container";
468 end if;
469
470 pragma Assert (Vet (Position), "bad cursor in Find");
471 end if;
472
473 -- Per AI05-0022, the container implementation is required to detect
474 -- element tampering by a generic actual subprogram.
475
476 declare
477 Lock : With_Lock (Container.TC'Unrestricted_Access);
478 begin
479 while Node /= null loop
480 if Node.Element = Item then
481 return Cursor'(Container'Unrestricted_Access, Node);
482 end if;
483
484 Node := Node.Next;
485 end loop;
486
487 return No_Element;
488 end;
489 end Find;
490
491 -----------
492 -- First --
493 -----------
494
495 function First (Container : List) return Cursor is
496 begin
497 if Container.First = null then
498 return No_Element;
499 else
500 return Cursor'(Container'Unrestricted_Access, Container.First);
501 end if;
502 end First;
503
504 function First (Object : Iterator) return Cursor is
505 begin
506 -- The value of the iterator object's Node component influences the
507 -- behavior of the First (and Last) selector function.
508
509 -- When the Node component is null, this means the iterator object was
510 -- constructed without a start expression, in which case the (forward)
511 -- iteration starts from the (logical) beginning of the entire sequence
512 -- of items (corresponding to Container.First, for a forward iterator).
513
514 -- Otherwise, this is iteration over a partial sequence of items. When
515 -- the Node component is non-null, the iterator object was constructed
516 -- with a start expression, that specifies the position from which the
517 -- (forward) partial iteration begins.
518
519 if Object.Node = null then
520 return Doubly_Linked_Lists.First (Object.Container.all);
521 else
522 return Cursor'(Object.Container, Object.Node);
523 end if;
524 end First;
525
526 -------------------
527 -- First_Element --
528 -------------------
529
530 function First_Element (Container : List) return Element_Type is
531 begin
532 if Checks and then Container.First = null then
533 raise Constraint_Error with "list is empty";
534 end if;
535
536 return Container.First.Element;
537 end First_Element;
538
539 ----------
540 -- Free --
541 ----------
542
543 procedure Free (X : in out Node_Access) is
544 procedure Deallocate is
545 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
546
547 begin
548 -- While a node is in use, as an active link in a list, its Previous and
549 -- Next components must be null, or designate a different node; this is
550 -- a node invariant. Before actually deallocating the node, we set both
551 -- access value components of the node to point to the node itself, thus
552 -- falsifying the node invariant. Subprogram Vet inspects the value of
553 -- the node components when interrogating the node, in order to detect
554 -- whether the cursor's node access value is dangling.
555
556 -- Note that we have no guarantee that the storage for the node isn't
557 -- modified when it is deallocated, but there are other tests that Vet
558 -- does if node invariants appear to be satisifed. However, in practice
559 -- this simple test works well enough, detecting dangling references
560 -- immediately, without needing further interrogation.
561
562 X.Prev := X;
563 X.Next := X;
564
565 Deallocate (X);
566 end Free;
567
568 ---------------------
569 -- Generic_Sorting --
570 ---------------------
571
572 package body Generic_Sorting is
573
574 ---------------
575 -- Is_Sorted --
576 ---------------
577
578 function Is_Sorted (Container : List) return Boolean is
579 -- Per AI05-0022, the container implementation is required to detect
580 -- element tampering by a generic actual subprogram.
581
582 Lock : With_Lock (Container.TC'Unrestricted_Access);
583
584 Node : Node_Access;
585 begin
586 Node := Container.First;
587 for Idx in 2 .. Container.Length loop
588 if Node.Next.Element < Node.Element then
589 return False;
590 end if;
591
592 Node := Node.Next;
593 end loop;
594
595 return True;
596 end Is_Sorted;
597
598 -----------
599 -- Merge --
600 -----------
601
602 procedure Merge
603 (Target : in out List;
604 Source : in out List)
605 is
606 begin
607 -- The semantics of Merge changed slightly per AI05-0021. It was
608 -- originally the case that if Target and Source denoted the same
609 -- container object, then the GNAT implementation of Merge did
610 -- nothing. However, it was argued that RM05 did not precisely
611 -- specify the semantics for this corner case. The decision of the
612 -- ARG was that if Target and Source denote the same non-empty
613 -- container object, then Program_Error is raised.
614
615 if Source.Is_Empty then
616 return;
617 end if;
618
619 if Checks and then Target'Address = Source'Address then
620 raise Program_Error with
621 "Target and Source denote same non-empty container";
622 end if;
623
624 if Checks and then Target.Length > Count_Type'Last - Source.Length
625 then
626 raise Constraint_Error with "new length exceeds maximum";
627 end if;
628
629 TC_Check (Target.TC);
630 TC_Check (Source.TC);
631
632 -- Per AI05-0022, the container implementation is required to detect
633 -- element tampering by a generic actual subprogram.
634
635 declare
636 Lock_Target : With_Lock (Target.TC'Unchecked_Access);
637 Lock_Source : With_Lock (Source.TC'Unchecked_Access);
638
639 LI, RI, RJ : Node_Access;
640
641 begin
642 LI := Target.First;
643 RI := Source.First;
644 while RI /= null loop
645 pragma Assert (RI.Next = null
646 or else not (RI.Next.Element < RI.Element));
647
648 if LI = null then
649 Splice_Internal (Target, null, Source);
650 exit;
651 end if;
652
653 pragma Assert (LI.Next = null
654 or else not (LI.Next.Element < LI.Element));
655
656 if RI.Element < LI.Element then
657 RJ := RI;
658 RI := RI.Next;
659 Splice_Internal (Target, LI, Source, RJ);
660
661 else
662 LI := LI.Next;
663 end if;
664 end loop;
665 end;
666 end Merge;
667
668 ----------
669 -- Sort --
670 ----------
671
672 procedure Sort (Container : in out List) is
673
674 procedure Partition (Pivot : Node_Access; Back : Node_Access);
675
676 procedure Sort (Front, Back : Node_Access);
677
678 ---------------
679 -- Partition --
680 ---------------
681
682 procedure Partition (Pivot : Node_Access; Back : Node_Access) is
683 Node : Node_Access;
684
685 begin
686 Node := Pivot.Next;
687 while Node /= Back loop
688 if Node.Element < Pivot.Element then
689 declare
690 Prev : constant Node_Access := Node.Prev;
691 Next : constant Node_Access := Node.Next;
692
693 begin
694 Prev.Next := Next;
695
696 if Next = null then
697 Container.Last := Prev;
698 else
699 Next.Prev := Prev;
700 end if;
701
702 Node.Next := Pivot;
703 Node.Prev := Pivot.Prev;
704
705 Pivot.Prev := Node;
706
707 if Node.Prev = null then
708 Container.First := Node;
709 else
710 Node.Prev.Next := Node;
711 end if;
712
713 Node := Next;
714 end;
715
716 else
717 Node := Node.Next;
718 end if;
719 end loop;
720 end Partition;
721
722 ----------
723 -- Sort --
724 ----------
725
726 procedure Sort (Front, Back : Node_Access) is
727 Pivot : constant Node_Access :=
728 (if Front = null then Container.First else Front.Next);
729 begin
730 if Pivot /= Back then
731 Partition (Pivot, Back);
732 Sort (Front, Pivot);
733 Sort (Pivot, Back);
734 end if;
735 end Sort;
736
737 -- Start of processing for Sort
738
739 begin
740 if Container.Length <= 1 then
741 return;
742 end if;
743
744 pragma Assert (Container.First.Prev = null);
745 pragma Assert (Container.Last.Next = null);
746
747 TC_Check (Container.TC);
748
749 -- Per AI05-0022, the container implementation is required to detect
750 -- element tampering by a generic actual subprogram.
751
752 declare
753 Lock : With_Lock (Container.TC'Unchecked_Access);
754 begin
755 Sort (Front => null, Back => null);
756 end;
757
758 pragma Assert (Container.First.Prev = null);
759 pragma Assert (Container.Last.Next = null);
760 end Sort;
761
762 end Generic_Sorting;
763
764 ------------------------
765 -- Get_Element_Access --
766 ------------------------
767
768 function Get_Element_Access
769 (Position : Cursor) return not null Element_Access is
770 begin
771 return Position.Node.Element'Access;
772 end Get_Element_Access;
773
774 -----------------
775 -- Has_Element --
776 -----------------
777
778 function Has_Element (Position : Cursor) return Boolean is
779 begin
780 pragma Assert (Vet (Position), "bad cursor in Has_Element");
781 return Position.Node /= null;
782 end Has_Element;
783
784 ------------
785 -- Insert --
786 ------------
787
788 procedure Insert
789 (Container : in out List;
790 Before : Cursor;
791 New_Item : Element_Type;
792 Position : out Cursor;
793 Count : Count_Type := 1)
794 is
795 First_Node : Node_Access;
796 New_Node : Node_Access;
797
798 begin
799 if Before.Container /= null then
800 if Checks and then Before.Container /= Container'Unrestricted_Access
801 then
802 raise Program_Error with
803 "Before cursor designates wrong list";
804 end if;
805
806 pragma Assert (Vet (Before), "bad cursor in Insert");
807 end if;
808
809 if Count = 0 then
810 Position := Before;
811 return;
812 end if;
813
814 if Checks and then Container.Length > Count_Type'Last - Count then
815 raise Constraint_Error with "new length exceeds maximum";
816 end if;
817
818 TC_Check (Container.TC);
819
820 New_Node := new Node_Type'(New_Item, null, null);
821 First_Node := New_Node;
822 Insert_Internal (Container, Before.Node, New_Node);
823
824 for J in 2 .. Count loop
825 New_Node := new Node_Type'(New_Item, null, null);
826 Insert_Internal (Container, Before.Node, New_Node);
827 end loop;
828
829 Position := Cursor'(Container'Unchecked_Access, First_Node);
830 end Insert;
831
832 procedure Insert
833 (Container : in out List;
834 Before : Cursor;
835 New_Item : Element_Type;
836 Count : Count_Type := 1)
837 is
838 Position : Cursor;
839 pragma Unreferenced (Position);
840 begin
841 Insert (Container, Before, New_Item, Position, Count);
842 end Insert;
843
844 procedure Insert
845 (Container : in out List;
846 Before : Cursor;
847 Position : out Cursor;
848 Count : Count_Type := 1)
849 is
850 First_Node : Node_Access;
851 New_Node : Node_Access;
852
853 begin
854 if Before.Container /= null then
855 if Checks and then Before.Container /= Container'Unrestricted_Access
856 then
857 raise Program_Error with
858 "Before cursor designates wrong list";
859 end if;
860
861 pragma Assert (Vet (Before), "bad cursor in Insert");
862 end if;
863
864 if Count = 0 then
865 Position := Before;
866 return;
867 end if;
868
869 if Checks and then Container.Length > Count_Type'Last - Count then
870 raise Constraint_Error with "new length exceeds maximum";
871 end if;
872
873 TC_Check (Container.TC);
874
875 New_Node := new Node_Type;
876 First_Node := New_Node;
877 Insert_Internal (Container, Before.Node, New_Node);
878
879 for J in 2 .. Count loop
880 New_Node := new Node_Type;
881 Insert_Internal (Container, Before.Node, New_Node);
882 end loop;
883
884 Position := Cursor'(Container'Unchecked_Access, First_Node);
885 end Insert;
886
887 ---------------------
888 -- Insert_Internal --
889 ---------------------
890
891 procedure Insert_Internal
892 (Container : in out List;
893 Before : Node_Access;
894 New_Node : Node_Access)
895 is
896 begin
897 if Container.Length = 0 then
898 pragma Assert (Before = null);
899 pragma Assert (Container.First = null);
900 pragma Assert (Container.Last = null);
901
902 Container.First := New_Node;
903 Container.Last := New_Node;
904
905 elsif Before = null then
906 pragma Assert (Container.Last.Next = null);
907
908 Container.Last.Next := New_Node;
909 New_Node.Prev := Container.Last;
910
911 Container.Last := New_Node;
912
913 elsif Before = Container.First then
914 pragma Assert (Container.First.Prev = null);
915
916 Container.First.Prev := New_Node;
917 New_Node.Next := Container.First;
918
919 Container.First := New_Node;
920
921 else
922 pragma Assert (Container.First.Prev = null);
923 pragma Assert (Container.Last.Next = null);
924
925 New_Node.Next := Before;
926 New_Node.Prev := Before.Prev;
927
928 Before.Prev.Next := New_Node;
929 Before.Prev := New_Node;
930 end if;
931
932 Container.Length := Container.Length + 1;
933 end Insert_Internal;
934
935 --------------
936 -- Is_Empty --
937 --------------
938
939 function Is_Empty (Container : List) return Boolean is
940 begin
941 return Container.Length = 0;
942 end Is_Empty;
943
944 -------------
945 -- Iterate --
946 -------------
947
948 procedure Iterate
949 (Container : List;
950 Process : not null access procedure (Position : Cursor))
951 is
952 Busy : With_Busy (Container.TC'Unrestricted_Access);
953 Node : Node_Access := Container.First;
954
955 begin
956 while Node /= null loop
957 Process (Cursor'(Container'Unrestricted_Access, Node));
958 Node := Node.Next;
959 end loop;
960 end Iterate;
961
962 function Iterate (Container : List)
963 return List_Iterator_Interfaces.Reversible_Iterator'Class
964 is
965 begin
966 -- The value of the Node component influences the behavior of the First
967 -- and Last selector functions of the iterator object. When the Node
968 -- component is null (as is the case here), this means the iterator
969 -- object was constructed without a start expression. This is a
970 -- complete iterator, meaning that the iteration starts from the
971 -- (logical) beginning of the sequence of items.
972
973 -- Note: For a forward iterator, Container.First is the beginning, and
974 -- for a reverse iterator, Container.Last is the beginning.
975
976 return It : constant Iterator :=
977 Iterator'(Limited_Controlled with
978 Container => Container'Unrestricted_Access,
979 Node => null)
980 do
981 Busy (Container.TC'Unrestricted_Access.all);
982 end return;
983 end Iterate;
984
985 function Iterate (Container : List; Start : Cursor)
986 return List_Iterator_Interfaces.Reversible_Iterator'Class
987 is
988 begin
989 -- It was formerly the case that when Start = No_Element, the partial
990 -- iterator was defined to behave the same as for a complete iterator,
991 -- and iterate over the entire sequence of items. However, those
992 -- semantics were unintuitive and arguably error-prone (it is too easy
993 -- to accidentally create an endless loop), and so they were changed,
994 -- per the ARG meeting in Denver on 2011/11. However, there was no
995 -- consensus about what positive meaning this corner case should have,
996 -- and so it was decided to simply raise an exception. This does imply,
997 -- however, that it is not possible to use a partial iterator to specify
998 -- an empty sequence of items.
999
1000 if Checks and then Start = No_Element then
1001 raise Constraint_Error with
1002 "Start position for iterator equals No_Element";
1003 end if;
1004
1005 if Checks and then Start.Container /= Container'Unrestricted_Access then
1006 raise Program_Error with
1007 "Start cursor of Iterate designates wrong list";
1008 end if;
1009
1010 pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
1011
1012 -- The value of the Node component influences the behavior of the First
1013 -- and Last selector functions of the iterator object. When the Node
1014 -- component is non-null (as is the case here), it means that this is a
1015 -- partial iteration, over a subset of the complete sequence of items.
1016 -- The iterator object was constructed with a start expression,
1017 -- indicating the position from which the iteration begins. Note that
1018 -- the start position has the same value irrespective of whether this is
1019 -- a forward or reverse iteration.
1020
1021 return It : constant Iterator :=
1022 Iterator'(Limited_Controlled with
1023 Container => Container'Unrestricted_Access,
1024 Node => Start.Node)
1025 do
1026 Busy (Container.TC'Unrestricted_Access.all);
1027 end return;
1028 end Iterate;
1029
1030 ----------
1031 -- Last --
1032 ----------
1033
1034 function Last (Container : List) return Cursor is
1035 begin
1036 if Container.Last = null then
1037 return No_Element;
1038 else
1039 return Cursor'(Container'Unrestricted_Access, Container.Last);
1040 end if;
1041 end Last;
1042
1043 function Last (Object : Iterator) return Cursor is
1044 begin
1045 -- The value of the iterator object's Node component influences the
1046 -- behavior of the Last (and First) selector function.
1047
1048 -- When the Node component is null, this means the iterator object was
1049 -- constructed without a start expression, in which case the (reverse)
1050 -- iteration starts from the (logical) beginning of the entire sequence
1051 -- (corresponding to Container.Last, for a reverse iterator).
1052
1053 -- Otherwise, this is iteration over a partial sequence of items. When
1054 -- the Node component is non-null, the iterator object was constructed
1055 -- with a start expression, that specifies the position from which the
1056 -- (reverse) partial iteration begins.
1057
1058 if Object.Node = null then
1059 return Doubly_Linked_Lists.Last (Object.Container.all);
1060 else
1061 return Cursor'(Object.Container, Object.Node);
1062 end if;
1063 end Last;
1064
1065 ------------------
1066 -- Last_Element --
1067 ------------------
1068
1069 function Last_Element (Container : List) return Element_Type is
1070 begin
1071 if Checks and then Container.Last = null then
1072 raise Constraint_Error with "list is empty";
1073 end if;
1074
1075 return Container.Last.Element;
1076 end Last_Element;
1077
1078 ------------
1079 -- Length --
1080 ------------
1081
1082 function Length (Container : List) return Count_Type is
1083 begin
1084 return Container.Length;
1085 end Length;
1086
1087 ----------
1088 -- Move --
1089 ----------
1090
1091 procedure Move
1092 (Target : in out List;
1093 Source : in out List)
1094 is
1095 begin
1096 if Target'Address = Source'Address then
1097 return;
1098 end if;
1099
1100 TC_Check (Source.TC);
1101
1102 Clear (Target);
1103
1104 Target.First := Source.First;
1105 Source.First := null;
1106
1107 Target.Last := Source.Last;
1108 Source.Last := null;
1109
1110 Target.Length := Source.Length;
1111 Source.Length := 0;
1112 end Move;
1113
1114 ----------
1115 -- Next --
1116 ----------
1117
1118 procedure Next (Position : in out Cursor) is
1119 begin
1120 Position := Next (Position);
1121 end Next;
1122
1123 function Next (Position : Cursor) return Cursor is
1124 begin
1125 if Position.Node = null then
1126 return No_Element;
1127
1128 else
1129 pragma Assert (Vet (Position), "bad cursor in Next");
1130
1131 declare
1132 Next_Node : constant Node_Access := Position.Node.Next;
1133 begin
1134 if Next_Node = null then
1135 return No_Element;
1136 else
1137 return Cursor'(Position.Container, Next_Node);
1138 end if;
1139 end;
1140 end if;
1141 end Next;
1142
1143 function Next
1144 (Object : Iterator;
1145 Position : Cursor) return Cursor
1146 is
1147 begin
1148 if Position.Container = null then
1149 return No_Element;
1150 end if;
1151
1152 if Checks and then Position.Container /= Object.Container then
1153 raise Program_Error with
1154 "Position cursor of Next designates wrong list";
1155 end if;
1156
1157 return Next (Position);
1158 end Next;
1159
1160 -------------
1161 -- Prepend --
1162 -------------
1163
1164 procedure Prepend
1165 (Container : in out List;
1166 New_Item : Element_Type;
1167 Count : Count_Type := 1)
1168 is
1169 begin
1170 Insert (Container, First (Container), New_Item, Count);
1171 end Prepend;
1172
1173 --------------
1174 -- Previous --
1175 --------------
1176
1177 procedure Previous (Position : in out Cursor) is
1178 begin
1179 Position := Previous (Position);
1180 end Previous;
1181
1182 function Previous (Position : Cursor) return Cursor is
1183 begin
1184 if Position.Node = null then
1185 return No_Element;
1186
1187 else
1188 pragma Assert (Vet (Position), "bad cursor in Previous");
1189
1190 declare
1191 Prev_Node : constant Node_Access := Position.Node.Prev;
1192 begin
1193 if Prev_Node = null then
1194 return No_Element;
1195 else
1196 return Cursor'(Position.Container, Prev_Node);
1197 end if;
1198 end;
1199 end if;
1200 end Previous;
1201
1202 function Previous
1203 (Object : Iterator;
1204 Position : Cursor) return Cursor
1205 is
1206 begin
1207 if Position.Container = null then
1208 return No_Element;
1209 end if;
1210
1211 if Checks and then Position.Container /= Object.Container then
1212 raise Program_Error with
1213 "Position cursor of Previous designates wrong list";
1214 end if;
1215
1216 return Previous (Position);
1217 end Previous;
1218
1219 ----------------------
1220 -- Pseudo_Reference --
1221 ----------------------
1222
1223 function Pseudo_Reference
1224 (Container : aliased List'Class) return Reference_Control_Type
1225 is
1226 TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
1227 begin
1228 return R : constant Reference_Control_Type := (Controlled with TC) do
1229 Lock (TC.all);
1230 end return;
1231 end Pseudo_Reference;
1232
1233 -------------------
1234 -- Query_Element --
1235 -------------------
1236
1237 procedure Query_Element
1238 (Position : Cursor;
1239 Process : not null access procedure (Element : Element_Type))
1240 is
1241 begin
1242 if Checks and then Position.Node = null then
1243 raise Constraint_Error with
1244 "Position cursor has no element";
1245 end if;
1246
1247 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1248
1249 declare
1250 Lock : With_Lock (Position.Container.TC'Unrestricted_Access);
1251 begin
1252 Process (Position.Node.Element);
1253 end;
1254 end Query_Element;
1255
1256 ----------
1257 -- Read --
1258 ----------
1259
1260 procedure Read
1261 (Stream : not null access Root_Stream_Type'Class;
1262 Item : out List)
1263 is
1264 N : Count_Type'Base;
1265 X : Node_Access;
1266
1267 begin
1268 Clear (Item);
1269 Count_Type'Base'Read (Stream, N);
1270
1271 if N = 0 then
1272 return;
1273 end if;
1274
1275 X := new Node_Type;
1276
1277 begin
1278 Element_Type'Read (Stream, X.Element);
1279 exception
1280 when others =>
1281 Free (X);
1282 raise;
1283 end;
1284
1285 Item.First := X;
1286 Item.Last := X;
1287
1288 loop
1289 Item.Length := Item.Length + 1;
1290 exit when Item.Length = N;
1291
1292 X := new Node_Type;
1293
1294 begin
1295 Element_Type'Read (Stream, X.Element);
1296 exception
1297 when others =>
1298 Free (X);
1299 raise;
1300 end;
1301
1302 X.Prev := Item.Last;
1303 Item.Last.Next := X;
1304 Item.Last := X;
1305 end loop;
1306 end Read;
1307
1308 procedure Read
1309 (Stream : not null access Root_Stream_Type'Class;
1310 Item : out Cursor)
1311 is
1312 begin
1313 raise Program_Error with "attempt to stream list cursor";
1314 end Read;
1315
1316 procedure Read
1317 (Stream : not null access Root_Stream_Type'Class;
1318 Item : out Reference_Type)
1319 is
1320 begin
1321 raise Program_Error with "attempt to stream reference";
1322 end Read;
1323
1324 procedure Read
1325 (Stream : not null access Root_Stream_Type'Class;
1326 Item : out Constant_Reference_Type)
1327 is
1328 begin
1329 raise Program_Error with "attempt to stream reference";
1330 end Read;
1331
1332 ---------------
1333 -- Reference --
1334 ---------------
1335
1336 function Reference
1337 (Container : aliased in out List;
1338 Position : Cursor) return Reference_Type
1339 is
1340 begin
1341 if Checks and then Position.Container = null then
1342 raise Constraint_Error with "Position cursor has no element";
1343 end if;
1344
1345 if Checks and then Position.Container /= Container'Unchecked_Access then
1346 raise Program_Error with
1347 "Position cursor designates wrong container";
1348 end if;
1349
1350 pragma Assert (Vet (Position), "bad cursor in function Reference");
1351
1352 declare
1353 TC : constant Tamper_Counts_Access :=
1354 Container.TC'Unrestricted_Access;
1355 begin
1356 return R : constant Reference_Type :=
1357 (Element => Position.Node.Element'Access,
1358 Control => (Controlled with TC))
1359 do
1360 Lock (TC.all);
1361 end return;
1362 end;
1363 end Reference;
1364
1365 ---------------------
1366 -- Replace_Element --
1367 ---------------------
1368
1369 procedure Replace_Element
1370 (Container : in out List;
1371 Position : Cursor;
1372 New_Item : Element_Type)
1373 is
1374 begin
1375 if Checks and then Position.Container = null then
1376 raise Constraint_Error with "Position cursor has no element";
1377 end if;
1378
1379 if Checks and then Position.Container /= Container'Unchecked_Access then
1380 raise Program_Error with
1381 "Position cursor designates wrong container";
1382 end if;
1383
1384 TE_Check (Container.TC);
1385
1386 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1387
1388 Position.Node.Element := New_Item;
1389 end Replace_Element;
1390
1391 ----------------------
1392 -- Reverse_Elements --
1393 ----------------------
1394
1395 procedure Reverse_Elements (Container : in out List) is
1396 I : Node_Access := Container.First;
1397 J : Node_Access := Container.Last;
1398
1399 procedure Swap (L, R : Node_Access);
1400
1401 ----------
1402 -- Swap --
1403 ----------
1404
1405 procedure Swap (L, R : Node_Access) is
1406 LN : constant Node_Access := L.Next;
1407 LP : constant Node_Access := L.Prev;
1408
1409 RN : constant Node_Access := R.Next;
1410 RP : constant Node_Access := R.Prev;
1411
1412 begin
1413 if LP /= null then
1414 LP.Next := R;
1415 end if;
1416
1417 if RN /= null then
1418 RN.Prev := L;
1419 end if;
1420
1421 L.Next := RN;
1422 R.Prev := LP;
1423
1424 if LN = R then
1425 pragma Assert (RP = L);
1426
1427 L.Prev := R;
1428 R.Next := L;
1429
1430 else
1431 L.Prev := RP;
1432 RP.Next := L;
1433
1434 R.Next := LN;
1435 LN.Prev := R;
1436 end if;
1437 end Swap;
1438
1439 -- Start of processing for Reverse_Elements
1440
1441 begin
1442 if Container.Length <= 1 then
1443 return;
1444 end if;
1445
1446 pragma Assert (Container.First.Prev = null);
1447 pragma Assert (Container.Last.Next = null);
1448
1449 TC_Check (Container.TC);
1450
1451 Container.First := J;
1452 Container.Last := I;
1453 loop
1454 Swap (L => I, R => J);
1455
1456 J := J.Next;
1457 exit when I = J;
1458
1459 I := I.Prev;
1460 exit when I = J;
1461
1462 Swap (L => J, R => I);
1463
1464 I := I.Next;
1465 exit when I = J;
1466
1467 J := J.Prev;
1468 exit when I = J;
1469 end loop;
1470
1471 pragma Assert (Container.First.Prev = null);
1472 pragma Assert (Container.Last.Next = null);
1473 end Reverse_Elements;
1474
1475 ------------------
1476 -- Reverse_Find --
1477 ------------------
1478
1479 function Reverse_Find
1480 (Container : List;
1481 Item : Element_Type;
1482 Position : Cursor := No_Element) return Cursor
1483 is
1484 Node : Node_Access := Position.Node;
1485
1486 begin
1487 if Node = null then
1488 Node := Container.Last;
1489
1490 else
1491 if Checks and then Position.Container /= Container'Unrestricted_Access
1492 then
1493 raise Program_Error with
1494 "Position cursor designates wrong container";
1495 end if;
1496
1497 pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1498 end if;
1499
1500 -- Per AI05-0022, the container implementation is required to detect
1501 -- element tampering by a generic actual subprogram.
1502
1503 declare
1504 Lock : With_Lock (Container.TC'Unrestricted_Access);
1505 begin
1506 while Node /= null loop
1507 if Node.Element = Item then
1508 return Cursor'(Container'Unrestricted_Access, Node);
1509 end if;
1510
1511 Node := Node.Prev;
1512 end loop;
1513
1514 return No_Element;
1515 end;
1516 end Reverse_Find;
1517
1518 ---------------------
1519 -- Reverse_Iterate --
1520 ---------------------
1521
1522 procedure Reverse_Iterate
1523 (Container : List;
1524 Process : not null access procedure (Position : Cursor))
1525 is
1526 Busy : With_Busy (Container.TC'Unrestricted_Access);
1527 Node : Node_Access := Container.Last;
1528
1529 begin
1530 while Node /= null loop
1531 Process (Cursor'(Container'Unrestricted_Access, Node));
1532 Node := Node.Prev;
1533 end loop;
1534 end Reverse_Iterate;
1535
1536 ------------
1537 -- Splice --
1538 ------------
1539
1540 procedure Splice
1541 (Target : in out List;
1542 Before : Cursor;
1543 Source : in out List)
1544 is
1545 begin
1546 if Before.Container /= null then
1547 if Checks and then Before.Container /= Target'Unrestricted_Access then
1548 raise Program_Error with
1549 "Before cursor designates wrong container";
1550 end if;
1551
1552 pragma Assert (Vet (Before), "bad cursor in Splice");
1553 end if;
1554
1555 if Target'Address = Source'Address or else Source.Length = 0 then
1556 return;
1557 end if;
1558
1559 if Checks and then Target.Length > Count_Type'Last - Source.Length then
1560 raise Constraint_Error with "new length exceeds maximum";
1561 end if;
1562
1563 TC_Check (Target.TC);
1564 TC_Check (Source.TC);
1565
1566 Splice_Internal (Target, Before.Node, Source);
1567 end Splice;
1568
1569 procedure Splice
1570 (Container : in out List;
1571 Before : Cursor;
1572 Position : Cursor)
1573 is
1574 begin
1575 if Before.Container /= null then
1576 if Checks and then Before.Container /= Container'Unchecked_Access then
1577 raise Program_Error with
1578 "Before cursor designates wrong container";
1579 end if;
1580
1581 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1582 end if;
1583
1584 if Checks and then Position.Node = null then
1585 raise Constraint_Error with "Position cursor has no element";
1586 end if;
1587
1588 if Checks and then Position.Container /= Container'Unrestricted_Access
1589 then
1590 raise Program_Error with
1591 "Position cursor designates wrong container";
1592 end if;
1593
1594 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1595
1596 if Position.Node = Before.Node
1597 or else Position.Node.Next = Before.Node
1598 then
1599 return;
1600 end if;
1601
1602 pragma Assert (Container.Length >= 2);
1603
1604 TC_Check (Container.TC);
1605
1606 if Before.Node = null then
1607 pragma Assert (Position.Node /= Container.Last);
1608
1609 if Position.Node = Container.First then
1610 Container.First := Position.Node.Next;
1611 Container.First.Prev := null;
1612 else
1613 Position.Node.Prev.Next := Position.Node.Next;
1614 Position.Node.Next.Prev := Position.Node.Prev;
1615 end if;
1616
1617 Container.Last.Next := Position.Node;
1618 Position.Node.Prev := Container.Last;
1619
1620 Container.Last := Position.Node;
1621 Container.Last.Next := null;
1622
1623 return;
1624 end if;
1625
1626 if Before.Node = Container.First then
1627 pragma Assert (Position.Node /= Container.First);
1628
1629 if Position.Node = Container.Last then
1630 Container.Last := Position.Node.Prev;
1631 Container.Last.Next := null;
1632 else
1633 Position.Node.Prev.Next := Position.Node.Next;
1634 Position.Node.Next.Prev := Position.Node.Prev;
1635 end if;
1636
1637 Container.First.Prev := Position.Node;
1638 Position.Node.Next := Container.First;
1639
1640 Container.First := Position.Node;
1641 Container.First.Prev := null;
1642
1643 return;
1644 end if;
1645
1646 if Position.Node = Container.First then
1647 Container.First := Position.Node.Next;
1648 Container.First.Prev := null;
1649
1650 elsif Position.Node = Container.Last then
1651 Container.Last := Position.Node.Prev;
1652 Container.Last.Next := null;
1653
1654 else
1655 Position.Node.Prev.Next := Position.Node.Next;
1656 Position.Node.Next.Prev := Position.Node.Prev;
1657 end if;
1658
1659 Before.Node.Prev.Next := Position.Node;
1660 Position.Node.Prev := Before.Node.Prev;
1661
1662 Before.Node.Prev := Position.Node;
1663 Position.Node.Next := Before.Node;
1664
1665 pragma Assert (Container.First.Prev = null);
1666 pragma Assert (Container.Last.Next = null);
1667 end Splice;
1668
1669 procedure Splice
1670 (Target : in out List;
1671 Before : Cursor;
1672 Source : in out List;
1673 Position : in out Cursor)
1674 is
1675 begin
1676 if Target'Address = Source'Address then
1677 Splice (Target, Before, Position);
1678 return;
1679 end if;
1680
1681 if Before.Container /= null then
1682 if Checks and then Before.Container /= Target'Unrestricted_Access then
1683 raise Program_Error with
1684 "Before cursor designates wrong container";
1685 end if;
1686
1687 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1688 end if;
1689
1690 if Checks and then Position.Node = null then
1691 raise Constraint_Error with "Position cursor has no element";
1692 end if;
1693
1694 if Checks and then Position.Container /= Source'Unrestricted_Access then
1695 raise Program_Error with
1696 "Position cursor designates wrong container";
1697 end if;
1698
1699 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1700
1701 if Checks and then Target.Length = Count_Type'Last then
1702 raise Constraint_Error with "Target is full";
1703 end if;
1704
1705 TC_Check (Target.TC);
1706 TC_Check (Source.TC);
1707
1708 Splice_Internal (Target, Before.Node, Source, Position.Node);
1709 Position.Container := Target'Unchecked_Access;
1710 end Splice;
1711
1712 ---------------------
1713 -- Splice_Internal --
1714 ---------------------
1715
1716 procedure Splice_Internal
1717 (Target : in out List;
1718 Before : Node_Access;
1719 Source : in out List)
1720 is
1721 begin
1722 -- This implements the corresponding Splice operation, after the
1723 -- parameters have been vetted, and corner-cases disposed of.
1724
1725 pragma Assert (Target'Address /= Source'Address);
1726 pragma Assert (Source.Length > 0);
1727 pragma Assert (Source.First /= null);
1728 pragma Assert (Source.First.Prev = null);
1729 pragma Assert (Source.Last /= null);
1730 pragma Assert (Source.Last.Next = null);
1731 pragma Assert (Target.Length <= Count_Type'Last - Source.Length);
1732
1733 if Target.Length = 0 then
1734 pragma Assert (Target.First = null);
1735 pragma Assert (Target.Last = null);
1736 pragma Assert (Before = null);
1737
1738 Target.First := Source.First;
1739 Target.Last := Source.Last;
1740
1741 elsif Before = null then
1742 pragma Assert (Target.Last.Next = null);
1743
1744 Target.Last.Next := Source.First;
1745 Source.First.Prev := Target.Last;
1746
1747 Target.Last := Source.Last;
1748
1749 elsif Before = Target.First then
1750 pragma Assert (Target.First.Prev = null);
1751
1752 Source.Last.Next := Target.First;
1753 Target.First.Prev := Source.Last;
1754
1755 Target.First := Source.First;
1756
1757 else
1758 pragma Assert (Target.Length >= 2);
1759
1760 Before.Prev.Next := Source.First;
1761 Source.First.Prev := Before.Prev;
1762
1763 Before.Prev := Source.Last;
1764 Source.Last.Next := Before;
1765 end if;
1766
1767 Source.First := null;
1768 Source.Last := null;
1769
1770 Target.Length := Target.Length + Source.Length;
1771 Source.Length := 0;
1772 end Splice_Internal;
1773
1774 procedure Splice_Internal
1775 (Target : in out List;
1776 Before : Node_Access; -- node of Target
1777 Source : in out List;
1778 Position : Node_Access) -- node of Source
1779 is
1780 begin
1781 -- This implements the corresponding Splice operation, after the
1782 -- parameters have been vetted.
1783
1784 pragma Assert (Target'Address /= Source'Address);
1785 pragma Assert (Target.Length < Count_Type'Last);
1786 pragma Assert (Source.Length > 0);
1787 pragma Assert (Source.First /= null);
1788 pragma Assert (Source.First.Prev = null);
1789 pragma Assert (Source.Last /= null);
1790 pragma Assert (Source.Last.Next = null);
1791 pragma Assert (Position /= null);
1792
1793 if Position = Source.First then
1794 Source.First := Position.Next;
1795
1796 if Position = Source.Last then
1797 pragma Assert (Source.First = null);
1798 pragma Assert (Source.Length = 1);
1799 Source.Last := null;
1800
1801 else
1802 Source.First.Prev := null;
1803 end if;
1804
1805 elsif Position = Source.Last then
1806 pragma Assert (Source.Length >= 2);
1807 Source.Last := Position.Prev;
1808 Source.Last.Next := null;
1809
1810 else
1811 pragma Assert (Source.Length >= 3);
1812 Position.Prev.Next := Position.Next;
1813 Position.Next.Prev := Position.Prev;
1814 end if;
1815
1816 if Target.Length = 0 then
1817 pragma Assert (Target.First = null);
1818 pragma Assert (Target.Last = null);
1819 pragma Assert (Before = null);
1820
1821 Target.First := Position;
1822 Target.Last := Position;
1823
1824 Target.First.Prev := null;
1825 Target.Last.Next := null;
1826
1827 elsif Before = null then
1828 pragma Assert (Target.Last.Next = null);
1829 Target.Last.Next := Position;
1830 Position.Prev := Target.Last;
1831
1832 Target.Last := Position;
1833 Target.Last.Next := null;
1834
1835 elsif Before = Target.First then
1836 pragma Assert (Target.First.Prev = null);
1837 Target.First.Prev := Position;
1838 Position.Next := Target.First;
1839
1840 Target.First := Position;
1841 Target.First.Prev := null;
1842
1843 else
1844 pragma Assert (Target.Length >= 2);
1845 Before.Prev.Next := Position;
1846 Position.Prev := Before.Prev;
1847
1848 Before.Prev := Position;
1849 Position.Next := Before;
1850 end if;
1851
1852 Target.Length := Target.Length + 1;
1853 Source.Length := Source.Length - 1;
1854 end Splice_Internal;
1855
1856 ----------
1857 -- Swap --
1858 ----------
1859
1860 procedure Swap
1861 (Container : in out List;
1862 I, J : Cursor)
1863 is
1864 begin
1865 if Checks and then I.Node = null then
1866 raise Constraint_Error with "I cursor has no element";
1867 end if;
1868
1869 if Checks and then J.Node = null then
1870 raise Constraint_Error with "J cursor has no element";
1871 end if;
1872
1873 if Checks and then I.Container /= Container'Unchecked_Access then
1874 raise Program_Error with "I cursor designates wrong container";
1875 end if;
1876
1877 if Checks and then J.Container /= Container'Unchecked_Access then
1878 raise Program_Error with "J cursor designates wrong container";
1879 end if;
1880
1881 if I.Node = J.Node then
1882 return;
1883 end if;
1884
1885 TE_Check (Container.TC);
1886
1887 pragma Assert (Vet (I), "bad I cursor in Swap");
1888 pragma Assert (Vet (J), "bad J cursor in Swap");
1889
1890 declare
1891 EI : Element_Type renames I.Node.Element;
1892 EJ : Element_Type renames J.Node.Element;
1893
1894 EI_Copy : constant Element_Type := EI;
1895
1896 begin
1897 EI := EJ;
1898 EJ := EI_Copy;
1899 end;
1900 end Swap;
1901
1902 ----------------
1903 -- Swap_Links --
1904 ----------------
1905
1906 procedure Swap_Links
1907 (Container : in out List;
1908 I, J : Cursor)
1909 is
1910 begin
1911 if Checks and then I.Node = null then
1912 raise Constraint_Error with "I cursor has no element";
1913 end if;
1914
1915 if Checks and then J.Node = null then
1916 raise Constraint_Error with "J cursor has no element";
1917 end if;
1918
1919 if Checks and then I.Container /= Container'Unrestricted_Access then
1920 raise Program_Error with "I cursor designates wrong container";
1921 end if;
1922
1923 if Checks and then J.Container /= Container'Unrestricted_Access then
1924 raise Program_Error with "J cursor designates wrong container";
1925 end if;
1926
1927 if I.Node = J.Node then
1928 return;
1929 end if;
1930
1931 TC_Check (Container.TC);
1932
1933 pragma Assert (Vet (I), "bad I cursor in Swap_Links");
1934 pragma Assert (Vet (J), "bad J cursor in Swap_Links");
1935
1936 declare
1937 I_Next : constant Cursor := Next (I);
1938
1939 begin
1940 if I_Next = J then
1941 Splice (Container, Before => I, Position => J);
1942
1943 else
1944 declare
1945 J_Next : constant Cursor := Next (J);
1946
1947 begin
1948 if J_Next = I then
1949 Splice (Container, Before => J, Position => I);
1950
1951 else
1952 pragma Assert (Container.Length >= 3);
1953
1954 Splice (Container, Before => I_Next, Position => J);
1955 Splice (Container, Before => J_Next, Position => I);
1956 end if;
1957 end;
1958 end if;
1959 end;
1960 end Swap_Links;
1961
1962 --------------------
1963 -- Update_Element --
1964 --------------------
1965
1966 procedure Update_Element
1967 (Container : in out List;
1968 Position : Cursor;
1969 Process : not null access procedure (Element : in out Element_Type))
1970 is
1971 begin
1972 if Checks and then Position.Node = null then
1973 raise Constraint_Error with "Position cursor has no element";
1974 end if;
1975
1976 if Checks and then Position.Container /= Container'Unchecked_Access then
1977 raise Program_Error with
1978 "Position cursor designates wrong container";
1979 end if;
1980
1981 pragma Assert (Vet (Position), "bad cursor in Update_Element");
1982
1983 declare
1984 Lock : With_Lock (Container.TC'Unchecked_Access);
1985 begin
1986 Process (Position.Node.Element);
1987 end;
1988 end Update_Element;
1989
1990 ---------
1991 -- Vet --
1992 ---------
1993
1994 function Vet (Position : Cursor) return Boolean is
1995 begin
1996 if Position.Node = null then
1997 return Position.Container = null;
1998 end if;
1999
2000 if Position.Container = null then
2001 return False;
2002 end if;
2003
2004 -- An invariant of a node is that its Previous and Next components can
2005 -- be null, or designate a different node. Operation Free sets the
2006 -- access value components of the node to designate the node itself
2007 -- before actually deallocating the node, thus deliberately violating
2008 -- the node invariant. This gives us a simple way to detect a dangling
2009 -- reference to a node.
2010
2011 if Position.Node.Next = Position.Node then
2012 return False;
2013 end if;
2014
2015 if Position.Node.Prev = Position.Node then
2016 return False;
2017 end if;
2018
2019 -- In practice the tests above will detect most instances of a dangling
2020 -- reference. If we get here, it means that the invariants of the
2021 -- designated node are satisfied (they at least appear to be satisfied),
2022 -- so we perform some more tests, to determine whether invariants of the
2023 -- designated list are satisfied too.
2024
2025 declare
2026 L : List renames Position.Container.all;
2027
2028 begin
2029 if L.Length = 0 then
2030 return False;
2031 end if;
2032
2033 if L.First = null then
2034 return False;
2035 end if;
2036
2037 if L.Last = null then
2038 return False;
2039 end if;
2040
2041 if L.First.Prev /= null then
2042 return False;
2043 end if;
2044
2045 if L.Last.Next /= null then
2046 return False;
2047 end if;
2048
2049 if Position.Node.Prev = null and then Position.Node /= L.First then
2050 return False;
2051 end if;
2052
2053 pragma Assert
2054 (Position.Node.Prev /= null or else Position.Node = L.First);
2055
2056 if Position.Node.Next = null and then Position.Node /= L.Last then
2057 return False;
2058 end if;
2059
2060 pragma Assert
2061 (Position.Node.Next /= null
2062 or else Position.Node = L.Last);
2063
2064 if L.Length = 1 then
2065 return L.First = L.Last;
2066 end if;
2067
2068 if L.First = L.Last then
2069 return False;
2070 end if;
2071
2072 if L.First.Next = null then
2073 return False;
2074 end if;
2075
2076 if L.Last.Prev = null then
2077 return False;
2078 end if;
2079
2080 if L.First.Next.Prev /= L.First then
2081 return False;
2082 end if;
2083
2084 if L.Last.Prev.Next /= L.Last then
2085 return False;
2086 end if;
2087
2088 if L.Length = 2 then
2089 if L.First.Next /= L.Last then
2090 return False;
2091 elsif L.Last.Prev /= L.First then
2092 return False;
2093 else
2094 return True;
2095 end if;
2096 end if;
2097
2098 if L.First.Next = L.Last then
2099 return False;
2100 end if;
2101
2102 if L.Last.Prev = L.First then
2103 return False;
2104 end if;
2105
2106 -- Eliminate earlier possibility
2107
2108 if Position.Node = L.First then
2109 return True;
2110 end if;
2111
2112 pragma Assert (Position.Node.Prev /= null);
2113
2114 -- Eliminate earlier possibility
2115
2116 if Position.Node = L.Last then
2117 return True;
2118 end if;
2119
2120 pragma Assert (Position.Node.Next /= null);
2121
2122 if Position.Node.Next.Prev /= Position.Node then
2123 return False;
2124 end if;
2125
2126 if Position.Node.Prev.Next /= Position.Node then
2127 return False;
2128 end if;
2129
2130 if L.Length = 3 then
2131 if L.First.Next /= Position.Node then
2132 return False;
2133 elsif L.Last.Prev /= Position.Node then
2134 return False;
2135 end if;
2136 end if;
2137
2138 return True;
2139 end;
2140 end Vet;
2141
2142 -----------
2143 -- Write --
2144 -----------
2145
2146 procedure Write
2147 (Stream : not null access Root_Stream_Type'Class;
2148 Item : List)
2149 is
2150 Node : Node_Access;
2151
2152 begin
2153 Count_Type'Base'Write (Stream, Item.Length);
2154
2155 Node := Item.First;
2156 while Node /= null loop
2157 Element_Type'Write (Stream, Node.Element);
2158 Node := Node.Next;
2159 end loop;
2160 end Write;
2161
2162 procedure Write
2163 (Stream : not null access Root_Stream_Type'Class;
2164 Item : Cursor)
2165 is
2166 begin
2167 raise Program_Error with "attempt to stream list cursor";
2168 end Write;
2169
2170 procedure Write
2171 (Stream : not null access Root_Stream_Type'Class;
2172 Item : Reference_Type)
2173 is
2174 begin
2175 raise Program_Error with "attempt to stream reference";
2176 end Write;
2177
2178 procedure Write
2179 (Stream : not null access Root_Stream_Type'Class;
2180 Item : Constant_Reference_Type)
2181 is
2182 begin
2183 raise Program_Error with "attempt to stream reference";
2184 end Write;
2185
2186 end Ada.Containers.Doubly_Linked_Lists;