Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / a-cidlli.adb
blob04d0597a22c50b537b0d288f4447549204e2fb01
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-2013, 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 ------------------------------------------------------------------------------
30 with Ada.Unchecked_Deallocation;
32 with System; use type System.Address;
34 package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
36 procedure Free is
37 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
39 -----------------------
40 -- Local Subprograms --
41 -----------------------
43 procedure Free (X : in out Node_Access);
45 procedure Insert_Internal
46 (Container : in out List;
47 Before : Node_Access;
48 New_Node : Node_Access);
50 procedure Splice_Internal
51 (Target : in out List;
52 Before : Node_Access;
53 Source : in out List);
55 procedure Splice_Internal
56 (Target : in out List;
57 Before : Node_Access;
58 Source : in out List;
59 Position : Node_Access);
61 function Vet (Position : Cursor) return Boolean;
62 -- Checks invariants of the cursor and its designated container, as a
63 -- simple way of detecting dangling references (see operation Free for a
64 -- description of the detection mechanism), returning True if all checks
65 -- pass. Invocations of Vet are used here as the argument of pragma Assert,
66 -- so the checks are performed only when assertions are enabled.
68 ---------
69 -- "=" --
70 ---------
72 function "=" (Left, Right : List) return Boolean is
73 BL : Natural renames Left'Unrestricted_Access.Busy;
74 LL : Natural renames Left'Unrestricted_Access.Lock;
76 BR : Natural renames Right'Unrestricted_Access.Busy;
77 LR : Natural renames Right'Unrestricted_Access.Lock;
79 L : Node_Access;
80 R : Node_Access;
81 Result : Boolean;
83 begin
84 if Left'Address = Right'Address then
85 return True;
86 end if;
88 if Left.Length /= Right.Length then
89 return False;
90 end if;
92 -- Per AI05-0022, the container implementation is required to detect
93 -- element tampering by a generic actual subprogram.
95 BL := BL + 1;
96 LL := LL + 1;
98 BR := BR + 1;
99 LR := LR + 1;
101 L := Left.First;
102 R := Right.First;
103 Result := True;
104 for J in 1 .. Left.Length loop
105 if L.Element.all /= R.Element.all then
106 Result := False;
107 exit;
108 end if;
110 L := L.Next;
111 R := R.Next;
112 end loop;
114 BL := BL - 1;
115 LL := LL - 1;
117 BR := BR - 1;
118 LR := LR - 1;
120 return Result;
122 exception
123 when others =>
124 BL := BL - 1;
125 LL := LL - 1;
127 BR := BR - 1;
128 LR := LR - 1;
130 raise;
131 end "=";
133 ------------
134 -- Adjust --
135 ------------
137 procedure Adjust (Container : in out List) is
138 Src : Node_Access := Container.First;
139 Dst : Node_Access;
141 begin
142 if Src = null then
143 pragma Assert (Container.Last = null);
144 pragma Assert (Container.Length = 0);
145 pragma Assert (Container.Busy = 0);
146 pragma Assert (Container.Lock = 0);
147 return;
148 end if;
150 pragma Assert (Container.First.Prev = null);
151 pragma Assert (Container.Last.Next = null);
152 pragma Assert (Container.Length > 0);
154 Container.First := null;
155 Container.Last := null;
156 Container.Length := 0;
157 Container.Busy := 0;
158 Container.Lock := 0;
160 declare
161 Element : Element_Access := new Element_Type'(Src.Element.all);
162 begin
163 Dst := new Node_Type'(Element, null, null);
164 exception
165 when others =>
166 Free (Element);
167 raise;
168 end;
170 Container.First := Dst;
171 Container.Last := Dst;
172 Container.Length := 1;
174 Src := Src.Next;
175 while Src /= null loop
176 declare
177 Element : Element_Access := new Element_Type'(Src.Element.all);
178 begin
179 Dst := new Node_Type'(Element, null, Prev => Container.Last);
180 exception
181 when others =>
182 Free (Element);
183 raise;
184 end;
186 Container.Last.Next := Dst;
187 Container.Last := Dst;
188 Container.Length := Container.Length + 1;
190 Src := Src.Next;
191 end loop;
192 end Adjust;
194 procedure Adjust (Control : in out Reference_Control_Type) is
195 begin
196 if Control.Container /= null then
197 declare
198 C : List renames Control.Container.all;
199 B : Natural renames C.Busy;
200 L : Natural renames C.Lock;
201 begin
202 B := B + 1;
203 L := L + 1;
204 end;
205 end if;
206 end Adjust;
208 ------------
209 -- Append --
210 ------------
212 procedure Append
213 (Container : in out List;
214 New_Item : Element_Type;
215 Count : Count_Type := 1)
217 begin
218 Insert (Container, No_Element, New_Item, Count);
219 end Append;
221 ------------
222 -- Assign --
223 ------------
225 procedure Assign (Target : in out List; Source : List) is
226 Node : Node_Access;
228 begin
229 if Target'Address = Source'Address then
230 return;
232 else
233 Target.Clear;
235 Node := Source.First;
236 while Node /= null loop
237 Target.Append (Node.Element.all);
238 Node := Node.Next;
239 end loop;
240 end if;
241 end Assign;
243 -----------
244 -- Clear --
245 -----------
247 procedure Clear (Container : in out List) is
248 X : Node_Access;
249 pragma Warnings (Off, X);
251 begin
252 if Container.Length = 0 then
253 pragma Assert (Container.First = null);
254 pragma Assert (Container.Last = null);
255 pragma Assert (Container.Busy = 0);
256 pragma Assert (Container.Lock = 0);
257 return;
258 end if;
260 pragma Assert (Container.First.Prev = null);
261 pragma Assert (Container.Last.Next = null);
263 if Container.Busy > 0 then
264 raise Program_Error with
265 "attempt to tamper with cursors (list is busy)";
266 end if;
268 while Container.Length > 1 loop
269 X := Container.First;
270 pragma Assert (X.Next.Prev = Container.First);
272 Container.First := X.Next;
273 Container.First.Prev := null;
275 Container.Length := Container.Length - 1;
277 Free (X);
278 end loop;
280 X := Container.First;
281 pragma Assert (X = Container.Last);
283 Container.First := null;
284 Container.Last := null;
285 Container.Length := 0;
287 Free (X);
288 end Clear;
290 ------------------------
291 -- Constant_Reference --
292 ------------------------
294 function Constant_Reference
295 (Container : aliased List;
296 Position : Cursor) return Constant_Reference_Type
298 begin
299 if Position.Container = null then
300 raise Constraint_Error with "Position cursor has no element";
302 elsif Position.Container /= Container'Unrestricted_Access then
303 raise Program_Error with
304 "Position cursor designates wrong container";
305 elsif Position.Node.Element = null then
306 raise Program_Error with "Node has no element";
308 else
309 pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
311 declare
312 C : List renames Position.Container.all;
313 B : Natural renames C.Busy;
314 L : Natural renames C.Lock;
315 begin
316 return R : constant Constant_Reference_Type :=
317 (Element => Position.Node.Element.all'Access,
318 Control => (Controlled with Position.Container))
320 B := B + 1;
321 L := L + 1;
322 end return;
323 end;
324 end if;
325 end Constant_Reference;
327 --------------
328 -- Contains --
329 --------------
331 function Contains
332 (Container : List;
333 Item : Element_Type) return Boolean
335 begin
336 return Find (Container, Item) /= No_Element;
337 end Contains;
339 ----------
340 -- Copy --
341 ----------
343 function Copy (Source : List) return List is
344 begin
345 return Target : List do
346 Target.Assign (Source);
347 end return;
348 end Copy;
350 ------------
351 -- Delete --
352 ------------
354 procedure Delete
355 (Container : in out List;
356 Position : in out Cursor;
357 Count : Count_Type := 1)
359 X : Node_Access;
361 begin
362 if Position.Node = null then
363 raise Constraint_Error with
364 "Position cursor has no element";
365 end if;
367 if Position.Node.Element = null then
368 raise Program_Error with
369 "Position cursor has no element";
370 end if;
372 if Position.Container /= Container'Unrestricted_Access then
373 raise Program_Error with
374 "Position cursor designates wrong container";
375 end if;
377 pragma Assert (Vet (Position), "bad cursor in Delete");
379 if Position.Node = Container.First then
380 Delete_First (Container, Count);
381 Position := No_Element; -- Post-York behavior
382 return;
383 end if;
385 if Count = 0 then
386 Position := No_Element; -- Post-York behavior
387 return;
388 end if;
390 if Container.Busy > 0 then
391 raise Program_Error with
392 "attempt to tamper with cursors (list is busy)";
393 end if;
395 for Index in 1 .. Count loop
396 X := Position.Node;
397 Container.Length := Container.Length - 1;
399 if X = Container.Last then
400 Position := No_Element;
402 Container.Last := X.Prev;
403 Container.Last.Next := null;
405 Free (X);
406 return;
407 end if;
409 Position.Node := X.Next;
411 X.Next.Prev := X.Prev;
412 X.Prev.Next := X.Next;
414 Free (X);
415 end loop;
417 -- Fix this junk comment ???
419 Position := No_Element; -- Post-York behavior
420 end Delete;
422 ------------------
423 -- Delete_First --
424 ------------------
426 procedure Delete_First
427 (Container : in out List;
428 Count : Count_Type := 1)
430 X : Node_Access;
432 begin
433 if Count >= Container.Length then
434 Clear (Container);
435 return;
437 elsif Count = 0 then
438 return;
440 elsif Container.Busy > 0 then
441 raise Program_Error with
442 "attempt to tamper with cursors (list is busy)";
444 else
445 for J in 1 .. Count loop
446 X := Container.First;
447 pragma Assert (X.Next.Prev = Container.First);
449 Container.First := X.Next;
450 Container.First.Prev := null;
452 Container.Length := Container.Length - 1;
454 Free (X);
455 end loop;
456 end if;
457 end Delete_First;
459 -----------------
460 -- Delete_Last --
461 -----------------
463 procedure Delete_Last
464 (Container : in out List;
465 Count : Count_Type := 1)
467 X : Node_Access;
469 begin
470 if Count >= Container.Length then
471 Clear (Container);
472 return;
474 elsif Count = 0 then
475 return;
477 elsif Container.Busy > 0 then
478 raise Program_Error with
479 "attempt to tamper with cursors (list is busy)";
481 else
482 for J in 1 .. Count loop
483 X := Container.Last;
484 pragma Assert (X.Prev.Next = Container.Last);
486 Container.Last := X.Prev;
487 Container.Last.Next := null;
489 Container.Length := Container.Length - 1;
491 Free (X);
492 end loop;
493 end if;
494 end Delete_Last;
496 -------------
497 -- Element --
498 -------------
500 function Element (Position : Cursor) return Element_Type is
501 begin
502 if Position.Node = null then
503 raise Constraint_Error with
504 "Position cursor has no element";
506 elsif Position.Node.Element = null then
507 raise Program_Error with
508 "Position cursor has no element";
510 else
511 pragma Assert (Vet (Position), "bad cursor in Element");
513 return Position.Node.Element.all;
514 end if;
515 end Element;
517 --------------
518 -- Finalize --
519 --------------
521 procedure Finalize (Object : in out Iterator) is
522 begin
523 if Object.Container /= null then
524 declare
525 B : Natural renames Object.Container.all.Busy;
526 begin
527 B := B - 1;
528 end;
529 end if;
530 end Finalize;
532 procedure Finalize (Control : in out Reference_Control_Type) is
533 begin
534 if Control.Container /= null then
535 declare
536 C : List renames Control.Container.all;
537 B : Natural renames C.Busy;
538 L : Natural renames C.Lock;
539 begin
540 B := B - 1;
541 L := L - 1;
542 end;
544 Control.Container := null;
545 end if;
546 end Finalize;
548 ----------
549 -- Find --
550 ----------
552 function Find
553 (Container : List;
554 Item : Element_Type;
555 Position : Cursor := No_Element) return Cursor
557 Node : Node_Access := Position.Node;
559 begin
560 if Node = null then
561 Node := Container.First;
563 else
564 if Node.Element = null then
565 raise Program_Error;
567 elsif Position.Container /= Container'Unrestricted_Access then
568 raise Program_Error with
569 "Position cursor designates wrong container";
571 else
572 pragma Assert (Vet (Position), "bad cursor in Find");
573 end if;
574 end if;
576 -- Per AI05-0022, the container implementation is required to detect
577 -- element tampering by a generic actual subprogram.
579 declare
580 B : Natural renames Container'Unrestricted_Access.Busy;
581 L : Natural renames Container'Unrestricted_Access.Lock;
583 Result : Node_Access;
585 begin
586 B := B + 1;
587 L := L + 1;
589 Result := null;
590 while Node /= null loop
591 if Node.Element.all = Item then
592 Result := Node;
593 exit;
594 end if;
596 Node := Node.Next;
597 end loop;
599 B := B - 1;
600 L := L - 1;
602 if Result = null then
603 return No_Element;
604 else
605 return Cursor'(Container'Unrestricted_Access, Result);
606 end if;
608 exception
609 when others =>
610 B := B - 1;
611 L := L - 1;
612 raise;
613 end;
614 end Find;
616 -----------
617 -- First --
618 -----------
620 function First (Container : List) return Cursor is
621 begin
622 if Container.First = null then
623 return No_Element;
624 else
625 return Cursor'(Container'Unrestricted_Access, Container.First);
626 end if;
627 end First;
629 function First (Object : Iterator) return Cursor is
630 begin
631 -- The value of the iterator object's Node component influences the
632 -- behavior of the First (and Last) selector function.
634 -- When the Node component is null, this means the iterator object was
635 -- constructed without a start expression, in which case the (forward)
636 -- iteration starts from the (logical) beginning of the entire sequence
637 -- of items (corresponding to Container.First, for a forward iterator).
639 -- Otherwise, this is iteration over a partial sequence of items. When
640 -- the Node component is non-null, the iterator object was constructed
641 -- with a start expression, that specifies the position from which the
642 -- (forward) partial iteration begins.
644 if Object.Node = null then
645 return Indefinite_Doubly_Linked_Lists.First (Object.Container.all);
646 else
647 return Cursor'(Object.Container, Object.Node);
648 end if;
649 end First;
651 -------------------
652 -- First_Element --
653 -------------------
655 function First_Element (Container : List) return Element_Type is
656 begin
657 if Container.First = null then
658 raise Constraint_Error with "list is empty";
659 else
660 return Container.First.Element.all;
661 end if;
662 end First_Element;
664 ----------
665 -- Free --
666 ----------
668 procedure Free (X : in out Node_Access) is
669 procedure Deallocate is
670 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
672 begin
673 -- While a node is in use, as an active link in a list, its Previous and
674 -- Next components must be null, or designate a different node; this is
675 -- a node invariant. For this indefinite list, there is an additional
676 -- invariant: that the element access value be non-null. Before actually
677 -- deallocating the node, we set the node access value components of the
678 -- node to point to the node itself, and set the element access value to
679 -- null (by deallocating the node's element), thus falsifying the node
680 -- invariant. Subprogram Vet inspects the value of the node components
681 -- when interrogating the node, in order to detect whether the cursor's
682 -- node access value is dangling.
684 -- Note that we have no guarantee that the storage for the node isn't
685 -- modified when it is deallocated, but there are other tests that Vet
686 -- does if node invariants appear to be satisifed. However, in practice
687 -- this simple test works well enough, detecting dangling references
688 -- immediately, without needing further interrogation.
690 X.Next := X;
691 X.Prev := X;
693 begin
694 Free (X.Element);
695 exception
696 when others =>
697 X.Element := null;
698 Deallocate (X);
699 raise;
700 end;
702 Deallocate (X);
703 end Free;
705 ---------------------
706 -- Generic_Sorting --
707 ---------------------
709 package body Generic_Sorting is
711 ---------------
712 -- Is_Sorted --
713 ---------------
715 function Is_Sorted (Container : List) return Boolean is
716 B : Natural renames Container'Unrestricted_Access.Busy;
717 L : Natural renames Container'Unrestricted_Access.Lock;
719 Node : Node_Access;
720 Result : Boolean;
722 begin
723 -- Per AI05-0022, the container implementation is required to detect
724 -- element tampering by a generic actual subprogram.
726 B := B + 1;
727 L := L + 1;
729 Node := Container.First;
730 Result := True;
731 for J in 2 .. Container.Length loop
732 if Node.Next.Element.all < Node.Element.all then
733 Result := False;
734 exit;
735 end if;
737 Node := Node.Next;
738 end loop;
740 B := B - 1;
741 L := L - 1;
743 return Result;
745 exception
746 when others =>
747 B := B - 1;
748 L := L - 1;
749 raise;
750 end Is_Sorted;
752 -----------
753 -- Merge --
754 -----------
756 procedure Merge
757 (Target : in out List;
758 Source : in out List)
760 begin
761 -- The semantics of Merge changed slightly per AI05-0021. It was
762 -- originally the case that if Target and Source denoted the same
763 -- container object, then the GNAT implementation of Merge did
764 -- nothing. However, it was argued that RM05 did not precisely
765 -- specify the semantics for this corner case. The decision of the
766 -- ARG was that if Target and Source denote the same non-empty
767 -- container object, then Program_Error is raised.
769 if Source.Is_Empty then
770 return;
772 elsif Target'Address = Source'Address then
773 raise Program_Error with
774 "Target and Source denote same non-empty container";
776 elsif Target.Length > Count_Type'Last - Source.Length then
777 raise Constraint_Error with "new length exceeds maximum";
779 elsif Target.Busy > 0 then
780 raise Program_Error with
781 "attempt to tamper with cursors of Target (list is busy)";
783 elsif Source.Busy > 0 then
784 raise Program_Error with
785 "attempt to tamper with cursors of Source (list is busy)";
786 end if;
788 declare
789 TB : Natural renames Target.Busy;
790 TL : Natural renames Target.Lock;
792 SB : Natural renames Source.Busy;
793 SL : Natural renames Source.Lock;
795 LI, RI, RJ : Node_Access;
797 begin
798 TB := TB + 1;
799 TL := TL + 1;
801 SB := SB + 1;
802 SL := SL + 1;
804 LI := Target.First;
805 RI := Source.First;
806 while RI /= null loop
807 pragma Assert (RI.Next = null
808 or else not (RI.Next.Element.all <
809 RI.Element.all));
811 if LI = null then
812 Splice_Internal (Target, null, Source);
813 exit;
814 end if;
816 pragma Assert (LI.Next = null
817 or else not (LI.Next.Element.all <
818 LI.Element.all));
820 if RI.Element.all < LI.Element.all then
821 RJ := RI;
822 RI := RI.Next;
823 Splice_Internal (Target, LI, Source, RJ);
825 else
826 LI := LI.Next;
827 end if;
828 end loop;
830 TB := TB - 1;
831 TL := TL - 1;
833 SB := SB - 1;
834 SL := SL - 1;
836 exception
837 when others =>
838 TB := TB - 1;
839 TL := TL - 1;
841 SB := SB - 1;
842 SL := SL - 1;
844 raise;
845 end;
846 end Merge;
848 ----------
849 -- Sort --
850 ----------
852 procedure Sort (Container : in out List) is
853 procedure Partition (Pivot : Node_Access; Back : Node_Access);
854 -- Comment ???
856 procedure Sort (Front, Back : Node_Access);
857 -- Comment??? Confusing name??? change name???
859 ---------------
860 -- Partition --
861 ---------------
863 procedure Partition (Pivot : Node_Access; Back : Node_Access) is
864 Node : Node_Access;
866 begin
867 Node := Pivot.Next;
868 while Node /= Back loop
869 if Node.Element.all < Pivot.Element.all then
870 declare
871 Prev : constant Node_Access := Node.Prev;
872 Next : constant Node_Access := Node.Next;
874 begin
875 Prev.Next := Next;
877 if Next = null then
878 Container.Last := Prev;
879 else
880 Next.Prev := Prev;
881 end if;
883 Node.Next := Pivot;
884 Node.Prev := Pivot.Prev;
886 Pivot.Prev := Node;
888 if Node.Prev = null then
889 Container.First := Node;
890 else
891 Node.Prev.Next := Node;
892 end if;
894 Node := Next;
895 end;
897 else
898 Node := Node.Next;
899 end if;
900 end loop;
901 end Partition;
903 ----------
904 -- Sort --
905 ----------
907 procedure Sort (Front, Back : Node_Access) is
908 Pivot : constant Node_Access :=
909 (if Front = null then Container.First else Front.Next);
910 begin
911 if Pivot /= Back then
912 Partition (Pivot, Back);
913 Sort (Front, Pivot);
914 Sort (Pivot, Back);
915 end if;
916 end Sort;
918 -- Start of processing for Sort
920 begin
921 if Container.Length <= 1 then
922 return;
923 end if;
925 pragma Assert (Container.First.Prev = null);
926 pragma Assert (Container.Last.Next = null);
928 if Container.Busy > 0 then
929 raise Program_Error with
930 "attempt to tamper with cursors (list is busy)";
931 end if;
933 -- Per AI05-0022, the container implementation is required to detect
934 -- element tampering by a generic actual subprogram.
936 declare
937 B : Natural renames Container.Busy;
938 L : Natural renames Container.Lock;
940 begin
941 B := B + 1;
942 L := L + 1;
944 Sort (Front => null, Back => null);
946 B := B - 1;
947 L := L - 1;
948 exception
949 when others =>
950 B := B - 1;
951 L := L - 1;
952 raise;
953 end;
955 pragma Assert (Container.First.Prev = null);
956 pragma Assert (Container.Last.Next = null);
957 end Sort;
959 end Generic_Sorting;
961 -----------------
962 -- Has_Element --
963 -----------------
965 function Has_Element (Position : Cursor) return Boolean is
966 begin
967 pragma Assert (Vet (Position), "bad cursor in Has_Element");
968 return Position.Node /= null;
969 end Has_Element;
971 ------------
972 -- Insert --
973 ------------
975 procedure Insert
976 (Container : in out List;
977 Before : Cursor;
978 New_Item : Element_Type;
979 Position : out Cursor;
980 Count : Count_Type := 1)
982 New_Node : Node_Access;
984 begin
985 if Before.Container /= null then
986 if Before.Container /= Container'Unrestricted_Access then
987 raise Program_Error with
988 "attempt to tamper with cursors (list is busy)";
990 elsif Before.Node = null or else Before.Node.Element = null then
991 raise Program_Error with
992 "Before cursor has no element";
994 else
995 pragma Assert (Vet (Before), "bad cursor in Insert");
996 end if;
997 end if;
999 if Count = 0 then
1000 Position := Before;
1001 return;
1002 end if;
1004 if Container.Length > Count_Type'Last - Count then
1005 raise Constraint_Error with "new length exceeds maximum";
1006 end if;
1008 if Container.Busy > 0 then
1009 raise Program_Error with
1010 "attempt to tamper with cursors (list is busy)";
1011 end if;
1013 declare
1014 -- The element allocator may need an accessibility check in the case
1015 -- the actual type is class-wide or has access discriminants (see
1016 -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
1017 -- allocator in the loop below, because the one in this block would
1018 -- have failed already.
1020 pragma Unsuppress (Accessibility_Check);
1022 Element : Element_Access := new Element_Type'(New_Item);
1024 begin
1025 New_Node := new Node_Type'(Element, null, null);
1027 exception
1028 when others =>
1029 Free (Element);
1030 raise;
1031 end;
1033 Insert_Internal (Container, Before.Node, New_Node);
1034 Position := Cursor'(Container'Unchecked_Access, New_Node);
1036 for J in 2 .. Count loop
1037 declare
1038 Element : Element_Access := new Element_Type'(New_Item);
1039 begin
1040 New_Node := new Node_Type'(Element, null, null);
1041 exception
1042 when others =>
1043 Free (Element);
1044 raise;
1045 end;
1047 Insert_Internal (Container, Before.Node, New_Node);
1048 end loop;
1049 end Insert;
1051 procedure Insert
1052 (Container : in out List;
1053 Before : Cursor;
1054 New_Item : Element_Type;
1055 Count : Count_Type := 1)
1057 Position : Cursor;
1058 pragma Unreferenced (Position);
1059 begin
1060 Insert (Container, Before, New_Item, Position, Count);
1061 end Insert;
1063 ---------------------
1064 -- Insert_Internal --
1065 ---------------------
1067 procedure Insert_Internal
1068 (Container : in out List;
1069 Before : Node_Access;
1070 New_Node : Node_Access)
1072 begin
1073 if Container.Length = 0 then
1074 pragma Assert (Before = null);
1075 pragma Assert (Container.First = null);
1076 pragma Assert (Container.Last = null);
1078 Container.First := New_Node;
1079 Container.Last := New_Node;
1081 elsif Before = null then
1082 pragma Assert (Container.Last.Next = null);
1084 Container.Last.Next := New_Node;
1085 New_Node.Prev := Container.Last;
1087 Container.Last := New_Node;
1089 elsif Before = Container.First then
1090 pragma Assert (Container.First.Prev = null);
1092 Container.First.Prev := New_Node;
1093 New_Node.Next := Container.First;
1095 Container.First := New_Node;
1097 else
1098 pragma Assert (Container.First.Prev = null);
1099 pragma Assert (Container.Last.Next = null);
1101 New_Node.Next := Before;
1102 New_Node.Prev := Before.Prev;
1104 Before.Prev.Next := New_Node;
1105 Before.Prev := New_Node;
1106 end if;
1108 Container.Length := Container.Length + 1;
1109 end Insert_Internal;
1111 --------------
1112 -- Is_Empty --
1113 --------------
1115 function Is_Empty (Container : List) return Boolean is
1116 begin
1117 return Container.Length = 0;
1118 end Is_Empty;
1120 -------------
1121 -- Iterate --
1122 -------------
1124 procedure Iterate
1125 (Container : List;
1126 Process : not null access procedure (Position : Cursor))
1128 B : Natural renames Container'Unrestricted_Access.all.Busy;
1129 Node : Node_Access := Container.First;
1131 begin
1132 B := B + 1;
1134 begin
1135 while Node /= null loop
1136 Process (Cursor'(Container'Unrestricted_Access, Node));
1137 Node := Node.Next;
1138 end loop;
1139 exception
1140 when others =>
1141 B := B - 1;
1142 raise;
1143 end;
1145 B := B - 1;
1146 end Iterate;
1148 function Iterate
1149 (Container : List)
1150 return List_Iterator_Interfaces.Reversible_Iterator'class
1152 B : Natural renames Container'Unrestricted_Access.all.Busy;
1154 begin
1155 -- The value of the Node component influences the behavior of the First
1156 -- and Last selector functions of the iterator object. When the Node
1157 -- component is null (as is the case here), this means the iterator
1158 -- object was constructed without a start expression. This is a
1159 -- complete iterator, meaning that the iteration starts from the
1160 -- (logical) beginning of the sequence of items.
1162 -- Note: For a forward iterator, Container.First is the beginning, and
1163 -- for a reverse iterator, Container.Last is the beginning.
1165 return It : constant Iterator :=
1166 Iterator'(Limited_Controlled with
1167 Container => Container'Unrestricted_Access,
1168 Node => null)
1170 B := B + 1;
1171 end return;
1172 end Iterate;
1174 function Iterate
1175 (Container : List;
1176 Start : Cursor)
1177 return List_Iterator_Interfaces.Reversible_Iterator'Class
1179 B : Natural renames Container'Unrestricted_Access.all.Busy;
1181 begin
1182 -- It was formerly the case that when Start = No_Element, the partial
1183 -- iterator was defined to behave the same as for a complete iterator,
1184 -- and iterate over the entire sequence of items. However, those
1185 -- semantics were unintuitive and arguably error-prone (it is too easy
1186 -- to accidentally create an endless loop), and so they were changed,
1187 -- per the ARG meeting in Denver on 2011/11. However, there was no
1188 -- consensus about what positive meaning this corner case should have,
1189 -- and so it was decided to simply raise an exception. This does imply,
1190 -- however, that it is not possible to use a partial iterator to specify
1191 -- an empty sequence of items.
1193 if Start = No_Element then
1194 raise Constraint_Error with
1195 "Start position for iterator equals No_Element";
1197 elsif Start.Container /= Container'Unrestricted_Access then
1198 raise Program_Error with
1199 "Start cursor of Iterate designates wrong list";
1201 else
1202 pragma Assert (Vet (Start), "Start cursor of Iterate is bad");
1204 -- The value of the Node component influences the behavior of the
1205 -- First and Last selector functions of the iterator object. When
1206 -- the Node component is non-null (as is the case here), it means
1207 -- that this is a partial iteration, over a subset of the complete
1208 -- sequence of items. The iterator object was constructed with
1209 -- a start expression, indicating the position from which the
1210 -- iteration begins. Note that the start position has the same value
1211 -- irrespective of whether this is a forward or reverse iteration.
1213 return It : constant Iterator :=
1214 Iterator'(Limited_Controlled with
1215 Container => Container'Unrestricted_Access,
1216 Node => Start.Node)
1218 B := B + 1;
1219 end return;
1220 end if;
1221 end Iterate;
1223 ----------
1224 -- Last --
1225 ----------
1227 function Last (Container : List) return Cursor is
1228 begin
1229 if Container.Last = null then
1230 return No_Element;
1231 else
1232 return Cursor'(Container'Unrestricted_Access, Container.Last);
1233 end if;
1234 end Last;
1236 function Last (Object : Iterator) return Cursor is
1237 begin
1238 -- The value of the iterator object's Node component influences the
1239 -- behavior of the Last (and First) selector function.
1241 -- When the Node component is null, this means the iterator object was
1242 -- constructed without a start expression, in which case the (reverse)
1243 -- iteration starts from the (logical) beginning of the entire sequence
1244 -- (corresponding to Container.Last, for a reverse iterator).
1246 -- Otherwise, this is iteration over a partial sequence of items. When
1247 -- the Node component is non-null, the iterator object was constructed
1248 -- with a start expression, that specifies the position from which the
1249 -- (reverse) partial iteration begins.
1251 if Object.Node = null then
1252 return Indefinite_Doubly_Linked_Lists.Last (Object.Container.all);
1253 else
1254 return Cursor'(Object.Container, Object.Node);
1255 end if;
1256 end Last;
1258 ------------------
1259 -- Last_Element --
1260 ------------------
1262 function Last_Element (Container : List) return Element_Type is
1263 begin
1264 if Container.Last = null then
1265 raise Constraint_Error with "list is empty";
1266 else
1267 return Container.Last.Element.all;
1268 end if;
1269 end Last_Element;
1271 ------------
1272 -- Length --
1273 ------------
1275 function Length (Container : List) return Count_Type is
1276 begin
1277 return Container.Length;
1278 end Length;
1280 ----------
1281 -- Move --
1282 ----------
1284 procedure Move (Target : in out List; Source : in out List) is
1285 begin
1286 if Target'Address = Source'Address then
1287 return;
1289 elsif Source.Busy > 0 then
1290 raise Program_Error with
1291 "attempt to tamper with cursors of Source (list is busy)";
1293 else
1294 Clear (Target);
1296 Target.First := Source.First;
1297 Source.First := null;
1299 Target.Last := Source.Last;
1300 Source.Last := null;
1302 Target.Length := Source.Length;
1303 Source.Length := 0;
1304 end if;
1305 end Move;
1307 ----------
1308 -- Next --
1309 ----------
1311 procedure Next (Position : in out Cursor) is
1312 begin
1313 Position := Next (Position);
1314 end Next;
1316 function Next (Position : Cursor) return Cursor is
1317 begin
1318 if Position.Node = null then
1319 return No_Element;
1321 else
1322 pragma Assert (Vet (Position), "bad cursor in Next");
1324 declare
1325 Next_Node : constant Node_Access := Position.Node.Next;
1326 begin
1327 if Next_Node = null then
1328 return No_Element;
1329 else
1330 return Cursor'(Position.Container, Next_Node);
1331 end if;
1332 end;
1333 end if;
1334 end Next;
1336 function Next (Object : Iterator; Position : Cursor) return Cursor is
1337 begin
1338 if Position.Container = null then
1339 return No_Element;
1340 elsif Position.Container /= Object.Container then
1341 raise Program_Error with
1342 "Position cursor of Next designates wrong list";
1343 else
1344 return Next (Position);
1345 end if;
1346 end Next;
1348 -------------
1349 -- Prepend --
1350 -------------
1352 procedure Prepend
1353 (Container : in out List;
1354 New_Item : Element_Type;
1355 Count : Count_Type := 1)
1357 begin
1358 Insert (Container, First (Container), New_Item, Count);
1359 end Prepend;
1361 --------------
1362 -- Previous --
1363 --------------
1365 procedure Previous (Position : in out Cursor) is
1366 begin
1367 Position := Previous (Position);
1368 end Previous;
1370 function Previous (Position : Cursor) return Cursor is
1371 begin
1372 if Position.Node = null then
1373 return No_Element;
1375 else
1376 pragma Assert (Vet (Position), "bad cursor in Previous");
1378 declare
1379 Prev_Node : constant Node_Access := Position.Node.Prev;
1380 begin
1381 if Prev_Node = null then
1382 return No_Element;
1383 else
1384 return Cursor'(Position.Container, Prev_Node);
1385 end if;
1386 end;
1387 end if;
1388 end Previous;
1390 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1391 begin
1392 if Position.Container = null then
1393 return No_Element;
1394 elsif Position.Container /= Object.Container then
1395 raise Program_Error with
1396 "Position cursor of Previous designates wrong list";
1397 else
1398 return Previous (Position);
1399 end if;
1400 end Previous;
1402 -------------------
1403 -- Query_Element --
1404 -------------------
1406 procedure Query_Element
1407 (Position : Cursor;
1408 Process : not null access procedure (Element : Element_Type))
1410 begin
1411 if Position.Node = null then
1412 raise Constraint_Error with
1413 "Position cursor has no element";
1415 elsif Position.Node.Element = null then
1416 raise Program_Error with
1417 "Position cursor has no element";
1419 else
1420 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1422 declare
1423 C : List renames Position.Container.all'Unrestricted_Access.all;
1424 B : Natural renames C.Busy;
1425 L : Natural renames C.Lock;
1427 begin
1428 B := B + 1;
1429 L := L + 1;
1431 begin
1432 Process (Position.Node.Element.all);
1433 exception
1434 when others =>
1435 L := L - 1;
1436 B := B - 1;
1437 raise;
1438 end;
1440 L := L - 1;
1441 B := B - 1;
1442 end;
1443 end if;
1444 end Query_Element;
1446 ----------
1447 -- Read --
1448 ----------
1450 procedure Read
1451 (Stream : not null access Root_Stream_Type'Class;
1452 Item : out List)
1454 N : Count_Type'Base;
1455 Dst : Node_Access;
1457 begin
1458 Clear (Item);
1460 Count_Type'Base'Read (Stream, N);
1462 if N = 0 then
1463 return;
1464 end if;
1466 declare
1467 Element : Element_Access :=
1468 new Element_Type'(Element_Type'Input (Stream));
1469 begin
1470 Dst := new Node_Type'(Element, null, null);
1471 exception
1472 when others =>
1473 Free (Element);
1474 raise;
1475 end;
1477 Item.First := Dst;
1478 Item.Last := Dst;
1479 Item.Length := 1;
1481 while Item.Length < N loop
1482 declare
1483 Element : Element_Access :=
1484 new Element_Type'(Element_Type'Input (Stream));
1485 begin
1486 Dst := new Node_Type'(Element, Next => null, Prev => Item.Last);
1487 exception
1488 when others =>
1489 Free (Element);
1490 raise;
1491 end;
1493 Item.Last.Next := Dst;
1494 Item.Last := Dst;
1495 Item.Length := Item.Length + 1;
1496 end loop;
1497 end Read;
1499 procedure Read
1500 (Stream : not null access Root_Stream_Type'Class;
1501 Item : out Cursor)
1503 begin
1504 raise Program_Error with "attempt to stream list cursor";
1505 end Read;
1507 procedure Read
1508 (Stream : not null access Root_Stream_Type'Class;
1509 Item : out Reference_Type)
1511 begin
1512 raise Program_Error with "attempt to stream reference";
1513 end Read;
1515 procedure Read
1516 (Stream : not null access Root_Stream_Type'Class;
1517 Item : out Constant_Reference_Type)
1519 begin
1520 raise Program_Error with "attempt to stream reference";
1521 end Read;
1523 ---------------
1524 -- Reference --
1525 ---------------
1527 function Reference
1528 (Container : aliased in out List;
1529 Position : Cursor) return Reference_Type
1531 begin
1532 if Position.Container = null then
1533 raise Constraint_Error with "Position cursor has no element";
1535 elsif Position.Container /= Container'Unrestricted_Access then
1536 raise Program_Error with
1537 "Position cursor designates wrong container";
1539 elsif Position.Node.Element = null then
1540 raise Program_Error with "Node has no element";
1542 else
1543 pragma Assert (Vet (Position), "bad cursor in function Reference");
1545 declare
1546 C : List renames Position.Container.all;
1547 B : Natural renames C.Busy;
1548 L : Natural renames C.Lock;
1549 begin
1550 return R : constant Reference_Type :=
1551 (Element => Position.Node.Element.all'Access,
1552 Control => (Controlled with Position.Container))
1554 B := B + 1;
1555 L := L + 1;
1556 end return;
1557 end;
1558 end if;
1559 end Reference;
1561 ---------------------
1562 -- Replace_Element --
1563 ---------------------
1565 procedure Replace_Element
1566 (Container : in out List;
1567 Position : Cursor;
1568 New_Item : Element_Type)
1570 begin
1571 if Position.Container = null then
1572 raise Constraint_Error with "Position cursor has no element";
1574 elsif Position.Container /= Container'Unchecked_Access then
1575 raise Program_Error with
1576 "Position cursor designates wrong container";
1578 elsif Container.Lock > 0 then
1579 raise Program_Error with
1580 "attempt to tamper with elements (list is locked)";
1582 elsif Position.Node.Element = null then
1583 raise Program_Error with
1584 "Position cursor has no element";
1586 else
1587 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1589 declare
1590 -- The element allocator may need an accessibility check in the
1591 -- case the actual type is class-wide or has access discriminants
1592 -- (see RM 4.8(10.1) and AI12-0035).
1594 pragma Unsuppress (Accessibility_Check);
1596 X : Element_Access := Position.Node.Element;
1598 begin
1599 Position.Node.Element := new Element_Type'(New_Item);
1600 Free (X);
1601 end;
1602 end if;
1603 end Replace_Element;
1605 ----------------------
1606 -- Reverse_Elements --
1607 ----------------------
1609 procedure Reverse_Elements (Container : in out List) is
1610 I : Node_Access := Container.First;
1611 J : Node_Access := Container.Last;
1613 procedure Swap (L, R : Node_Access);
1615 ----------
1616 -- Swap --
1617 ----------
1619 procedure Swap (L, R : Node_Access) is
1620 LN : constant Node_Access := L.Next;
1621 LP : constant Node_Access := L.Prev;
1623 RN : constant Node_Access := R.Next;
1624 RP : constant Node_Access := R.Prev;
1626 begin
1627 if LP /= null then
1628 LP.Next := R;
1629 end if;
1631 if RN /= null then
1632 RN.Prev := L;
1633 end if;
1635 L.Next := RN;
1636 R.Prev := LP;
1638 if LN = R then
1639 pragma Assert (RP = L);
1641 L.Prev := R;
1642 R.Next := L;
1644 else
1645 L.Prev := RP;
1646 RP.Next := L;
1648 R.Next := LN;
1649 LN.Prev := R;
1650 end if;
1651 end Swap;
1653 -- Start of processing for Reverse_Elements
1655 begin
1656 if Container.Length <= 1 then
1657 return;
1658 end if;
1660 pragma Assert (Container.First.Prev = null);
1661 pragma Assert (Container.Last.Next = null);
1663 if Container.Busy > 0 then
1664 raise Program_Error with
1665 "attempt to tamper with cursors (list is busy)";
1666 end if;
1668 Container.First := J;
1669 Container.Last := I;
1670 loop
1671 Swap (L => I, R => J);
1673 J := J.Next;
1674 exit when I = J;
1676 I := I.Prev;
1677 exit when I = J;
1679 Swap (L => J, R => I);
1681 I := I.Next;
1682 exit when I = J;
1684 J := J.Prev;
1685 exit when I = J;
1686 end loop;
1688 pragma Assert (Container.First.Prev = null);
1689 pragma Assert (Container.Last.Next = null);
1690 end Reverse_Elements;
1692 ------------------
1693 -- Reverse_Find --
1694 ------------------
1696 function Reverse_Find
1697 (Container : List;
1698 Item : Element_Type;
1699 Position : Cursor := No_Element) return Cursor
1701 Node : Node_Access := Position.Node;
1703 begin
1704 if Node = null then
1705 Node := Container.Last;
1707 else
1708 if Node.Element = null then
1709 raise Program_Error with "Position cursor has no element";
1711 elsif Position.Container /= Container'Unrestricted_Access then
1712 raise Program_Error with
1713 "Position cursor designates wrong container";
1715 else
1716 pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1717 end if;
1718 end if;
1720 -- Per AI05-0022, the container implementation is required to detect
1721 -- element tampering by a generic actual subprogram.
1723 declare
1724 B : Natural renames Container'Unrestricted_Access.Busy;
1725 L : Natural renames Container'Unrestricted_Access.Lock;
1727 Result : Node_Access;
1729 begin
1730 B := B + 1;
1731 L := L + 1;
1733 Result := null;
1734 while Node /= null loop
1735 if Node.Element.all = Item then
1736 Result := Node;
1737 exit;
1738 end if;
1740 Node := Node.Prev;
1741 end loop;
1743 B := B - 1;
1744 L := L - 1;
1746 if Result = null then
1747 return No_Element;
1748 else
1749 return Cursor'(Container'Unrestricted_Access, Result);
1750 end if;
1752 exception
1753 when others =>
1754 B := B - 1;
1755 L := L - 1;
1756 raise;
1757 end;
1758 end Reverse_Find;
1760 ---------------------
1761 -- Reverse_Iterate --
1762 ---------------------
1764 procedure Reverse_Iterate
1765 (Container : List;
1766 Process : not null access procedure (Position : Cursor))
1768 C : List renames Container'Unrestricted_Access.all;
1769 B : Natural renames C.Busy;
1771 Node : Node_Access := Container.Last;
1773 begin
1774 B := B + 1;
1776 begin
1777 while Node /= null loop
1778 Process (Cursor'(Container'Unrestricted_Access, Node));
1779 Node := Node.Prev;
1780 end loop;
1781 exception
1782 when others =>
1783 B := B - 1;
1784 raise;
1785 end;
1787 B := B - 1;
1788 end Reverse_Iterate;
1790 ------------
1791 -- Splice --
1792 ------------
1794 procedure Splice
1795 (Target : in out List;
1796 Before : Cursor;
1797 Source : in out List)
1799 begin
1800 if Before.Container /= null then
1801 if Before.Container /= Target'Unrestricted_Access then
1802 raise Program_Error with
1803 "Before cursor designates wrong container";
1805 elsif Before.Node = null or else Before.Node.Element = null then
1806 raise Program_Error with
1807 "Before cursor has no element";
1809 else
1810 pragma Assert (Vet (Before), "bad cursor in Splice");
1811 end if;
1812 end if;
1814 if Target'Address = Source'Address or else Source.Length = 0 then
1815 return;
1817 elsif Target.Length > Count_Type'Last - Source.Length then
1818 raise Constraint_Error with "new length exceeds maximum";
1820 elsif Target.Busy > 0 then
1821 raise Program_Error with
1822 "attempt to tamper with cursors of Target (list is busy)";
1824 elsif Source.Busy > 0 then
1825 raise Program_Error with
1826 "attempt to tamper with cursors of Source (list is busy)";
1828 else
1829 Splice_Internal (Target, Before.Node, Source);
1830 end if;
1831 end Splice;
1833 procedure Splice
1834 (Container : in out List;
1835 Before : Cursor;
1836 Position : Cursor)
1838 begin
1839 if Before.Container /= null then
1840 if Before.Container /= Container'Unchecked_Access then
1841 raise Program_Error with
1842 "Before cursor designates wrong container";
1844 elsif Before.Node = null or else Before.Node.Element = null then
1845 raise Program_Error with
1846 "Before cursor has no element";
1848 else
1849 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1850 end if;
1851 end if;
1853 if Position.Node = null then
1854 raise Constraint_Error with "Position cursor has no element";
1855 end if;
1857 if Position.Node.Element = null then
1858 raise Program_Error with "Position cursor has no element";
1859 end if;
1861 if Position.Container /= Container'Unrestricted_Access then
1862 raise Program_Error with
1863 "Position cursor designates wrong container";
1864 end if;
1866 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1868 if Position.Node = Before.Node
1869 or else Position.Node.Next = Before.Node
1870 then
1871 return;
1872 end if;
1874 pragma Assert (Container.Length >= 2);
1876 if Container.Busy > 0 then
1877 raise Program_Error with
1878 "attempt to tamper with cursors (list is busy)";
1879 end if;
1881 if Before.Node = null then
1882 pragma Assert (Position.Node /= Container.Last);
1884 if Position.Node = Container.First then
1885 Container.First := Position.Node.Next;
1886 Container.First.Prev := null;
1887 else
1888 Position.Node.Prev.Next := Position.Node.Next;
1889 Position.Node.Next.Prev := Position.Node.Prev;
1890 end if;
1892 Container.Last.Next := Position.Node;
1893 Position.Node.Prev := Container.Last;
1895 Container.Last := Position.Node;
1896 Container.Last.Next := null;
1898 return;
1899 end if;
1901 if Before.Node = Container.First then
1902 pragma Assert (Position.Node /= Container.First);
1904 if Position.Node = Container.Last then
1905 Container.Last := Position.Node.Prev;
1906 Container.Last.Next := null;
1907 else
1908 Position.Node.Prev.Next := Position.Node.Next;
1909 Position.Node.Next.Prev := Position.Node.Prev;
1910 end if;
1912 Container.First.Prev := Position.Node;
1913 Position.Node.Next := Container.First;
1915 Container.First := Position.Node;
1916 Container.First.Prev := null;
1918 return;
1919 end if;
1921 if Position.Node = Container.First then
1922 Container.First := Position.Node.Next;
1923 Container.First.Prev := null;
1925 elsif Position.Node = Container.Last then
1926 Container.Last := Position.Node.Prev;
1927 Container.Last.Next := null;
1929 else
1930 Position.Node.Prev.Next := Position.Node.Next;
1931 Position.Node.Next.Prev := Position.Node.Prev;
1932 end if;
1934 Before.Node.Prev.Next := Position.Node;
1935 Position.Node.Prev := Before.Node.Prev;
1937 Before.Node.Prev := Position.Node;
1938 Position.Node.Next := Before.Node;
1940 pragma Assert (Container.First.Prev = null);
1941 pragma Assert (Container.Last.Next = null);
1942 end Splice;
1944 procedure Splice
1945 (Target : in out List;
1946 Before : Cursor;
1947 Source : in out List;
1948 Position : in out Cursor)
1950 begin
1951 if Target'Address = Source'Address then
1952 Splice (Target, Before, Position);
1953 return;
1954 end if;
1956 if Before.Container /= null then
1957 if Before.Container /= Target'Unrestricted_Access then
1958 raise Program_Error with
1959 "Before cursor designates wrong container";
1960 end if;
1962 if Before.Node = null
1963 or else Before.Node.Element = null
1964 then
1965 raise Program_Error with
1966 "Before cursor has no element";
1967 end if;
1969 pragma Assert (Vet (Before), "bad Before cursor in Splice");
1970 end if;
1972 if Position.Node = null then
1973 raise Constraint_Error with "Position cursor has no element";
1974 end if;
1976 if Position.Node.Element = null then
1977 raise Program_Error with
1978 "Position cursor has no element";
1979 end if;
1981 if Position.Container /= Source'Unrestricted_Access then
1982 raise Program_Error with
1983 "Position cursor designates wrong container";
1984 end if;
1986 pragma Assert (Vet (Position), "bad Position cursor in Splice");
1988 if Target.Length = Count_Type'Last then
1989 raise Constraint_Error with "Target is full";
1990 end if;
1992 if Target.Busy > 0 then
1993 raise Program_Error with
1994 "attempt to tamper with cursors of Target (list is busy)";
1995 end if;
1997 if Source.Busy > 0 then
1998 raise Program_Error with
1999 "attempt to tamper with cursors of Source (list is busy)";
2000 end if;
2002 Splice_Internal (Target, Before.Node, Source, Position.Node);
2003 Position.Container := Target'Unchecked_Access;
2004 end Splice;
2006 ---------------------
2007 -- Splice_Internal --
2008 ---------------------
2010 procedure Splice_Internal
2011 (Target : in out List;
2012 Before : Node_Access;
2013 Source : in out List)
2015 begin
2016 -- This implements the corresponding Splice operation, after the
2017 -- parameters have been vetted, and corner-cases disposed of.
2019 pragma Assert (Target'Address /= Source'Address);
2020 pragma Assert (Source.Length > 0);
2021 pragma Assert (Source.First /= null);
2022 pragma Assert (Source.First.Prev = null);
2023 pragma Assert (Source.Last /= null);
2024 pragma Assert (Source.Last.Next = null);
2025 pragma Assert (Target.Length <= Count_Type'Last - Source.Length);
2027 if Target.Length = 0 then
2028 pragma Assert (Before = null);
2029 pragma Assert (Target.First = null);
2030 pragma Assert (Target.Last = null);
2032 Target.First := Source.First;
2033 Target.Last := Source.Last;
2035 elsif Before = null then
2036 pragma Assert (Target.Last.Next = null);
2038 Target.Last.Next := Source.First;
2039 Source.First.Prev := Target.Last;
2041 Target.Last := Source.Last;
2043 elsif Before = Target.First then
2044 pragma Assert (Target.First.Prev = null);
2046 Source.Last.Next := Target.First;
2047 Target.First.Prev := Source.Last;
2049 Target.First := Source.First;
2051 else
2052 pragma Assert (Target.Length >= 2);
2053 Before.Prev.Next := Source.First;
2054 Source.First.Prev := Before.Prev;
2056 Before.Prev := Source.Last;
2057 Source.Last.Next := Before;
2058 end if;
2060 Source.First := null;
2061 Source.Last := null;
2063 Target.Length := Target.Length + Source.Length;
2064 Source.Length := 0;
2065 end Splice_Internal;
2067 procedure Splice_Internal
2068 (Target : in out List;
2069 Before : Node_Access; -- node of Target
2070 Source : in out List;
2071 Position : Node_Access) -- node of Source
2073 begin
2074 -- This implements the corresponding Splice operation, after the
2075 -- parameters have been vetted.
2077 pragma Assert (Target'Address /= Source'Address);
2078 pragma Assert (Target.Length < Count_Type'Last);
2079 pragma Assert (Source.Length > 0);
2080 pragma Assert (Source.First /= null);
2081 pragma Assert (Source.First.Prev = null);
2082 pragma Assert (Source.Last /= null);
2083 pragma Assert (Source.Last.Next = null);
2084 pragma Assert (Position /= null);
2086 if Position = Source.First then
2087 Source.First := Position.Next;
2089 if Position = Source.Last then
2090 pragma Assert (Source.First = null);
2091 pragma Assert (Source.Length = 1);
2092 Source.Last := null;
2094 else
2095 Source.First.Prev := null;
2096 end if;
2098 elsif Position = Source.Last then
2099 pragma Assert (Source.Length >= 2);
2100 Source.Last := Position.Prev;
2101 Source.Last.Next := null;
2103 else
2104 pragma Assert (Source.Length >= 3);
2105 Position.Prev.Next := Position.Next;
2106 Position.Next.Prev := Position.Prev;
2107 end if;
2109 if Target.Length = 0 then
2110 pragma Assert (Before = null);
2111 pragma Assert (Target.First = null);
2112 pragma Assert (Target.Last = null);
2114 Target.First := Position;
2115 Target.Last := Position;
2117 Target.First.Prev := null;
2118 Target.Last.Next := null;
2120 elsif Before = null then
2121 pragma Assert (Target.Last.Next = null);
2122 Target.Last.Next := Position;
2123 Position.Prev := Target.Last;
2125 Target.Last := Position;
2126 Target.Last.Next := null;
2128 elsif Before = Target.First then
2129 pragma Assert (Target.First.Prev = null);
2130 Target.First.Prev := Position;
2131 Position.Next := Target.First;
2133 Target.First := Position;
2134 Target.First.Prev := null;
2136 else
2137 pragma Assert (Target.Length >= 2);
2138 Before.Prev.Next := Position;
2139 Position.Prev := Before.Prev;
2141 Before.Prev := Position;
2142 Position.Next := Before;
2143 end if;
2145 Target.Length := Target.Length + 1;
2146 Source.Length := Source.Length - 1;
2147 end Splice_Internal;
2149 ----------
2150 -- Swap --
2151 ----------
2153 procedure Swap
2154 (Container : in out List;
2155 I, J : Cursor)
2157 begin
2158 if I.Node = null then
2159 raise Constraint_Error with "I cursor has no element";
2160 end if;
2162 if J.Node = null then
2163 raise Constraint_Error with "J cursor has no element";
2164 end if;
2166 if I.Container /= Container'Unchecked_Access then
2167 raise Program_Error with "I cursor designates wrong container";
2168 end if;
2170 if J.Container /= Container'Unchecked_Access then
2171 raise Program_Error with "J cursor designates wrong container";
2172 end if;
2174 if I.Node = J.Node then
2175 return;
2176 end if;
2178 if Container.Lock > 0 then
2179 raise Program_Error with
2180 "attempt to tamper with elements (list is locked)";
2181 end if;
2183 pragma Assert (Vet (I), "bad I cursor in Swap");
2184 pragma Assert (Vet (J), "bad J cursor in Swap");
2186 declare
2187 EI_Copy : constant Element_Access := I.Node.Element;
2189 begin
2190 I.Node.Element := J.Node.Element;
2191 J.Node.Element := EI_Copy;
2192 end;
2193 end Swap;
2195 ----------------
2196 -- Swap_Links --
2197 ----------------
2199 procedure Swap_Links
2200 (Container : in out List;
2201 I, J : Cursor)
2203 begin
2204 if I.Node = null then
2205 raise Constraint_Error with "I cursor has no element";
2206 end if;
2208 if J.Node = null then
2209 raise Constraint_Error with "J cursor has no element";
2210 end if;
2212 if I.Container /= Container'Unrestricted_Access then
2213 raise Program_Error with "I cursor designates wrong container";
2214 end if;
2216 if J.Container /= Container'Unrestricted_Access then
2217 raise Program_Error with "J cursor designates wrong container";
2218 end if;
2220 if I.Node = J.Node then
2221 return;
2222 end if;
2224 if Container.Busy > 0 then
2225 raise Program_Error with
2226 "attempt to tamper with cursors (list is busy)";
2227 end if;
2229 pragma Assert (Vet (I), "bad I cursor in Swap_Links");
2230 pragma Assert (Vet (J), "bad J cursor in Swap_Links");
2232 declare
2233 I_Next : constant Cursor := Next (I);
2235 begin
2236 if I_Next = J then
2237 Splice (Container, Before => I, Position => J);
2239 else
2240 declare
2241 J_Next : constant Cursor := Next (J);
2243 begin
2244 if J_Next = I then
2245 Splice (Container, Before => J, Position => I);
2247 else
2248 pragma Assert (Container.Length >= 3);
2250 Splice (Container, Before => I_Next, Position => J);
2251 Splice (Container, Before => J_Next, Position => I);
2252 end if;
2253 end;
2254 end if;
2255 end;
2257 pragma Assert (Container.First.Prev = null);
2258 pragma Assert (Container.Last.Next = null);
2259 end Swap_Links;
2261 --------------------
2262 -- Update_Element --
2263 --------------------
2265 procedure Update_Element
2266 (Container : in out List;
2267 Position : Cursor;
2268 Process : not null access procedure (Element : in out Element_Type))
2270 begin
2271 if Position.Node = null then
2272 raise Constraint_Error with "Position cursor has no element";
2273 end if;
2275 if Position.Node.Element = null then
2276 raise Program_Error with
2277 "Position cursor has no element";
2278 end if;
2280 if Position.Container /= Container'Unchecked_Access then
2281 raise Program_Error with
2282 "Position cursor designates wrong container";
2283 end if;
2285 pragma Assert (Vet (Position), "bad cursor in Update_Element");
2287 declare
2288 B : Natural renames Container.Busy;
2289 L : Natural renames Container.Lock;
2291 begin
2292 B := B + 1;
2293 L := L + 1;
2295 begin
2296 Process (Position.Node.Element.all);
2297 exception
2298 when others =>
2299 L := L - 1;
2300 B := B - 1;
2301 raise;
2302 end;
2304 L := L - 1;
2305 B := B - 1;
2306 end;
2307 end Update_Element;
2309 ---------
2310 -- Vet --
2311 ---------
2313 function Vet (Position : Cursor) return Boolean is
2314 begin
2315 if Position.Node = null then
2316 return Position.Container = null;
2317 end if;
2319 if Position.Container = null then
2320 return False;
2321 end if;
2323 -- An invariant of a node is that its Previous and Next components can
2324 -- be null, or designate a different node. Also, its element access
2325 -- value must be non-null. Operation Free sets the node access value
2326 -- components of the node to designate the node itself, and the element
2327 -- access value to null, before actually deallocating the node, thus
2328 -- deliberately violating the node invariant. This gives us a simple way
2329 -- to detect a dangling reference to a node.
2331 if Position.Node.Next = Position.Node then
2332 return False;
2333 end if;
2335 if Position.Node.Prev = Position.Node then
2336 return False;
2337 end if;
2339 if Position.Node.Element = null then
2340 return False;
2341 end if;
2343 -- In practice the tests above will detect most instances of a dangling
2344 -- reference. If we get here, it means that the invariants of the
2345 -- designated node are satisfied (they at least appear to be satisfied),
2346 -- so we perform some more tests, to determine whether invariants of the
2347 -- designated list are satisfied too.
2349 declare
2350 L : List renames Position.Container.all;
2352 begin
2353 if L.Length = 0 then
2354 return False;
2355 end if;
2357 if L.First = null then
2358 return False;
2359 end if;
2361 if L.Last = null then
2362 return False;
2363 end if;
2365 if L.First.Prev /= null then
2366 return False;
2367 end if;
2369 if L.Last.Next /= null then
2370 return False;
2371 end if;
2373 if Position.Node.Prev = null and then Position.Node /= L.First then
2374 return False;
2375 end if;
2377 if Position.Node.Next = null and then Position.Node /= L.Last then
2378 return False;
2379 end if;
2381 if L.Length = 1 then
2382 return L.First = L.Last;
2383 end if;
2385 if L.First = L.Last then
2386 return False;
2387 end if;
2389 if L.First.Next = null then
2390 return False;
2391 end if;
2393 if L.Last.Prev = null then
2394 return False;
2395 end if;
2397 if L.First.Next.Prev /= L.First then
2398 return False;
2399 end if;
2401 if L.Last.Prev.Next /= L.Last then
2402 return False;
2403 end if;
2405 if L.Length = 2 then
2406 if L.First.Next /= L.Last then
2407 return False;
2408 end if;
2410 if L.Last.Prev /= L.First then
2411 return False;
2412 end if;
2414 return True;
2415 end if;
2417 if L.First.Next = L.Last then
2418 return False;
2419 end if;
2421 if L.Last.Prev = L.First then
2422 return False;
2423 end if;
2425 if Position.Node = L.First then
2426 return True;
2427 end if;
2429 if Position.Node = L.Last then
2430 return True;
2431 end if;
2433 if Position.Node.Next = null then
2434 return False;
2435 end if;
2437 if Position.Node.Prev = null then
2438 return False;
2439 end if;
2441 if Position.Node.Next.Prev /= Position.Node then
2442 return False;
2443 end if;
2445 if Position.Node.Prev.Next /= Position.Node then
2446 return False;
2447 end if;
2449 if L.Length = 3 then
2450 if L.First.Next /= Position.Node then
2451 return False;
2452 end if;
2454 if L.Last.Prev /= Position.Node then
2455 return False;
2456 end if;
2457 end if;
2459 return True;
2460 end;
2461 end Vet;
2463 -----------
2464 -- Write --
2465 -----------
2467 procedure Write
2468 (Stream : not null access Root_Stream_Type'Class;
2469 Item : List)
2471 Node : Node_Access := Item.First;
2473 begin
2474 Count_Type'Base'Write (Stream, Item.Length);
2476 while Node /= null loop
2477 Element_Type'Output (Stream, Node.Element.all);
2478 Node := Node.Next;
2479 end loop;
2480 end Write;
2482 procedure Write
2483 (Stream : not null access Root_Stream_Type'Class;
2484 Item : Cursor)
2486 begin
2487 raise Program_Error with "attempt to stream list cursor";
2488 end Write;
2490 procedure Write
2491 (Stream : not null access Root_Stream_Type'Class;
2492 Item : Reference_Type)
2494 begin
2495 raise Program_Error with "attempt to stream reference";
2496 end Write;
2498 procedure Write
2499 (Stream : not null access Root_Stream_Type'Class;
2500 Item : Constant_Reference_Type)
2502 begin
2503 raise Program_Error with "attempt to stream reference";
2504 end Write;
2506 end Ada.Containers.Indefinite_Doubly_Linked_Lists;