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

Subversion Repositories openrisc

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

powered by: WebSVN 2.1.0

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