Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-cbdlli.adb @ 111:04ced10e8804

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