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