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