OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-cdlili.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.