OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [a-cidlli.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 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-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- This unit was originally developed by Matthew J Heaney.                  --
28
------------------------------------------------------------------------------
29
 
30
with System;  use type System.Address;
31
with Ada.Unchecked_Deallocation;
32
 
33
package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
34
 
35
   procedure Free is
36
     new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
37
 
38
   -----------------------
39
   -- Local Subprograms --
40
   -----------------------
41
 
42
   procedure Free (X : in out Node_Access);
43
 
44
   procedure Insert_Internal
45
     (Container : in out List;
46
      Before    : Node_Access;
47
      New_Node  : Node_Access);
48
 
49
   function Vet (Position : Cursor) return Boolean;
50
 
51
   ---------
52
   -- "=" --
53
   ---------
54
 
55
   function "=" (Left, Right : List) return Boolean is
56
      L : Node_Access;
57
      R : Node_Access;
58
 
59
   begin
60
      if Left'Address = Right'Address then
61
         return True;
62
      end if;
63
 
64
      if Left.Length /= Right.Length then
65
         return False;
66
      end if;
67
 
68
      L := Left.First;
69
      R := Right.First;
70
      for J in 1 .. Left.Length loop
71
         if L.Element.all /= R.Element.all then
72
            return False;
73
         end if;
74
 
75
         L := L.Next;
76
         R := R.Next;
77
      end loop;
78
 
79
      return True;
80
   end "=";
81
 
82
   ------------
83
   -- Adjust --
84
   ------------
85
 
86
   procedure Adjust (Container : in out List) is
87
      Src : Node_Access := Container.First;
88
      Dst : Node_Access;
89
 
90
   begin
91
      if Src = null then
92
         pragma Assert (Container.Last = null);
93
         pragma Assert (Container.Length = 0);
94
         pragma Assert (Container.Busy = 0);
95
         pragma Assert (Container.Lock = 0);
96
         return;
97
      end if;
98
 
99
      pragma Assert (Container.First.Prev = null);
100
      pragma Assert (Container.Last.Next = null);
101
      pragma Assert (Container.Length > 0);
102
 
103
      Container.First := null;
104
      Container.Last := null;
105
      Container.Length := 0;
106
      Container.Busy := 0;
107
      Container.Lock := 0;
108
 
109
      declare
110
         Element : Element_Access := new Element_Type'(Src.Element.all);
111
      begin
112
         Dst := new Node_Type'(Element, null, null);
113
      exception
114
         when others =>
115
            Free (Element);
116
            raise;
117
      end;
118
 
119
      Container.First := Dst;
120
      Container.Last := Dst;
121
      Container.Length := 1;
122
 
123
      Src := Src.Next;
124
      while Src /= null loop
125
         declare
126
            Element : Element_Access := new Element_Type'(Src.Element.all);
127
         begin
128
            Dst := new Node_Type'(Element, null, Prev => Container.Last);
129
         exception
130
            when others =>
131
               Free (Element);
132
               raise;
133
         end;
134
 
135
         Container.Last.Next := Dst;
136
         Container.Last := Dst;
137
         Container.Length := Container.Length + 1;
138
 
139
         Src := Src.Next;
140
      end loop;
141
   end Adjust;
142
 
143
   ------------
144
   -- Append --
145
   ------------
146
 
147
   procedure Append
148
     (Container : in out List;
149
      New_Item  : Element_Type;
150
      Count     : Count_Type := 1)
151
   is
152
   begin
153
      Insert (Container, No_Element, New_Item, Count);
154
   end Append;
155
 
156
   -----------
157
   -- Clear --
158
   -----------
159
 
160
   procedure Clear (Container : in out List) is
161
      X : Node_Access;
162
      pragma Warnings (Off, X);
163
 
164
   begin
165
      if Container.Length = 0 then
166
         pragma Assert (Container.First = null);
167
         pragma Assert (Container.Last = null);
168
         pragma Assert (Container.Busy = 0);
169
         pragma Assert (Container.Lock = 0);
170
         return;
171
      end if;
172
 
173
      pragma Assert (Container.First.Prev = null);
174
      pragma Assert (Container.Last.Next = null);
175
 
176
      if Container.Busy > 0 then
177
         raise Program_Error with
178
           "attempt to tamper with elements (list is busy)";
179
      end if;
180
 
181
      while Container.Length > 1 loop
182
         X := Container.First;
183
         pragma Assert (X.Next.Prev = Container.First);
184
 
185
         Container.First := X.Next;
186
         Container.First.Prev := null;
187
 
188
         Container.Length := Container.Length - 1;
189
 
190
         Free (X);
191
      end loop;
192
 
193
      X := Container.First;
194
      pragma Assert (X = Container.Last);
195
 
196
      Container.First := null;
197
      Container.Last := null;
198
      Container.Length := 0;
199
 
200
      Free (X);
201
   end Clear;
202
 
203
   --------------
204
   -- Contains --
205
   --------------
206
 
207
   function Contains
208
     (Container : List;
209
      Item      : Element_Type) return Boolean
210
   is
211
   begin
212
      return Find (Container, Item) /= No_Element;
213
   end Contains;
214
 
215
   ------------
216
   -- Delete --
217
   ------------
218
 
219
   procedure Delete
220
     (Container : in out List;
221
      Position  : in out Cursor;
222
      Count     : Count_Type := 1)
223
   is
224
      X : Node_Access;
225
 
226
   begin
227
      if Position.Node = null then
228
         raise Constraint_Error with
229
           "Position cursor has no element";
230
      end if;
231
 
232
      if Position.Node.Element = null then
233
         raise Program_Error with
234
           "Position cursor has no element";
235
      end if;
236
 
237
      if Position.Container /= Container'Unrestricted_Access then
238
         raise Program_Error with
239
           "Position cursor designates wrong container";
240
      end if;
241
 
242
      pragma Assert (Vet (Position), "bad cursor in Delete");
243
 
244
      if Position.Node = Container.First then
245
         Delete_First (Container, Count);
246
         Position := No_Element;  --  Post-York behavior
247
         return;
248
      end if;
249
 
250
      if Count = 0 then
251
         Position := No_Element;  --  Post-York behavior
252
         return;
253
      end if;
254
 
255
      if Container.Busy > 0 then
256
         raise Program_Error with
257
           "attempt to tamper with elements (list is busy)";
258
      end if;
259
 
260
      for Index in 1 .. Count loop
261
         X := Position.Node;
262
         Container.Length := Container.Length - 1;
263
 
264
         if X = Container.Last then
265
            Position := No_Element;
266
 
267
            Container.Last := X.Prev;
268
            Container.Last.Next := null;
269
 
270
            Free (X);
271
            return;
272
         end if;
273
 
274
         Position.Node := X.Next;
275
 
276
         X.Next.Prev := X.Prev;
277
         X.Prev.Next := X.Next;
278
 
279
         Free (X);
280
      end loop;
281
 
282
      Position := No_Element;  --  Post-York behavior
283
   end Delete;
284
 
285
   ------------------
286
   -- Delete_First --
287
   ------------------
288
 
289
   procedure Delete_First
290
     (Container : in out List;
291
      Count     : Count_Type := 1)
292
   is
293
      X : Node_Access;
294
 
295
   begin
296
      if Count >= Container.Length then
297
         Clear (Container);
298
         return;
299
      end if;
300
 
301
      if Count = 0 then
302
         return;
303
      end if;
304
 
305
      if Container.Busy > 0 then
306
         raise Program_Error with
307
           "attempt to tamper with elements (list is busy)";
308
      end if;
309
 
310
      for I in 1 .. Count loop
311
         X := Container.First;
312
         pragma Assert (X.Next.Prev = Container.First);
313
 
314
         Container.First := X.Next;
315
         Container.First.Prev := null;
316
 
317
         Container.Length := Container.Length - 1;
318
 
319
         Free (X);
320
      end loop;
321
   end Delete_First;
322
 
323
   -----------------
324
   -- Delete_Last --
325
   -----------------
326
 
327
   procedure Delete_Last
328
     (Container : in out List;
329
      Count     : Count_Type := 1)
330
   is
331
      X : Node_Access;
332
 
333
   begin
334
      if Count >= Container.Length then
335
         Clear (Container);
336
         return;
337
      end if;
338
 
339
      if Count = 0 then
340
         return;
341
      end if;
342
 
343
      if Container.Busy > 0 then
344
         raise Program_Error with
345
           "attempt to tamper with elements (list is busy)";
346
      end if;
347
 
348
      for I in 1 .. Count loop
349
         X := Container.Last;
350
         pragma Assert (X.Prev.Next = Container.Last);
351
 
352
         Container.Last := X.Prev;
353
         Container.Last.Next := null;
354
 
355
         Container.Length := Container.Length - 1;
356
 
357
         Free (X);
358
      end loop;
359
   end Delete_Last;
360
 
361
   -------------
362
   -- Element --
363
   -------------
364
 
365
   function Element (Position : Cursor) return Element_Type is
366
   begin
367
      if Position.Node = null then
368
         raise Constraint_Error with
369
           "Position cursor has no element";
370
      end if;
371
 
372
      if Position.Node.Element = null then
373
         raise Program_Error with
374
           "Position cursor has no element";
375
      end if;
376
 
377
      pragma Assert (Vet (Position), "bad cursor in Element");
378
 
379
      return Position.Node.Element.all;
380
   end Element;
381
 
382
   ----------
383
   -- Find --
384
   ----------
385
 
386
   function Find
387
     (Container : List;
388
      Item      : Element_Type;
389
      Position  : Cursor := No_Element) return Cursor
390
   is
391
      Node : Node_Access := Position.Node;
392
 
393
   begin
394
      if Node = null then
395
         Node := Container.First;
396
 
397
      else
398
         if Node.Element = null then
399
            raise Program_Error;
400
         end if;
401
 
402
         if Position.Container /= Container'Unrestricted_Access then
403
            raise Program_Error with
404
              "Position cursor designates wrong container";
405
         end if;
406
 
407
         pragma Assert (Vet (Position), "bad cursor in Find");
408
      end if;
409
 
410
      while Node /= null loop
411
         if Node.Element.all = Item then
412
            return Cursor'(Container'Unchecked_Access, Node);
413
         end if;
414
 
415
         Node := Node.Next;
416
      end loop;
417
 
418
      return No_Element;
419
   end Find;
420
 
421
   -----------
422
   -- First --
423
   -----------
424
 
425
   function First (Container : List) return Cursor is
426
   begin
427
      if Container.First = null then
428
         return No_Element;
429
      end if;
430
 
431
      return Cursor'(Container'Unchecked_Access, Container.First);
432
   end First;
433
 
434
   -------------------
435
   -- First_Element --
436
   -------------------
437
 
438
   function First_Element (Container : List) return Element_Type is
439
   begin
440
      if Container.First = null then
441
         raise Constraint_Error with "list is empty";
442
      end if;
443
 
444
      return Container.First.Element.all;
445
   end First_Element;
446
 
447
   ----------
448
   -- Free --
449
   ----------
450
 
451
   procedure Free (X : in out Node_Access) is
452
      procedure Deallocate is
453
         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
454
 
455
   begin
456
      X.Next := X;
457
      X.Prev := X;
458
 
459
      begin
460
         Free (X.Element);
461
      exception
462
         when others =>
463
            X.Element := null;
464
            Deallocate (X);
465
            raise;
466
      end;
467
 
468
      Deallocate (X);
469
   end Free;
470
 
471
   ---------------------
472
   -- Generic_Sorting --
473
   ---------------------
474
 
475
   package body Generic_Sorting is
476
 
477
      ---------------
478
      -- Is_Sorted --
479
      ---------------
480
 
481
      function Is_Sorted (Container : List) return Boolean is
482
         Node : Node_Access := Container.First;
483
 
484
      begin
485
         for I in 2 .. Container.Length loop
486
            if Node.Next.Element.all < Node.Element.all then
487
               return False;
488
            end if;
489
 
490
            Node := Node.Next;
491
         end loop;
492
 
493
         return True;
494
      end Is_Sorted;
495
 
496
      -----------
497
      -- Merge --
498
      -----------
499
 
500
      procedure Merge
501
        (Target : in out List;
502
         Source : in out List)
503
      is
504
         LI, RI : Cursor;
505
 
506
      begin
507
         if Target'Address = Source'Address then
508
            return;
509
         end if;
510
 
511
         if Target.Busy > 0 then
512
            raise Program_Error with
513
              "attempt to tamper with elements of Target (list is busy)";
514
         end if;
515
 
516
         if Source.Busy > 0 then
517
            raise Program_Error with
518
              "attempt to tamper with elements of Source (list is busy)";
519
         end if;
520
 
521
         LI := First (Target);
522
         RI := First (Source);
523
         while RI.Node /= null loop
524
            pragma Assert (RI.Node.Next = null
525
                             or else not (RI.Node.Next.Element.all <
526
                                          RI.Node.Element.all));
527
 
528
            if LI.Node = null then
529
               Splice (Target, No_Element, Source);
530
               return;
531
            end if;
532
 
533
            pragma Assert (LI.Node.Next = null
534
                             or else not (LI.Node.Next.Element.all <
535
                                          LI.Node.Element.all));
536
 
537
            if RI.Node.Element.all < LI.Node.Element.all then
538
               declare
539
                  RJ : Cursor := RI;
540
                  pragma Warnings (Off, RJ);
541
               begin
542
                  RI.Node := RI.Node.Next;
543
                  Splice (Target, LI, Source, RJ);
544
               end;
545
 
546
            else
547
               LI.Node := LI.Node.Next;
548
            end if;
549
         end loop;
550
      end Merge;
551
 
552
      ----------
553
      -- Sort --
554
      ----------
555
 
556
      procedure Sort (Container : in out List) is
557
         procedure Partition (Pivot : Node_Access; Back  : Node_Access);
558
 
559
         procedure Sort (Front, Back : Node_Access);
560
 
561
         ---------------
562
         -- Partition --
563
         ---------------
564
 
565
         procedure Partition (Pivot : Node_Access; Back : Node_Access) is
566
            Node : Node_Access := Pivot.Next;
567
 
568
         begin
569
            while Node /= Back loop
570
               if Node.Element.all < Pivot.Element.all then
571
                  declare
572
                     Prev : constant Node_Access := Node.Prev;
573
                     Next : constant Node_Access := Node.Next;
574
                  begin
575
                     Prev.Next := Next;
576
 
577
                     if Next = null then
578
                        Container.Last := Prev;
579
                     else
580
                        Next.Prev := Prev;
581
                     end if;
582
 
583
                     Node.Next := Pivot;
584
                     Node.Prev := Pivot.Prev;
585
 
586
                     Pivot.Prev := Node;
587
 
588
                     if Node.Prev = null then
589
                        Container.First := Node;
590
                     else
591
                        Node.Prev.Next := Node;
592
                     end if;
593
 
594
                     Node := Next;
595
                  end;
596
 
597
               else
598
                  Node := Node.Next;
599
               end if;
600
            end loop;
601
         end Partition;
602
 
603
         ----------
604
         -- Sort --
605
         ----------
606
 
607
         procedure Sort (Front, Back : Node_Access) is
608
            Pivot : constant Node_Access :=
609
                      (if Front = null then Container.First else Front.Next);
610
         begin
611
            if Pivot /= Back then
612
               Partition (Pivot, Back);
613
               Sort (Front, Pivot);
614
               Sort (Pivot, Back);
615
            end if;
616
         end Sort;
617
 
618
      --  Start of processing for Sort
619
 
620
      begin
621
         if Container.Length <= 1 then
622
            return;
623
         end if;
624
 
625
         pragma Assert (Container.First.Prev = null);
626
         pragma Assert (Container.Last.Next = null);
627
 
628
         if Container.Busy > 0 then
629
            raise Program_Error with
630
              "attempt to tamper with elements (list is busy)";
631
         end if;
632
 
633
         Sort (Front => null, Back => null);
634
 
635
         pragma Assert (Container.First.Prev = null);
636
         pragma Assert (Container.Last.Next = null);
637
      end Sort;
638
 
639
   end Generic_Sorting;
640
 
641
   -----------------
642
   -- Has_Element --
643
   -----------------
644
 
645
   function Has_Element (Position : Cursor) return Boolean is
646
   begin
647
      pragma Assert (Vet (Position), "bad cursor in Has_Element");
648
      return Position.Node /= null;
649
   end Has_Element;
650
 
651
   ------------
652
   -- Insert --
653
   ------------
654
 
655
   procedure Insert
656
     (Container : in out List;
657
      Before    : Cursor;
658
      New_Item  : Element_Type;
659
      Position  : out Cursor;
660
      Count     : Count_Type := 1)
661
   is
662
      New_Node : Node_Access;
663
 
664
   begin
665
      if Before.Container /= null then
666
         if Before.Container /= Container'Unrestricted_Access then
667
            raise Program_Error with
668
              "attempt to tamper with elements (list is busy)";
669
         end if;
670
 
671
         if Before.Node = null
672
           or else Before.Node.Element = null
673
         then
674
            raise Program_Error with
675
              "Before cursor has no element";
676
         end if;
677
 
678
         pragma Assert (Vet (Before), "bad cursor in Insert");
679
      end if;
680
 
681
      if Count = 0 then
682
         Position := Before;
683
         return;
684
      end if;
685
 
686
      if Container.Length > Count_Type'Last - Count then
687
         raise Constraint_Error with "new length exceeds maximum";
688
      end if;
689
 
690
      if Container.Busy > 0 then
691
         raise Program_Error with
692
           "attempt to tamper with elements (list is busy)";
693
      end if;
694
 
695
      declare
696
         Element : Element_Access := new Element_Type'(New_Item);
697
      begin
698
         New_Node := new Node_Type'(Element, null, null);
699
      exception
700
         when others =>
701
            Free (Element);
702
            raise;
703
      end;
704
 
705
      Insert_Internal (Container, Before.Node, New_Node);
706
      Position := Cursor'(Container'Unchecked_Access, New_Node);
707
 
708
      for J in Count_Type'(2) .. Count loop
709
 
710
         declare
711
            Element : Element_Access := new Element_Type'(New_Item);
712
         begin
713
            New_Node := new Node_Type'(Element, null, null);
714
         exception
715
            when others =>
716
               Free (Element);
717
               raise;
718
         end;
719
 
720
         Insert_Internal (Container, Before.Node, New_Node);
721
      end loop;
722
   end Insert;
723
 
724
   procedure Insert
725
     (Container : in out List;
726
      Before    : Cursor;
727
      New_Item  : Element_Type;
728
      Count     : Count_Type := 1)
729
   is
730
      Position : Cursor;
731
      pragma Unreferenced (Position);
732
   begin
733
      Insert (Container, Before, New_Item, Position, Count);
734
   end Insert;
735
 
736
   ---------------------
737
   -- Insert_Internal --
738
   ---------------------
739
 
740
   procedure Insert_Internal
741
     (Container : in out List;
742
      Before    : Node_Access;
743
      New_Node  : Node_Access)
744
   is
745
   begin
746
      if Container.Length = 0 then
747
         pragma Assert (Before = null);
748
         pragma Assert (Container.First = null);
749
         pragma Assert (Container.Last = null);
750
 
751
         Container.First := New_Node;
752
         Container.Last := New_Node;
753
 
754
      elsif Before = null then
755
         pragma Assert (Container.Last.Next = null);
756
 
757
         Container.Last.Next := New_Node;
758
         New_Node.Prev := Container.Last;
759
 
760
         Container.Last := New_Node;
761
 
762
      elsif Before = Container.First then
763
         pragma Assert (Container.First.Prev = null);
764
 
765
         Container.First.Prev := New_Node;
766
         New_Node.Next := Container.First;
767
 
768
         Container.First := New_Node;
769
 
770
      else
771
         pragma Assert (Container.First.Prev = null);
772
         pragma Assert (Container.Last.Next = null);
773
 
774
         New_Node.Next := Before;
775
         New_Node.Prev := Before.Prev;
776
 
777
         Before.Prev.Next := New_Node;
778
         Before.Prev := New_Node;
779
      end if;
780
 
781
      Container.Length := Container.Length + 1;
782
   end Insert_Internal;
783
 
784
   --------------
785
   -- Is_Empty --
786
   --------------
787
 
788
   function Is_Empty (Container : List) return Boolean is
789
   begin
790
      return Container.Length = 0;
791
   end Is_Empty;
792
 
793
   -------------
794
   -- Iterate --
795
   -------------
796
 
797
   procedure Iterate
798
     (Container : List;
799
      Process   : not null access procedure (Position : Cursor))
800
   is
801
      C : List renames Container'Unrestricted_Access.all;
802
      B : Natural renames C.Busy;
803
 
804
      Node : Node_Access := Container.First;
805
 
806
   begin
807
      B := B + 1;
808
 
809
      begin
810
         while Node /= null loop
811
            Process (Cursor'(Container'Unchecked_Access, Node));
812
            Node := Node.Next;
813
         end loop;
814
      exception
815
         when others =>
816
            B := B - 1;
817
            raise;
818
      end;
819
 
820
      B := B - 1;
821
   end Iterate;
822
 
823
   ----------
824
   -- Last --
825
   ----------
826
 
827
   function Last (Container : List) return Cursor is
828
   begin
829
      if Container.Last = null then
830
         return No_Element;
831
      end if;
832
 
833
      return Cursor'(Container'Unchecked_Access, Container.Last);
834
   end Last;
835
 
836
   ------------------
837
   -- Last_Element --
838
   ------------------
839
 
840
   function Last_Element (Container : List) return Element_Type is
841
   begin
842
      if Container.Last = null then
843
         raise Constraint_Error with "list is empty";
844
      end if;
845
 
846
      return Container.Last.Element.all;
847
   end Last_Element;
848
 
849
   ------------
850
   -- Length --
851
   ------------
852
 
853
   function Length (Container : List) return Count_Type is
854
   begin
855
      return Container.Length;
856
   end Length;
857
 
858
   ----------
859
   -- Move --
860
   ----------
861
 
862
   procedure Move (Target : in out List; Source : in out List) is
863
   begin
864
      if Target'Address = Source'Address then
865
         return;
866
      end if;
867
 
868
      if Source.Busy > 0 then
869
         raise Program_Error with
870
           "attempt to tamper with elements of Source (list is busy)";
871
      end if;
872
 
873
      Clear (Target);
874
 
875
      Target.First := Source.First;
876
      Source.First := null;
877
 
878
      Target.Last := Source.Last;
879
      Source.Last := null;
880
 
881
      Target.Length := Source.Length;
882
      Source.Length := 0;
883
   end Move;
884
 
885
   ----------
886
   -- Next --
887
   ----------
888
 
889
   procedure Next (Position : in out Cursor) is
890
   begin
891
      Position := Next (Position);
892
   end Next;
893
 
894
   function Next (Position : Cursor) return Cursor is
895
   begin
896
      if Position.Node = null then
897
         return No_Element;
898
      end if;
899
 
900
      pragma Assert (Vet (Position), "bad cursor in Next");
901
 
902
      declare
903
         Next_Node : constant Node_Access := Position.Node.Next;
904
      begin
905
         if Next_Node = null then
906
            return No_Element;
907
         end if;
908
 
909
         return Cursor'(Position.Container, Next_Node);
910
      end;
911
   end Next;
912
 
913
   -------------
914
   -- Prepend --
915
   -------------
916
 
917
   procedure Prepend
918
     (Container : in out List;
919
      New_Item  : Element_Type;
920
      Count     : Count_Type := 1)
921
   is
922
   begin
923
      Insert (Container, First (Container), New_Item, Count);
924
   end Prepend;
925
 
926
   --------------
927
   -- Previous --
928
   --------------
929
 
930
   procedure Previous (Position : in out Cursor) is
931
   begin
932
      Position := Previous (Position);
933
   end Previous;
934
 
935
   function Previous (Position : Cursor) return Cursor is
936
   begin
937
      if Position.Node = null then
938
         return No_Element;
939
      end if;
940
 
941
      pragma Assert (Vet (Position), "bad cursor in Previous");
942
 
943
      declare
944
         Prev_Node : constant Node_Access := Position.Node.Prev;
945
      begin
946
         if Prev_Node = null then
947
            return No_Element;
948
         end if;
949
 
950
         return Cursor'(Position.Container, Prev_Node);
951
      end;
952
   end Previous;
953
 
954
   -------------------
955
   -- Query_Element --
956
   -------------------
957
 
958
   procedure Query_Element
959
     (Position : Cursor;
960
      Process  : not null access procedure (Element : Element_Type))
961
   is
962
   begin
963
      if Position.Node = null then
964
         raise Constraint_Error with
965
           "Position cursor has no element";
966
      end if;
967
 
968
      if Position.Node.Element = null then
969
         raise Program_Error with
970
           "Position cursor has no element";
971
      end if;
972
 
973
      pragma Assert (Vet (Position), "bad cursor in Query_Element");
974
 
975
      declare
976
         C : List renames Position.Container.all'Unrestricted_Access.all;
977
         B : Natural renames C.Busy;
978
         L : Natural renames C.Lock;
979
 
980
      begin
981
         B := B + 1;
982
         L := L + 1;
983
 
984
         begin
985
            Process (Position.Node.Element.all);
986
         exception
987
            when others =>
988
               L := L - 1;
989
               B := B - 1;
990
               raise;
991
         end;
992
 
993
         L := L - 1;
994
         B := B - 1;
995
      end;
996
   end Query_Element;
997
 
998
   ----------
999
   -- Read --
1000
   ----------
1001
 
1002
   procedure Read
1003
     (Stream : not null access Root_Stream_Type'Class;
1004
      Item   : out List)
1005
   is
1006
      N   : Count_Type'Base;
1007
      Dst : Node_Access;
1008
 
1009
   begin
1010
      Clear (Item);
1011
 
1012
      Count_Type'Base'Read (Stream, N);
1013
 
1014
      if N = 0 then
1015
         return;
1016
      end if;
1017
 
1018
      declare
1019
         Element : Element_Access :=
1020
                     new Element_Type'(Element_Type'Input (Stream));
1021
      begin
1022
         Dst := new Node_Type'(Element, null, null);
1023
      exception
1024
         when others =>
1025
            Free (Element);
1026
            raise;
1027
      end;
1028
 
1029
      Item.First := Dst;
1030
      Item.Last := Dst;
1031
      Item.Length := 1;
1032
 
1033
      while Item.Length < N loop
1034
         declare
1035
            Element : Element_Access :=
1036
                        new Element_Type'(Element_Type'Input (Stream));
1037
         begin
1038
            Dst := new Node_Type'(Element, Next => null, Prev => Item.Last);
1039
         exception
1040
            when others =>
1041
               Free (Element);
1042
               raise;
1043
         end;
1044
 
1045
         Item.Last.Next := Dst;
1046
         Item.Last := Dst;
1047
         Item.Length := Item.Length + 1;
1048
      end loop;
1049
   end Read;
1050
 
1051
   procedure Read
1052
     (Stream : not null access Root_Stream_Type'Class;
1053
      Item   : out Cursor)
1054
   is
1055
   begin
1056
      raise Program_Error with "attempt to stream list cursor";
1057
   end Read;
1058
 
1059
   ---------------------
1060
   -- Replace_Element --
1061
   ---------------------
1062
 
1063
   procedure Replace_Element
1064
     (Container : in out List;
1065
      Position  : Cursor;
1066
      New_Item  : Element_Type)
1067
   is
1068
   begin
1069
      if Position.Container = null then
1070
         raise Constraint_Error with "Position cursor has no element";
1071
      end if;
1072
 
1073
      if Position.Container /= Container'Unchecked_Access then
1074
         raise Program_Error with
1075
           "Position cursor designates wrong container";
1076
      end if;
1077
 
1078
      if Container.Lock > 0 then
1079
         raise Program_Error with
1080
           "attempt to tamper with cursors (list is locked)";
1081
      end if;
1082
 
1083
      if Position.Node.Element = null then
1084
         raise Program_Error with
1085
           "Position cursor has no element";
1086
      end if;
1087
 
1088
      pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1089
 
1090
      declare
1091
         X : Element_Access := Position.Node.Element;
1092
 
1093
      begin
1094
         Position.Node.Element := new Element_Type'(New_Item);
1095
         Free (X);
1096
      end;
1097
   end Replace_Element;
1098
 
1099
   ----------------------
1100
   -- Reverse_Elements --
1101
   ----------------------
1102
 
1103
   procedure Reverse_Elements (Container : in out List) is
1104
      I : Node_Access := Container.First;
1105
      J : Node_Access := Container.Last;
1106
 
1107
      procedure Swap (L, R : Node_Access);
1108
 
1109
      ----------
1110
      -- Swap --
1111
      ----------
1112
 
1113
      procedure Swap (L, R : Node_Access) is
1114
         LN : constant Node_Access := L.Next;
1115
         LP : constant Node_Access := L.Prev;
1116
 
1117
         RN : constant Node_Access := R.Next;
1118
         RP : constant Node_Access := R.Prev;
1119
 
1120
      begin
1121
         if LP /= null then
1122
            LP.Next := R;
1123
         end if;
1124
 
1125
         if RN /= null then
1126
            RN.Prev := L;
1127
         end if;
1128
 
1129
         L.Next := RN;
1130
         R.Prev := LP;
1131
 
1132
         if LN = R then
1133
            pragma Assert (RP = L);
1134
 
1135
            L.Prev := R;
1136
            R.Next := L;
1137
 
1138
         else
1139
            L.Prev := RP;
1140
            RP.Next := L;
1141
 
1142
            R.Next := LN;
1143
            LN.Prev := R;
1144
         end if;
1145
      end Swap;
1146
 
1147
   --  Start of processing for Reverse_Elements
1148
 
1149
   begin
1150
      if Container.Length <= 1 then
1151
         return;
1152
      end if;
1153
 
1154
      pragma Assert (Container.First.Prev = null);
1155
      pragma Assert (Container.Last.Next = null);
1156
 
1157
      if Container.Busy > 0 then
1158
         raise Program_Error with
1159
           "attempt to tamper with elements (list is busy)";
1160
      end if;
1161
 
1162
      Container.First := J;
1163
      Container.Last := I;
1164
      loop
1165
         Swap (L => I, R => J);
1166
 
1167
         J := J.Next;
1168
         exit when I = J;
1169
 
1170
         I := I.Prev;
1171
         exit when I = J;
1172
 
1173
         Swap (L => J, R => I);
1174
 
1175
         I := I.Next;
1176
         exit when I = J;
1177
 
1178
         J := J.Prev;
1179
         exit when I = J;
1180
      end loop;
1181
 
1182
      pragma Assert (Container.First.Prev = null);
1183
      pragma Assert (Container.Last.Next = null);
1184
   end Reverse_Elements;
1185
 
1186
   ------------------
1187
   -- Reverse_Find --
1188
   ------------------
1189
 
1190
   function Reverse_Find
1191
     (Container : List;
1192
      Item      : Element_Type;
1193
      Position  : Cursor := No_Element) return Cursor
1194
   is
1195
      Node : Node_Access := Position.Node;
1196
 
1197
   begin
1198
      if Node = null then
1199
         Node := Container.Last;
1200
 
1201
      else
1202
         if Node.Element = null then
1203
            raise Program_Error with "Position cursor has no element";
1204
         end if;
1205
 
1206
         if Position.Container /= Container'Unrestricted_Access then
1207
            raise Program_Error with
1208
              "Position cursor designates wrong container";
1209
         end if;
1210
 
1211
         pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1212
      end if;
1213
 
1214
      while Node /= null loop
1215
         if Node.Element.all = Item then
1216
            return Cursor'(Container'Unchecked_Access, Node);
1217
         end if;
1218
 
1219
         Node := Node.Prev;
1220
      end loop;
1221
 
1222
      return No_Element;
1223
   end Reverse_Find;
1224
 
1225
   ---------------------
1226
   -- Reverse_Iterate --
1227
   ---------------------
1228
 
1229
   procedure Reverse_Iterate
1230
     (Container : List;
1231
      Process   : not null access procedure (Position : Cursor))
1232
   is
1233
      C : List renames Container'Unrestricted_Access.all;
1234
      B : Natural renames C.Busy;
1235
 
1236
      Node : Node_Access := Container.Last;
1237
 
1238
   begin
1239
      B := B + 1;
1240
 
1241
      begin
1242
         while Node /= null loop
1243
            Process (Cursor'(Container'Unchecked_Access, Node));
1244
            Node := Node.Prev;
1245
         end loop;
1246
      exception
1247
         when others =>
1248
            B := B - 1;
1249
            raise;
1250
      end;
1251
 
1252
      B := B - 1;
1253
   end Reverse_Iterate;
1254
 
1255
   ------------
1256
   -- Splice --
1257
   ------------
1258
 
1259
   procedure Splice
1260
     (Target : in out List;
1261
      Before : Cursor;
1262
      Source : in out List)
1263
   is
1264
   begin
1265
      if Before.Container /= null then
1266
         if Before.Container /= Target'Unrestricted_Access then
1267
            raise Program_Error with
1268
              "Before cursor designates wrong container";
1269
         end if;
1270
 
1271
         if Before.Node = null
1272
           or else Before.Node.Element = null
1273
         then
1274
            raise Program_Error with
1275
              "Before cursor has no element";
1276
         end if;
1277
 
1278
         pragma Assert (Vet (Before), "bad cursor in Splice");
1279
      end if;
1280
 
1281
      if Target'Address = Source'Address
1282
        or else Source.Length = 0
1283
      then
1284
         return;
1285
      end if;
1286
 
1287
      pragma Assert (Source.First.Prev = null);
1288
      pragma Assert (Source.Last.Next = null);
1289
 
1290
      if Target.Length > Count_Type'Last - Source.Length then
1291
         raise Constraint_Error with "new length exceeds maximum";
1292
      end if;
1293
 
1294
      if Target.Busy > 0 then
1295
         raise Program_Error with
1296
           "attempt to tamper with elements of Target (list is busy)";
1297
      end if;
1298
 
1299
      if Source.Busy > 0 then
1300
         raise Program_Error with
1301
           "attempt to tamper with elements of Source (list is busy)";
1302
      end if;
1303
 
1304
      if Target.Length = 0 then
1305
         pragma Assert (Before = No_Element);
1306
         pragma Assert (Target.First = null);
1307
         pragma Assert (Target.Last = null);
1308
 
1309
         Target.First := Source.First;
1310
         Target.Last := Source.Last;
1311
 
1312
      elsif Before.Node = null then
1313
         pragma Assert (Target.Last.Next = null);
1314
 
1315
         Target.Last.Next := Source.First;
1316
         Source.First.Prev := Target.Last;
1317
 
1318
         Target.Last := Source.Last;
1319
 
1320
      elsif Before.Node = Target.First then
1321
         pragma Assert (Target.First.Prev = null);
1322
 
1323
         Source.Last.Next := Target.First;
1324
         Target.First.Prev := Source.Last;
1325
 
1326
         Target.First := Source.First;
1327
 
1328
      else
1329
         pragma Assert (Target.Length >= 2);
1330
         Before.Node.Prev.Next := Source.First;
1331
         Source.First.Prev := Before.Node.Prev;
1332
 
1333
         Before.Node.Prev := Source.Last;
1334
         Source.Last.Next := Before.Node;
1335
      end if;
1336
 
1337
      Source.First := null;
1338
      Source.Last := null;
1339
 
1340
      Target.Length := Target.Length + Source.Length;
1341
      Source.Length := 0;
1342
   end Splice;
1343
 
1344
   procedure Splice
1345
     (Container : in out List;
1346
      Before    : Cursor;
1347
      Position  : Cursor)
1348
   is
1349
   begin
1350
      if Before.Container /= null then
1351
         if Before.Container /= Container'Unchecked_Access then
1352
            raise Program_Error with
1353
              "Before cursor designates wrong container";
1354
         end if;
1355
 
1356
         if Before.Node = null
1357
           or else Before.Node.Element = null
1358
         then
1359
            raise Program_Error with
1360
              "Before cursor has no element";
1361
         end if;
1362
 
1363
         pragma Assert (Vet (Before), "bad Before cursor in Splice");
1364
      end if;
1365
 
1366
      if Position.Node = null then
1367
         raise Constraint_Error with "Position cursor has no element";
1368
      end if;
1369
 
1370
      if Position.Node.Element = null then
1371
         raise Program_Error with "Position cursor has no element";
1372
      end if;
1373
 
1374
      if Position.Container /= Container'Unrestricted_Access then
1375
         raise Program_Error with
1376
           "Position cursor designates wrong container";
1377
      end if;
1378
 
1379
      pragma Assert (Vet (Position), "bad Position cursor in Splice");
1380
 
1381
      if Position.Node = Before.Node
1382
        or else Position.Node.Next = Before.Node
1383
      then
1384
         return;
1385
      end if;
1386
 
1387
      pragma Assert (Container.Length >= 2);
1388
 
1389
      if Container.Busy > 0 then
1390
         raise Program_Error with
1391
           "attempt to tamper with elements (list is busy)";
1392
      end if;
1393
 
1394
      if Before.Node = null then
1395
         pragma Assert (Position.Node /= Container.Last);
1396
 
1397
         if Position.Node = Container.First then
1398
            Container.First := Position.Node.Next;
1399
            Container.First.Prev := null;
1400
         else
1401
            Position.Node.Prev.Next := Position.Node.Next;
1402
            Position.Node.Next.Prev := Position.Node.Prev;
1403
         end if;
1404
 
1405
         Container.Last.Next := Position.Node;
1406
         Position.Node.Prev := Container.Last;
1407
 
1408
         Container.Last := Position.Node;
1409
         Container.Last.Next := null;
1410
 
1411
         return;
1412
      end if;
1413
 
1414
      if Before.Node = Container.First then
1415
         pragma Assert (Position.Node /= Container.First);
1416
 
1417
         if Position.Node = Container.Last then
1418
            Container.Last := Position.Node.Prev;
1419
            Container.Last.Next := null;
1420
         else
1421
            Position.Node.Prev.Next := Position.Node.Next;
1422
            Position.Node.Next.Prev := Position.Node.Prev;
1423
         end if;
1424
 
1425
         Container.First.Prev := Position.Node;
1426
         Position.Node.Next := Container.First;
1427
 
1428
         Container.First := Position.Node;
1429
         Container.First.Prev := null;
1430
 
1431
         return;
1432
      end if;
1433
 
1434
      if Position.Node = Container.First then
1435
         Container.First := Position.Node.Next;
1436
         Container.First.Prev := null;
1437
 
1438
      elsif Position.Node = Container.Last then
1439
         Container.Last := Position.Node.Prev;
1440
         Container.Last.Next := null;
1441
 
1442
      else
1443
         Position.Node.Prev.Next := Position.Node.Next;
1444
         Position.Node.Next.Prev := Position.Node.Prev;
1445
      end if;
1446
 
1447
      Before.Node.Prev.Next := Position.Node;
1448
      Position.Node.Prev := Before.Node.Prev;
1449
 
1450
      Before.Node.Prev := Position.Node;
1451
      Position.Node.Next := Before.Node;
1452
 
1453
      pragma Assert (Container.First.Prev = null);
1454
      pragma Assert (Container.Last.Next = null);
1455
   end Splice;
1456
 
1457
   procedure Splice
1458
     (Target   : in out List;
1459
      Before   : Cursor;
1460
      Source   : in out List;
1461
      Position : in out Cursor)
1462
   is
1463
   begin
1464
      if Target'Address = Source'Address then
1465
         Splice (Target, Before, Position);
1466
         return;
1467
      end if;
1468
 
1469
      if Before.Container /= null then
1470
         if Before.Container /= Target'Unrestricted_Access then
1471
            raise Program_Error with
1472
              "Before cursor designates wrong container";
1473
         end if;
1474
 
1475
         if Before.Node = null
1476
           or else Before.Node.Element = null
1477
         then
1478
            raise Program_Error with
1479
              "Before cursor has no element";
1480
         end if;
1481
 
1482
         pragma Assert (Vet (Before), "bad Before cursor in Splice");
1483
      end if;
1484
 
1485
      if Position.Node = null then
1486
         raise Constraint_Error with "Position cursor has no element";
1487
      end if;
1488
 
1489
      if Position.Node.Element = null then
1490
         raise Program_Error with
1491
           "Position cursor has no element";
1492
      end if;
1493
 
1494
      if Position.Container /= Source'Unrestricted_Access then
1495
         raise Program_Error with
1496
           "Position cursor designates wrong container";
1497
      end if;
1498
 
1499
      pragma Assert (Vet (Position), "bad Position cursor in Splice");
1500
 
1501
      if Target.Length = Count_Type'Last then
1502
         raise Constraint_Error with "Target is full";
1503
      end if;
1504
 
1505
      if Target.Busy > 0 then
1506
         raise Program_Error with
1507
           "attempt to tamper with elements of Target (list is busy)";
1508
      end if;
1509
 
1510
      if Source.Busy > 0 then
1511
         raise Program_Error with
1512
           "attempt to tamper with elements of Source (list is busy)";
1513
      end if;
1514
 
1515
      if Position.Node = Source.First then
1516
         Source.First := Position.Node.Next;
1517
 
1518
         if Position.Node = Source.Last then
1519
            pragma Assert (Source.First = null);
1520
            pragma Assert (Source.Length = 1);
1521
            Source.Last := null;
1522
 
1523
         else
1524
            Source.First.Prev := null;
1525
         end if;
1526
 
1527
      elsif Position.Node = Source.Last then
1528
         pragma Assert (Source.Length >= 2);
1529
         Source.Last := Position.Node.Prev;
1530
         Source.Last.Next := null;
1531
 
1532
      else
1533
         pragma Assert (Source.Length >= 3);
1534
         Position.Node.Prev.Next := Position.Node.Next;
1535
         Position.Node.Next.Prev := Position.Node.Prev;
1536
      end if;
1537
 
1538
      if Target.Length = 0 then
1539
         pragma Assert (Before = No_Element);
1540
         pragma Assert (Target.First = null);
1541
         pragma Assert (Target.Last = null);
1542
 
1543
         Target.First := Position.Node;
1544
         Target.Last := Position.Node;
1545
 
1546
         Target.First.Prev := null;
1547
         Target.Last.Next := null;
1548
 
1549
      elsif Before.Node = null then
1550
         pragma Assert (Target.Last.Next = null);
1551
         Target.Last.Next := Position.Node;
1552
         Position.Node.Prev := Target.Last;
1553
 
1554
         Target.Last := Position.Node;
1555
         Target.Last.Next := null;
1556
 
1557
      elsif Before.Node = Target.First then
1558
         pragma Assert (Target.First.Prev = null);
1559
         Target.First.Prev := Position.Node;
1560
         Position.Node.Next := Target.First;
1561
 
1562
         Target.First := Position.Node;
1563
         Target.First.Prev := null;
1564
 
1565
      else
1566
         pragma Assert (Target.Length >= 2);
1567
         Before.Node.Prev.Next := Position.Node;
1568
         Position.Node.Prev := Before.Node.Prev;
1569
 
1570
         Before.Node.Prev := Position.Node;
1571
         Position.Node.Next := Before.Node;
1572
      end if;
1573
 
1574
      Target.Length := Target.Length + 1;
1575
      Source.Length := Source.Length - 1;
1576
 
1577
      Position.Container := Target'Unchecked_Access;
1578
   end Splice;
1579
 
1580
   ----------
1581
   -- Swap --
1582
   ----------
1583
 
1584
   procedure Swap
1585
     (Container : in out List;
1586
      I, J      : Cursor)
1587
   is
1588
   begin
1589
      if I.Node = null then
1590
         raise Constraint_Error with "I cursor has no element";
1591
      end if;
1592
 
1593
      if J.Node = null then
1594
         raise Constraint_Error with "J cursor has no element";
1595
      end if;
1596
 
1597
      if I.Container /= Container'Unchecked_Access then
1598
         raise Program_Error with "I cursor designates wrong container";
1599
      end if;
1600
 
1601
      if J.Container /= Container'Unchecked_Access then
1602
         raise Program_Error with "J cursor designates wrong container";
1603
      end if;
1604
 
1605
      if I.Node = J.Node then
1606
         return;
1607
      end if;
1608
 
1609
      if Container.Lock > 0 then
1610
         raise Program_Error with
1611
           "attempt to tamper with cursors (list is locked)";
1612
      end if;
1613
 
1614
      pragma Assert (Vet (I), "bad I cursor in Swap");
1615
      pragma Assert (Vet (J), "bad J cursor in Swap");
1616
 
1617
      declare
1618
         EI_Copy : constant Element_Access := I.Node.Element;
1619
 
1620
      begin
1621
         I.Node.Element := J.Node.Element;
1622
         J.Node.Element := EI_Copy;
1623
      end;
1624
   end Swap;
1625
 
1626
   ----------------
1627
   -- Swap_Links --
1628
   ----------------
1629
 
1630
   procedure Swap_Links
1631
     (Container : in out List;
1632
      I, J      : Cursor)
1633
   is
1634
   begin
1635
      if I.Node = null then
1636
         raise Constraint_Error with "I cursor has no element";
1637
      end if;
1638
 
1639
      if J.Node = null then
1640
         raise Constraint_Error with "J cursor has no element";
1641
      end if;
1642
 
1643
      if I.Container /= Container'Unrestricted_Access then
1644
         raise Program_Error with "I cursor designates wrong container";
1645
      end if;
1646
 
1647
      if J.Container /= Container'Unrestricted_Access then
1648
         raise Program_Error with "J cursor designates wrong container";
1649
      end if;
1650
 
1651
      if I.Node = J.Node then
1652
         return;
1653
      end if;
1654
 
1655
      if Container.Busy > 0 then
1656
         raise Program_Error with
1657
           "attempt to tamper with elements (list is busy)";
1658
      end if;
1659
 
1660
      pragma Assert (Vet (I), "bad I cursor in Swap_Links");
1661
      pragma Assert (Vet (J), "bad J cursor in Swap_Links");
1662
 
1663
      declare
1664
         I_Next : constant Cursor := Next (I);
1665
 
1666
      begin
1667
         if I_Next = J then
1668
            Splice (Container, Before => I, Position => J);
1669
 
1670
         else
1671
            declare
1672
               J_Next : constant Cursor := Next (J);
1673
 
1674
            begin
1675
               if J_Next = I then
1676
                  Splice (Container, Before => J, Position => I);
1677
 
1678
               else
1679
                  pragma Assert (Container.Length >= 3);
1680
 
1681
                  Splice (Container, Before => I_Next, Position => J);
1682
                  Splice (Container, Before => J_Next, Position => I);
1683
               end if;
1684
            end;
1685
         end if;
1686
      end;
1687
 
1688
      pragma Assert (Container.First.Prev = null);
1689
      pragma Assert (Container.Last.Next = null);
1690
   end Swap_Links;
1691
 
1692
   --------------------
1693
   -- Update_Element --
1694
   --------------------
1695
 
1696
   procedure Update_Element
1697
     (Container : in out List;
1698
      Position  : Cursor;
1699
      Process   : not null access procedure (Element : in out Element_Type))
1700
   is
1701
   begin
1702
      if Position.Node = null then
1703
         raise Constraint_Error with "Position cursor has no element";
1704
      end if;
1705
 
1706
      if Position.Node.Element = null then
1707
         raise Program_Error with
1708
           "Position cursor has no element";
1709
      end if;
1710
 
1711
      if Position.Container /= Container'Unchecked_Access then
1712
         raise Program_Error with
1713
           "Position cursor designates wrong container";
1714
      end if;
1715
 
1716
      pragma Assert (Vet (Position), "bad cursor in Update_Element");
1717
 
1718
      declare
1719
         B : Natural renames Container.Busy;
1720
         L : Natural renames Container.Lock;
1721
 
1722
      begin
1723
         B := B + 1;
1724
         L := L + 1;
1725
 
1726
         begin
1727
            Process (Position.Node.Element.all);
1728
         exception
1729
            when others =>
1730
               L := L - 1;
1731
               B := B - 1;
1732
               raise;
1733
         end;
1734
 
1735
         L := L - 1;
1736
         B := B - 1;
1737
      end;
1738
   end Update_Element;
1739
 
1740
   ---------
1741
   -- Vet --
1742
   ---------
1743
 
1744
   function Vet (Position : Cursor) return Boolean is
1745
   begin
1746
      if Position.Node = null then
1747
         return Position.Container = null;
1748
      end if;
1749
 
1750
      if Position.Container = null then
1751
         return False;
1752
      end if;
1753
 
1754
      if Position.Node.Next = Position.Node then
1755
         return False;
1756
      end if;
1757
 
1758
      if Position.Node.Prev = Position.Node then
1759
         return False;
1760
      end if;
1761
 
1762
      if Position.Node.Element = null then
1763
         return False;
1764
      end if;
1765
 
1766
      declare
1767
         L : List renames Position.Container.all;
1768
      begin
1769
         if L.Length = 0 then
1770
            return False;
1771
         end if;
1772
 
1773
         if L.First = null then
1774
            return False;
1775
         end if;
1776
 
1777
         if L.Last = null then
1778
            return False;
1779
         end if;
1780
 
1781
         if L.First.Prev /= null then
1782
            return False;
1783
         end if;
1784
 
1785
         if L.Last.Next /= null then
1786
            return False;
1787
         end if;
1788
 
1789
         if Position.Node.Prev = null
1790
           and then Position.Node /= L.First
1791
         then
1792
            return False;
1793
         end if;
1794
 
1795
         if Position.Node.Next = null
1796
           and then Position.Node /= L.Last
1797
         then
1798
            return False;
1799
         end if;
1800
 
1801
         if L.Length = 1 then
1802
            return L.First = L.Last;
1803
         end if;
1804
 
1805
         if L.First = L.Last then
1806
            return False;
1807
         end if;
1808
 
1809
         if L.First.Next = null then
1810
            return False;
1811
         end if;
1812
 
1813
         if L.Last.Prev = null then
1814
            return False;
1815
         end if;
1816
 
1817
         if L.First.Next.Prev /= L.First then
1818
            return False;
1819
         end if;
1820
 
1821
         if L.Last.Prev.Next /= L.Last then
1822
            return False;
1823
         end if;
1824
 
1825
         if L.Length = 2 then
1826
            if L.First.Next /= L.Last then
1827
               return False;
1828
            end if;
1829
 
1830
            if L.Last.Prev /= L.First then
1831
               return False;
1832
            end if;
1833
 
1834
            return True;
1835
         end if;
1836
 
1837
         if L.First.Next = L.Last then
1838
            return False;
1839
         end if;
1840
 
1841
         if L.Last.Prev = L.First then
1842
            return False;
1843
         end if;
1844
 
1845
         if Position.Node = L.First then
1846
            return True;
1847
         end if;
1848
 
1849
         if Position.Node = L.Last then
1850
            return True;
1851
         end if;
1852
 
1853
         if Position.Node.Next = null then
1854
            return False;
1855
         end if;
1856
 
1857
         if Position.Node.Prev = null then
1858
            return False;
1859
         end if;
1860
 
1861
         if Position.Node.Next.Prev /= Position.Node then
1862
            return False;
1863
         end if;
1864
 
1865
         if Position.Node.Prev.Next /= Position.Node then
1866
            return False;
1867
         end if;
1868
 
1869
         if L.Length = 3 then
1870
            if L.First.Next /= Position.Node then
1871
               return False;
1872
            end if;
1873
 
1874
            if L.Last.Prev /= Position.Node then
1875
               return False;
1876
            end if;
1877
         end if;
1878
 
1879
         return True;
1880
      end;
1881
   end Vet;
1882
 
1883
   -----------
1884
   -- Write --
1885
   -----------
1886
 
1887
   procedure Write
1888
     (Stream : not null access Root_Stream_Type'Class;
1889
      Item   : List)
1890
   is
1891
      Node : Node_Access := Item.First;
1892
 
1893
   begin
1894
      Count_Type'Base'Write (Stream, Item.Length);
1895
 
1896
      while Node /= null loop
1897
         Element_Type'Output (Stream, Node.Element.all);
1898
         Node := Node.Next;
1899
      end loop;
1900
   end Write;
1901
 
1902
   procedure Write
1903
     (Stream : not null access Root_Stream_Type'Class;
1904
      Item   : Cursor)
1905
   is
1906
   begin
1907
      raise Program_Error with "attempt to stream list cursor";
1908
   end Write;
1909
 
1910
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.