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

Subversion Repositories openrisc_me

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

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT LIBRARY COMPONENTS                          --
4
--                                                                          --
5
--              ADA.CONTAINERS.RESTRICTED_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
 
32
package body Ada.Containers.Restricted_Doubly_Linked_Lists is
33
 
34
   -----------------------
35
   -- Local Subprograms --
36
   -----------------------
37
 
38
   procedure Allocate
39
     (Container : in out List'Class;
40
      New_Item  : Element_Type;
41
      New_Node  : out Count_Type);
42
 
43
   procedure Free
44
     (Container : in out List'Class;
45
      X         : Count_Type);
46
 
47
   procedure Insert_Internal
48
     (Container : in out List'Class;
49
      Before    : Count_Type;
50
      New_Node  : Count_Type);
51
 
52
   function Vet (Position : Cursor) return Boolean;
53
 
54
   ---------
55
   -- "=" --
56
   ---------
57
 
58
   function "=" (Left, Right : List) return Boolean is
59
      LN : Node_Array renames Left.Nodes;
60
      RN : Node_Array renames Right.Nodes;
61
 
62
      LI : Count_Type := Left.First;
63
      RI : Count_Type := Right.First;
64
 
65
   begin
66
      if Left'Address = Right'Address then
67
         return True;
68
      end if;
69
 
70
      if Left.Length /= Right.Length then
71
         return False;
72
      end if;
73
 
74
      for J in 1 .. Left.Length loop
75
         if LN (LI).Element /= RN (RI).Element then
76
            return False;
77
         end if;
78
 
79
         LI := LN (LI).Next;
80
         RI := RN (RI).Next;
81
      end loop;
82
 
83
      return True;
84
   end "=";
85
 
86
   --------------
87
   -- Allocate --
88
   --------------
89
 
90
   procedure Allocate
91
     (Container : in out List'Class;
92
      New_Item  : Element_Type;
93
      New_Node  : out Count_Type)
94
   is
95
      N : Node_Array renames Container.Nodes;
96
 
97
   begin
98
      if Container.Free >= 0 then
99
         New_Node := Container.Free;
100
         N (New_Node).Element := New_Item;
101
         Container.Free := N (New_Node).Next;
102
 
103
      else
104
         New_Node := abs Container.Free;
105
         N (New_Node).Element := New_Item;
106
         Container.Free := Container.Free - 1;
107
      end if;
108
   end Allocate;
109
 
110
   ------------
111
   -- Append --
112
   ------------
113
 
114
   procedure Append
115
     (Container : in out List;
116
      New_Item  : Element_Type;
117
      Count     : Count_Type := 1)
118
   is
119
   begin
120
      Insert (Container, No_Element, New_Item, Count);
121
   end Append;
122
 
123
   ------------
124
   -- Assign --
125
   ------------
126
 
127
   procedure Assign (Target : in out List; Source : List) is
128
   begin
129
      if Target'Address = Source'Address then
130
         return;
131
      end if;
132
 
133
      if Target.Capacity < Source.Length then
134
         raise Constraint_Error;  -- ???
135
      end if;
136
 
137
      Clear (Target);
138
 
139
      declare
140
         N : Node_Array renames Source.Nodes;
141
         J : Count_Type := Source.First;
142
 
143
      begin
144
         while J /= 0 loop
145
            Append (Target, N (J).Element);
146
            J := N (J).Next;
147
         end loop;
148
      end;
149
   end Assign;
150
 
151
   -----------
152
   -- Clear --
153
   -----------
154
 
155
   procedure Clear (Container : in out List) is
156
      N : Node_Array renames Container.Nodes;
157
      X : Count_Type;
158
 
159
   begin
160
      if Container.Length = 0 then
161
         pragma Assert (Container.First = 0);
162
         pragma Assert (Container.Last = 0);
163
--       pragma Assert (Container.Busy = 0);
164
--       pragma Assert (Container.Lock = 0);
165
         return;
166
      end if;
167
 
168
      pragma Assert (Container.First >= 1);
169
      pragma Assert (Container.Last >= 1);
170
      pragma Assert (N (Container.First).Prev = 0);
171
      pragma Assert (N (Container.Last).Next = 0);
172
 
173
--    if Container.Busy > 0 then
174
--      raise Program_Error;
175
--    end if;
176
 
177
      while Container.Length > 1 loop
178
         X := Container.First;
179
 
180
         Container.First := N (X).Next;
181
         N (Container.First).Prev := 0;
182
 
183
         Container.Length := Container.Length - 1;
184
 
185
         Free (Container, X);
186
      end loop;
187
 
188
      X := Container.First;
189
 
190
      Container.First := 0;
191
      Container.Last := 0;
192
      Container.Length := 0;
193
 
194
      Free (Container, X);
195
   end Clear;
196
 
197
   --------------
198
   -- Contains --
199
   --------------
200
 
201
   function Contains
202
     (Container : List;
203
      Item      : Element_Type) return Boolean
204
   is
205
   begin
206
      return Find (Container, Item) /= No_Element;
207
   end Contains;
208
 
209
   ------------
210
   -- Delete --
211
   ------------
212
 
213
   procedure Delete
214
     (Container : in out List;
215
      Position  : in out Cursor;
216
      Count     : Count_Type := 1)
217
   is
218
      N : Node_Array renames Container.Nodes;
219
      X : Count_Type;
220
 
221
   begin
222
      if Position.Node = 0 then
223
         raise Constraint_Error;
224
      end if;
225
 
226
      if Position.Container /= Container'Unrestricted_Access then
227
         raise Program_Error;
228
      end if;
229
 
230
      pragma Assert (Vet (Position), "bad cursor in Delete");
231
 
232
      if Position.Node = Container.First then
233
         Delete_First (Container, Count);
234
         Position := No_Element;
235
         return;
236
      end if;
237
 
238
      if Count = 0 then
239
         Position := No_Element;
240
         return;
241
      end if;
242
 
243
--    if Container.Busy > 0 then
244
--       raise Program_Error;
245
--    end if;
246
 
247
      pragma Assert (Container.First >= 1);
248
      pragma Assert (Container.Last >= 1);
249
      pragma Assert (N (Container.First).Prev = 0);
250
      pragma Assert (N (Container.Last).Next = 0);
251
 
252
      for Index in 1 .. Count loop
253
         pragma Assert (Container.Length >= 2);
254
 
255
         X := Position.Node;
256
         Container.Length := Container.Length - 1;
257
 
258
         if X = Container.Last then
259
            Position := No_Element;
260
 
261
            Container.Last := N (X).Prev;
262
            N (Container.Last).Next := 0;
263
 
264
            Free (Container, X);
265
            return;
266
         end if;
267
 
268
         Position.Node := N (X).Next;
269
 
270
         N (N (X).Next).Prev := N (X).Prev;
271
         N (N (X).Prev).Next := N (X).Next;
272
 
273
         Free (Container, X);
274
      end loop;
275
 
276
      Position := No_Element;
277
   end Delete;
278
 
279
   ------------------
280
   -- Delete_First --
281
   ------------------
282
 
283
   procedure Delete_First
284
     (Container : in out List;
285
      Count     : Count_Type := 1)
286
   is
287
      N : Node_Array renames Container.Nodes;
288
      X : Count_Type;
289
 
290
   begin
291
      if Count >= Container.Length then
292
         Clear (Container);
293
         return;
294
      end if;
295
 
296
      if Count = 0 then
297
         return;
298
      end if;
299
 
300
--    if Container.Busy > 0 then
301
--       raise Program_Error;
302
--    end if;
303
 
304
      for I in 1 .. Count loop
305
         X := Container.First;
306
         pragma Assert (N (N (X).Next).Prev = Container.First);
307
 
308
         Container.First := N (X).Next;
309
         N (Container.First).Prev := 0;
310
 
311
         Container.Length := Container.Length - 1;
312
 
313
         Free (Container, X);
314
      end loop;
315
   end Delete_First;
316
 
317
   -----------------
318
   -- Delete_Last --
319
   -----------------
320
 
321
   procedure Delete_Last
322
     (Container : in out List;
323
      Count     : Count_Type := 1)
324
   is
325
      N : Node_Array renames Container.Nodes;
326
      X : Count_Type;
327
 
328
   begin
329
      if Count >= Container.Length then
330
         Clear (Container);
331
         return;
332
      end if;
333
 
334
      if Count = 0 then
335
         return;
336
      end if;
337
 
338
--    if Container.Busy > 0 then
339
--       raise Program_Error;
340
--    end if;
341
 
342
      for I in 1 .. Count loop
343
         X := Container.Last;
344
         pragma Assert (N (N (X).Prev).Next = Container.Last);
345
 
346
         Container.Last := N (X).Prev;
347
         N (Container.Last).Next := 0;
348
 
349
         Container.Length := Container.Length - 1;
350
 
351
         Free (Container, X);
352
      end loop;
353
   end Delete_Last;
354
 
355
   -------------
356
   -- Element --
357
   -------------
358
 
359
   function Element (Position : Cursor) return Element_Type is
360
   begin
361
      if Position.Node = 0 then
362
         raise Constraint_Error;
363
      end if;
364
 
365
      pragma Assert (Vet (Position), "bad cursor in Element");
366
 
367
      declare
368
         N : Node_Array renames Position.Container.Nodes;
369
      begin
370
         return N (Position.Node).Element;
371
      end;
372
   end Element;
373
 
374
   ----------
375
   -- Find --
376
   ----------
377
 
378
   function Find
379
     (Container : List;
380
      Item      : Element_Type;
381
      Position  : Cursor := No_Element) return Cursor
382
   is
383
      Nodes : Node_Array renames Container.Nodes;
384
      Node  : Count_Type := Position.Node;
385
 
386
   begin
387
      if Node = 0 then
388
         Node := Container.First;
389
 
390
      else
391
         if Position.Container /= Container'Unrestricted_Access then
392
            raise Program_Error;
393
         end if;
394
 
395
         pragma Assert (Vet (Position), "bad cursor in Find");
396
      end if;
397
 
398
      while Node /= 0 loop
399
         if Nodes (Node).Element = Item then
400
            return Cursor'(Container'Unrestricted_Access, Node);
401
         end if;
402
 
403
         Node := Nodes (Node).Next;
404
      end loop;
405
 
406
      return No_Element;
407
   end Find;
408
 
409
   -----------
410
   -- First --
411
   -----------
412
 
413
   function First (Container : List) return Cursor is
414
   begin
415
      if Container.First = 0 then
416
         return No_Element;
417
      end if;
418
 
419
      return Cursor'(Container'Unrestricted_Access, Container.First);
420
   end First;
421
 
422
   -------------------
423
   -- First_Element --
424
   -------------------
425
 
426
   function First_Element (Container : List) return Element_Type is
427
      N : Node_Array renames Container.Nodes;
428
 
429
   begin
430
      if Container.First = 0 then
431
         raise Constraint_Error;
432
      end if;
433
 
434
      return N (Container.First).Element;
435
   end First_Element;
436
 
437
   ----------
438
   -- Free --
439
   ----------
440
 
441
   procedure Free
442
     (Container : in out List'Class;
443
      X         : Count_Type)
444
   is
445
      pragma Assert (X > 0);
446
      pragma Assert (X <= Container.Capacity);
447
 
448
      N : Node_Array renames Container.Nodes;
449
 
450
   begin
451
      N (X).Prev := -1;  -- Node is deallocated (not on active list)
452
 
453
      if Container.Free >= 0 then
454
         N (X).Next := Container.Free;
455
         Container.Free := X;
456
 
457
      elsif X + 1 = abs Container.Free then
458
         N (X).Next := 0;  -- Not strictly necessary, but marginally safer
459
         Container.Free := Container.Free + 1;
460
 
461
      else
462
         Container.Free := abs Container.Free;
463
 
464
         if Container.Free > Container.Capacity then
465
            Container.Free := 0;
466
 
467
         else
468
            for I in Container.Free .. Container.Capacity - 1 loop
469
               N (I).Next := I + 1;
470
            end loop;
471
 
472
            N (Container.Capacity).Next := 0;
473
         end if;
474
 
475
         N (X).Next := Container.Free;
476
         Container.Free := X;
477
      end if;
478
   end Free;
479
 
480
   ---------------------
481
   -- Generic_Sorting --
482
   ---------------------
483
 
484
   package body Generic_Sorting is
485
 
486
      ---------------
487
      -- Is_Sorted --
488
      ---------------
489
 
490
      function Is_Sorted (Container : List) return Boolean is
491
         Nodes : Node_Array renames Container.Nodes;
492
         Node  : Count_Type := Container.First;
493
 
494
      begin
495
         for I in 2 .. Container.Length loop
496
            if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
497
               return False;
498
            end if;
499
 
500
            Node := Nodes (Node).Next;
501
         end loop;
502
 
503
         return True;
504
      end Is_Sorted;
505
 
506
      ----------
507
      -- Sort --
508
      ----------
509
 
510
      procedure Sort (Container : in out List) is
511
         N : Node_Array renames Container.Nodes;
512
 
513
         procedure Partition (Pivot, Back : Count_Type);
514
         procedure Sort (Front, Back : Count_Type);
515
 
516
         ---------------
517
         -- Partition --
518
         ---------------
519
 
520
         procedure Partition (Pivot, Back : Count_Type) is
521
            Node : Count_Type := N (Pivot).Next;
522
 
523
         begin
524
            while Node /= Back loop
525
               if N (Node).Element < N (Pivot).Element then
526
                  declare
527
                     Prev : constant Count_Type := N (Node).Prev;
528
                     Next : constant Count_Type := N (Node).Next;
529
 
530
                  begin
531
                     N (Prev).Next := Next;
532
 
533
                     if Next = 0 then
534
                        Container.Last := Prev;
535
                     else
536
                        N (Next).Prev := Prev;
537
                     end if;
538
 
539
                     N (Node).Next := Pivot;
540
                     N (Node).Prev := N (Pivot).Prev;
541
 
542
                     N (Pivot).Prev := Node;
543
 
544
                     if N (Node).Prev = 0 then
545
                        Container.First := Node;
546
                     else
547
                        N (N (Node).Prev).Next := Node;
548
                     end if;
549
 
550
                     Node := Next;
551
                  end;
552
 
553
               else
554
                  Node := N (Node).Next;
555
               end if;
556
            end loop;
557
         end Partition;
558
 
559
         ----------
560
         -- Sort --
561
         ----------
562
 
563
         procedure Sort (Front, Back : Count_Type) is
564
            Pivot : constant Count_Type :=
565
                      (if Front = 0 then Container.First else N (Front).Next);
566
         begin
567
            if Pivot /= Back then
568
               Partition (Pivot, Back);
569
               Sort (Front, Pivot);
570
               Sort (Pivot, Back);
571
            end if;
572
         end Sort;
573
 
574
      --  Start of processing for Sort
575
 
576
      begin
577
         if Container.Length <= 1 then
578
            return;
579
         end if;
580
 
581
         pragma Assert (N (Container.First).Prev = 0);
582
         pragma Assert (N (Container.Last).Next = 0);
583
 
584
--       if Container.Busy > 0 then
585
--          raise Program_Error;
586
--       end if;
587
 
588
         Sort (Front => 0, Back => 0);
589
 
590
         pragma Assert (N (Container.First).Prev = 0);
591
         pragma Assert (N (Container.Last).Next = 0);
592
      end Sort;
593
 
594
   end Generic_Sorting;
595
 
596
   -----------------
597
   -- Has_Element --
598
   -----------------
599
 
600
   function Has_Element (Position : Cursor) return Boolean is
601
   begin
602
      pragma Assert (Vet (Position), "bad cursor in Has_Element");
603
      return Position.Node /= 0;
604
   end Has_Element;
605
 
606
   ------------
607
   -- Insert --
608
   ------------
609
 
610
   procedure Insert
611
     (Container : in out List;
612
      Before    : Cursor;
613
      New_Item  : Element_Type;
614
      Position  : out Cursor;
615
      Count     : Count_Type := 1)
616
   is
617
      J : Count_Type;
618
 
619
   begin
620
      if Before.Container /= null then
621
         if Before.Container /= Container'Unrestricted_Access then
622
            raise Program_Error;
623
         end if;
624
 
625
         pragma Assert (Vet (Before), "bad cursor in Insert");
626
      end if;
627
 
628
      if Count = 0 then
629
         Position := Before;
630
         return;
631
      end if;
632
 
633
      if Container.Length > Container.Capacity - Count then
634
         raise Constraint_Error;
635
      end if;
636
 
637
--    if Container.Busy > 0 then
638
--       raise Program_Error;
639
--    end if;
640
 
641
      Allocate (Container, New_Item, New_Node => J);
642
      Insert_Internal (Container, Before.Node, New_Node => J);
643
      Position := Cursor'(Container'Unrestricted_Access, Node => J);
644
 
645
      for Index in 2 .. Count loop
646
         Allocate (Container, New_Item, New_Node => J);
647
         Insert_Internal (Container, Before.Node, New_Node => J);
648
      end loop;
649
   end Insert;
650
 
651
   procedure Insert
652
     (Container : in out List;
653
      Before    : Cursor;
654
      New_Item  : Element_Type;
655
      Count     : Count_Type := 1)
656
   is
657
      Position : Cursor;
658
      pragma Unreferenced (Position);
659
   begin
660
      Insert (Container, Before, New_Item, Position, Count);
661
   end Insert;
662
 
663
   procedure Insert
664
     (Container : in out List;
665
      Before    : Cursor;
666
      Position  : out Cursor;
667
      Count     : Count_Type := 1)
668
   is
669
      New_Item : Element_Type;  -- Do we need to reinit node ???
670
      pragma Warnings (Off, New_Item);
671
 
672
   begin
673
      Insert (Container, Before, New_Item, Position, Count);
674
   end Insert;
675
 
676
   ---------------------
677
   -- Insert_Internal --
678
   ---------------------
679
 
680
   procedure Insert_Internal
681
     (Container : in out List'Class;
682
      Before    : Count_Type;
683
      New_Node  : Count_Type)
684
   is
685
      N : Node_Array renames Container.Nodes;
686
 
687
   begin
688
      if Container.Length = 0 then
689
         pragma Assert (Before = 0);
690
         pragma Assert (Container.First = 0);
691
         pragma Assert (Container.Last = 0);
692
 
693
         Container.First := New_Node;
694
         Container.Last := New_Node;
695
 
696
         N (Container.First).Prev := 0;
697
         N (Container.Last).Next := 0;
698
 
699
      elsif Before = 0 then
700
         pragma Assert (N (Container.Last).Next = 0);
701
 
702
         N (Container.Last).Next := New_Node;
703
         N (New_Node).Prev := Container.Last;
704
 
705
         Container.Last := New_Node;
706
         N (Container.Last).Next := 0;
707
 
708
      elsif Before = Container.First then
709
         pragma Assert (N (Container.First).Prev = 0);
710
 
711
         N (Container.First).Prev := New_Node;
712
         N (New_Node).Next := Container.First;
713
 
714
         Container.First := New_Node;
715
         N (Container.First).Prev := 0;
716
 
717
      else
718
         pragma Assert (N (Container.First).Prev = 0);
719
         pragma Assert (N (Container.Last).Next = 0);
720
 
721
         N (New_Node).Next := Before;
722
         N (New_Node).Prev := N (Before).Prev;
723
 
724
         N (N (Before).Prev).Next := New_Node;
725
         N (Before).Prev := New_Node;
726
      end if;
727
 
728
      Container.Length := Container.Length + 1;
729
   end Insert_Internal;
730
 
731
   --------------
732
   -- Is_Empty --
733
   --------------
734
 
735
   function Is_Empty (Container : List) return Boolean is
736
   begin
737
      return Container.Length = 0;
738
   end Is_Empty;
739
 
740
   -------------
741
   -- Iterate --
742
   -------------
743
 
744
   procedure Iterate
745
     (Container : List;
746
      Process   : not null access procedure (Position : Cursor))
747
   is
748
      C : List renames Container'Unrestricted_Access.all;
749
      N : Node_Array renames C.Nodes;
750
--    B : Natural renames C.Busy;
751
 
752
      Node  : Count_Type := Container.First;
753
 
754
      Index     : Count_Type := 0;
755
      Index_Max : constant Count_Type := Container.Length;
756
 
757
   begin
758
      if Index_Max = 0 then
759
         pragma Assert (Node = 0);
760
         return;
761
      end if;
762
 
763
      loop
764
         pragma Assert (Node /= 0);
765
 
766
         Process (Cursor'(C'Unchecked_Access, Node));
767
         pragma Assert (Container.Length = Index_Max);
768
         pragma Assert (N (Node).Prev /= -1);
769
 
770
         Node := N (Node).Next;
771
         Index := Index + 1;
772
 
773
         if Index = Index_Max then
774
            pragma Assert (Node = 0);
775
            return;
776
         end if;
777
      end loop;
778
   end Iterate;
779
 
780
   ----------
781
   -- Last --
782
   ----------
783
 
784
   function Last (Container : List) return Cursor is
785
   begin
786
      if Container.Last = 0 then
787
         return No_Element;
788
      end if;
789
 
790
      return Cursor'(Container'Unrestricted_Access, Container.Last);
791
   end Last;
792
 
793
   ------------------
794
   -- Last_Element --
795
   ------------------
796
 
797
   function Last_Element (Container : List) return Element_Type is
798
      N : Node_Array renames Container.Nodes;
799
 
800
   begin
801
      if Container.Last = 0 then
802
         raise Constraint_Error;
803
      end if;
804
 
805
      return N (Container.Last).Element;
806
   end Last_Element;
807
 
808
   ------------
809
   -- Length --
810
   ------------
811
 
812
   function Length (Container : List) return Count_Type is
813
   begin
814
      return Container.Length;
815
   end Length;
816
 
817
   ----------
818
   -- Next --
819
   ----------
820
 
821
   procedure Next (Position : in out Cursor) is
822
   begin
823
      Position := Next (Position);
824
   end Next;
825
 
826
   function Next (Position : Cursor) return Cursor is
827
   begin
828
      if Position.Node = 0 then
829
         return No_Element;
830
      end if;
831
 
832
      pragma Assert (Vet (Position), "bad cursor in Next");
833
 
834
      declare
835
         Nodes : Node_Array renames Position.Container.Nodes;
836
         Node  : constant Count_Type := Nodes (Position.Node).Next;
837
 
838
      begin
839
         if Node = 0 then
840
            return No_Element;
841
         end if;
842
 
843
         return Cursor'(Position.Container, Node);
844
      end;
845
   end Next;
846
 
847
   -------------
848
   -- Prepend --
849
   -------------
850
 
851
   procedure Prepend
852
     (Container : in out List;
853
      New_Item  : Element_Type;
854
      Count     : Count_Type := 1)
855
   is
856
   begin
857
      Insert (Container, First (Container), New_Item, Count);
858
   end Prepend;
859
 
860
   --------------
861
   -- Previous --
862
   --------------
863
 
864
   procedure Previous (Position : in out Cursor) is
865
   begin
866
      Position := Previous (Position);
867
   end Previous;
868
 
869
   function Previous (Position : Cursor) return Cursor is
870
   begin
871
      if Position.Node = 0 then
872
         return No_Element;
873
      end if;
874
 
875
      pragma Assert (Vet (Position), "bad cursor in Previous");
876
 
877
      declare
878
         Nodes : Node_Array renames Position.Container.Nodes;
879
         Node  : constant Count_Type := Nodes (Position.Node).Prev;
880
      begin
881
         if Node = 0 then
882
            return No_Element;
883
         end if;
884
 
885
         return Cursor'(Position.Container, Node);
886
      end;
887
   end Previous;
888
 
889
   -------------------
890
   -- Query_Element --
891
   -------------------
892
 
893
   procedure Query_Element
894
     (Position : Cursor;
895
      Process  : not null access procedure (Element : Element_Type))
896
   is
897
   begin
898
      if Position.Node = 0 then
899
         raise Constraint_Error;
900
      end if;
901
 
902
      pragma Assert (Vet (Position), "bad cursor in Query_Element");
903
 
904
      declare
905
         C : List renames Position.Container.all'Unrestricted_Access.all;
906
         N : Node_Type renames C.Nodes (Position.Node);
907
 
908
      begin
909
         Process (N.Element);
910
         pragma Assert (N.Prev >= 0);
911
      end;
912
   end Query_Element;
913
 
914
   ---------------------
915
   -- Replace_Element --
916
   ---------------------
917
 
918
   procedure Replace_Element
919
     (Container : in out List;
920
      Position  : Cursor;
921
      New_Item  : Element_Type)
922
   is
923
   begin
924
      if Position.Container = null then
925
         raise Constraint_Error;
926
      end if;
927
 
928
      if Position.Container /= Container'Unrestricted_Access then
929
         raise Program_Error;
930
      end if;
931
 
932
--    if Container.Lock > 0 then
933
--       raise Program_Error;
934
--    end if;
935
 
936
      pragma Assert (Vet (Position), "bad cursor in Replace_Element");
937
 
938
      declare
939
         N : Node_Array renames Container.Nodes;
940
      begin
941
         N (Position.Node).Element := New_Item;
942
      end;
943
   end Replace_Element;
944
 
945
   ----------------------
946
   -- Reverse_Elements --
947
   ----------------------
948
 
949
   procedure Reverse_Elements (Container : in out List) is
950
      N : Node_Array renames Container.Nodes;
951
      I : Count_Type := Container.First;
952
      J : Count_Type := Container.Last;
953
 
954
      procedure Swap (L, R : Count_Type);
955
 
956
      ----------
957
      -- Swap --
958
      ----------
959
 
960
      procedure Swap (L, R : Count_Type) is
961
         LN : constant Count_Type := N (L).Next;
962
         LP : constant Count_Type := N (L).Prev;
963
 
964
         RN : constant Count_Type := N (R).Next;
965
         RP : constant Count_Type := N (R).Prev;
966
 
967
      begin
968
         if LP /= 0 then
969
            N (LP).Next := R;
970
         end if;
971
 
972
         if RN /= 0 then
973
            N (RN).Prev := L;
974
         end if;
975
 
976
         N (L).Next := RN;
977
         N (R).Prev := LP;
978
 
979
         if LN = R then
980
            pragma Assert (RP = L);
981
 
982
            N (L).Prev := R;
983
            N (R).Next := L;
984
 
985
         else
986
            N (L).Prev := RP;
987
            N (RP).Next := L;
988
 
989
            N (R).Next := LN;
990
            N (LN).Prev := R;
991
         end if;
992
      end Swap;
993
 
994
   --  Start of processing for Reverse_Elements
995
 
996
   begin
997
      if Container.Length <= 1 then
998
         return;
999
      end if;
1000
 
1001
      pragma Assert (N (Container.First).Prev = 0);
1002
      pragma Assert (N (Container.Last).Next = 0);
1003
 
1004
--    if Container.Busy > 0 then
1005
--       raise Program_Error;
1006
--    end if;
1007
 
1008
      Container.First := J;
1009
      Container.Last := I;
1010
      loop
1011
         Swap (L => I, R => J);
1012
 
1013
         J := N (J).Next;
1014
         exit when I = J;
1015
 
1016
         I := N (I).Prev;
1017
         exit when I = J;
1018
 
1019
         Swap (L => J, R => I);
1020
 
1021
         I := N (I).Next;
1022
         exit when I = J;
1023
 
1024
         J := N (J).Prev;
1025
         exit when I = J;
1026
      end loop;
1027
 
1028
      pragma Assert (N (Container.First).Prev = 0);
1029
      pragma Assert (N (Container.Last).Next = 0);
1030
   end Reverse_Elements;
1031
 
1032
   ------------------
1033
   -- Reverse_Find --
1034
   ------------------
1035
 
1036
   function Reverse_Find
1037
     (Container : List;
1038
      Item      : Element_Type;
1039
      Position  : Cursor := No_Element) return Cursor
1040
   is
1041
      N    : Node_Array renames Container.Nodes;
1042
      Node : Count_Type := Position.Node;
1043
 
1044
   begin
1045
      if Node = 0 then
1046
         Node := Container.Last;
1047
 
1048
      else
1049
         if Position.Container /= Container'Unrestricted_Access then
1050
            raise Program_Error;
1051
         end if;
1052
 
1053
         pragma Assert (Vet (Position), "bad cursor in Reverse_Find");
1054
      end if;
1055
 
1056
      while Node /= 0 loop
1057
         if N (Node).Element = Item then
1058
            return Cursor'(Container'Unrestricted_Access, Node);
1059
         end if;
1060
 
1061
         Node := N (Node).Prev;
1062
      end loop;
1063
 
1064
      return No_Element;
1065
   end Reverse_Find;
1066
 
1067
   ---------------------
1068
   -- Reverse_Iterate --
1069
   ---------------------
1070
 
1071
   procedure Reverse_Iterate
1072
     (Container : List;
1073
      Process   : not null access procedure (Position : Cursor))
1074
   is
1075
      C : List renames Container'Unrestricted_Access.all;
1076
      N : Node_Array renames C.Nodes;
1077
--    B : Natural renames C.Busy;
1078
 
1079
      Node : Count_Type := Container.Last;
1080
 
1081
      Index     : Count_Type := 0;
1082
      Index_Max : constant Count_Type := Container.Length;
1083
 
1084
   begin
1085
      if Index_Max = 0 then
1086
         pragma Assert (Node = 0);
1087
         return;
1088
      end if;
1089
 
1090
      loop
1091
         pragma Assert (Node > 0);
1092
 
1093
         Process (Cursor'(C'Unchecked_Access, Node));
1094
         pragma Assert (Container.Length = Index_Max);
1095
         pragma Assert (N (Node).Prev /= -1);
1096
 
1097
         Node := N (Node).Prev;
1098
         Index := Index + 1;
1099
 
1100
         if Index = Index_Max then
1101
            pragma Assert (Node = 0);
1102
            return;
1103
         end if;
1104
      end loop;
1105
   end Reverse_Iterate;
1106
 
1107
   ------------
1108
   -- Splice --
1109
   ------------
1110
 
1111
   procedure Splice
1112
     (Container : in out List;
1113
      Before    : Cursor;
1114
      Position  : in out Cursor)
1115
   is
1116
      N : Node_Array renames Container.Nodes;
1117
 
1118
   begin
1119
      if Before.Container /= null then
1120
         if Before.Container /= Container'Unrestricted_Access then
1121
            raise Program_Error;
1122
         end if;
1123
 
1124
         pragma Assert (Vet (Before), "bad Before cursor in Splice");
1125
      end if;
1126
 
1127
      if Position.Node = 0 then
1128
         raise Constraint_Error;
1129
      end if;
1130
 
1131
      if Position.Container /= Container'Unrestricted_Access then
1132
         raise Program_Error;
1133
      end if;
1134
 
1135
      pragma Assert (Vet (Position), "bad Position cursor in Splice");
1136
 
1137
      if Position.Node = Before.Node
1138
        or else N (Position.Node).Next = Before.Node
1139
      then
1140
         return;
1141
      end if;
1142
 
1143
      pragma Assert (Container.Length >= 2);
1144
 
1145
--    if Container.Busy > 0 then
1146
--       raise Program_Error;
1147
--    end if;
1148
 
1149
      if Before.Node = 0 then
1150
         pragma Assert (Position.Node /= Container.Last);
1151
 
1152
         if Position.Node = Container.First then
1153
            Container.First := N (Position.Node).Next;
1154
            N (Container.First).Prev := 0;
1155
 
1156
         else
1157
            N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1158
            N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1159
         end if;
1160
 
1161
         N (Container.Last).Next := Position.Node;
1162
         N (Position.Node).Prev := Container.Last;
1163
 
1164
         Container.Last := Position.Node;
1165
         N (Container.Last).Next := 0;
1166
 
1167
         return;
1168
      end if;
1169
 
1170
      if Before.Node = Container.First then
1171
         pragma Assert (Position.Node /= Container.First);
1172
 
1173
         if Position.Node = Container.Last then
1174
            Container.Last := N (Position.Node).Prev;
1175
            N (Container.Last).Next := 0;
1176
 
1177
         else
1178
            N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1179
            N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1180
         end if;
1181
 
1182
         N (Container.First).Prev := Position.Node;
1183
         N (Position.Node).Next := Container.First;
1184
 
1185
         Container.First := Position.Node;
1186
         N (Container.First).Prev := 0;
1187
 
1188
         return;
1189
      end if;
1190
 
1191
      if Position.Node = Container.First then
1192
         Container.First := N (Position.Node).Next;
1193
         N (Container.First).Prev := 0;
1194
 
1195
      elsif Position.Node = Container.Last then
1196
         Container.Last := N (Position.Node).Prev;
1197
         N (Container.Last).Next := 0;
1198
 
1199
      else
1200
         N (N (Position.Node).Prev).Next := N (Position.Node).Next;
1201
         N (N (Position.Node).Next).Prev := N (Position.Node).Prev;
1202
      end if;
1203
 
1204
      N (N (Before.Node).Prev).Next := Position.Node;
1205
      N (Position.Node).Prev := N (Before.Node).Prev;
1206
 
1207
      N (Before.Node).Prev := Position.Node;
1208
      N (Position.Node).Next := Before.Node;
1209
 
1210
      pragma Assert (N (Container.First).Prev = 0);
1211
      pragma Assert (N (Container.Last).Next = 0);
1212
   end Splice;
1213
 
1214
   ----------
1215
   -- Swap --
1216
   ----------
1217
 
1218
   procedure Swap
1219
     (Container : in out List;
1220
      I, J      : Cursor)
1221
   is
1222
   begin
1223
      if I.Node = 0
1224
        or else J.Node = 0
1225
      then
1226
         raise Constraint_Error;
1227
      end if;
1228
 
1229
      if I.Container /= Container'Unrestricted_Access
1230
        or else J.Container /= Container'Unrestricted_Access
1231
      then
1232
         raise Program_Error;
1233
      end if;
1234
 
1235
      if I.Node = J.Node then
1236
         return;
1237
      end if;
1238
 
1239
--    if Container.Lock > 0 then
1240
--       raise Program_Error;
1241
--    end if;
1242
 
1243
      pragma Assert (Vet (I), "bad I cursor in Swap");
1244
      pragma Assert (Vet (J), "bad J cursor in Swap");
1245
 
1246
      declare
1247
         N  : Node_Array renames Container.Nodes;
1248
 
1249
         EI : Element_Type renames N (I.Node).Element;
1250
         EJ : Element_Type renames N (J.Node).Element;
1251
 
1252
         EI_Copy : constant Element_Type := EI;
1253
 
1254
      begin
1255
         EI := EJ;
1256
         EJ := EI_Copy;
1257
      end;
1258
   end Swap;
1259
 
1260
   ----------------
1261
   -- Swap_Links --
1262
   ----------------
1263
 
1264
   procedure Swap_Links
1265
     (Container : in out List;
1266
      I, J      : Cursor)
1267
   is
1268
   begin
1269
      if I.Node = 0
1270
        or else J.Node = 0
1271
      then
1272
         raise Constraint_Error;
1273
      end if;
1274
 
1275
      if I.Container /= Container'Unrestricted_Access
1276
        or else I.Container /= J.Container
1277
      then
1278
         raise Program_Error;
1279
      end if;
1280
 
1281
      if I.Node = J.Node then
1282
         return;
1283
      end if;
1284
 
1285
--    if Container.Busy > 0 then
1286
--       raise Program_Error;
1287
--    end if;
1288
 
1289
      pragma Assert (Vet (I), "bad I cursor in Swap_Links");
1290
      pragma Assert (Vet (J), "bad J cursor in Swap_Links");
1291
 
1292
      declare
1293
         I_Next : constant Cursor := Next (I);
1294
 
1295
         J_Copy : Cursor := J;
1296
         pragma Warnings (Off, J_Copy);
1297
 
1298
      begin
1299
         if I_Next = J then
1300
            Splice (Container, Before => I, Position => J_Copy);
1301
 
1302
         else
1303
            declare
1304
               J_Next : constant Cursor := Next (J);
1305
 
1306
               I_Copy : Cursor := I;
1307
               pragma Warnings (Off, I_Copy);
1308
 
1309
            begin
1310
               if J_Next = I then
1311
                  Splice (Container, Before => J, Position => I_Copy);
1312
 
1313
               else
1314
                  pragma Assert (Container.Length >= 3);
1315
 
1316
                  Splice (Container, Before => I_Next, Position => J_Copy);
1317
                  Splice (Container, Before => J_Next, Position => I_Copy);
1318
               end if;
1319
            end;
1320
         end if;
1321
      end;
1322
   end Swap_Links;
1323
 
1324
   --------------------
1325
   -- Update_Element --
1326
   --------------------
1327
 
1328
   procedure Update_Element
1329
     (Container : in out List;
1330
      Position  : Cursor;
1331
      Process   : not null access procedure (Element : in out Element_Type))
1332
   is
1333
   begin
1334
      if Position.Node = 0 then
1335
         raise Constraint_Error;
1336
      end if;
1337
 
1338
      if Position.Container /= Container'Unrestricted_Access then
1339
         raise Program_Error;
1340
      end if;
1341
 
1342
      pragma Assert (Vet (Position), "bad cursor in Update_Element");
1343
 
1344
      declare
1345
         N  : Node_Type renames Container.Nodes (Position.Node);
1346
 
1347
      begin
1348
         Process (N.Element);
1349
         pragma Assert (N.Prev >= 0);
1350
      end;
1351
   end Update_Element;
1352
 
1353
   ---------
1354
   -- Vet --
1355
   ---------
1356
 
1357
   function Vet (Position : Cursor) return Boolean is
1358
   begin
1359
      if Position.Node = 0 then
1360
         return Position.Container = null;
1361
      end if;
1362
 
1363
      if Position.Container = null then
1364
         return False;
1365
      end if;
1366
 
1367
      declare
1368
         L : List renames Position.Container.all;
1369
         N : Node_Array renames L.Nodes;
1370
 
1371
      begin
1372
         if L.Length = 0 then
1373
            return False;
1374
         end if;
1375
 
1376
         if L.First = 0 then
1377
            return False;
1378
         end if;
1379
 
1380
         if L.Last = 0 then
1381
            return False;
1382
         end if;
1383
 
1384
         if Position.Node > L.Capacity then
1385
            return False;
1386
         end if;
1387
 
1388
         if N (Position.Node).Prev < 0
1389
           or else N (Position.Node).Prev > L.Capacity
1390
         then
1391
            return False;
1392
         end if;
1393
 
1394
         if N (Position.Node).Next > L.Capacity then
1395
            return False;
1396
         end if;
1397
 
1398
         if N (L.First).Prev /= 0 then
1399
            return False;
1400
         end if;
1401
 
1402
         if N (L.Last).Next /= 0 then
1403
            return False;
1404
         end if;
1405
 
1406
         if N (Position.Node).Prev = 0
1407
           and then Position.Node /= L.First
1408
         then
1409
            return False;
1410
         end if;
1411
 
1412
         if N (Position.Node).Next = 0
1413
           and then Position.Node /= L.Last
1414
         then
1415
            return False;
1416
         end if;
1417
 
1418
         if L.Length = 1 then
1419
            return L.First = L.Last;
1420
         end if;
1421
 
1422
         if L.First = L.Last then
1423
            return False;
1424
         end if;
1425
 
1426
         if N (L.First).Next = 0 then
1427
            return False;
1428
         end if;
1429
 
1430
         if N (L.Last).Prev = 0 then
1431
            return False;
1432
         end if;
1433
 
1434
         if N (N (L.First).Next).Prev /= L.First then
1435
            return False;
1436
         end if;
1437
 
1438
         if N (N (L.Last).Prev).Next /= L.Last then
1439
            return False;
1440
         end if;
1441
 
1442
         if L.Length = 2 then
1443
            if N (L.First).Next /= L.Last then
1444
               return False;
1445
            end if;
1446
 
1447
            if N (L.Last).Prev /= L.First then
1448
               return False;
1449
            end if;
1450
 
1451
            return True;
1452
         end if;
1453
 
1454
         if N (L.First).Next = L.Last then
1455
            return False;
1456
         end if;
1457
 
1458
         if N (L.Last).Prev = L.First then
1459
            return False;
1460
         end if;
1461
 
1462
         if Position.Node = L.First then
1463
            return True;
1464
         end if;
1465
 
1466
         if Position.Node = L.Last then
1467
            return True;
1468
         end if;
1469
 
1470
         if N (Position.Node).Next = 0 then
1471
            return False;
1472
         end if;
1473
 
1474
         if N (Position.Node).Prev = 0 then
1475
            return False;
1476
         end if;
1477
 
1478
         if N (N (Position.Node).Next).Prev /= Position.Node then
1479
            return False;
1480
         end if;
1481
 
1482
         if N (N (Position.Node).Prev).Next /= Position.Node then
1483
            return False;
1484
         end if;
1485
 
1486
         if L.Length = 3 then
1487
            if N (L.First).Next /= Position.Node then
1488
               return False;
1489
            end if;
1490
 
1491
            if N (L.Last).Prev /= Position.Node then
1492
               return False;
1493
            end if;
1494
         end if;
1495
 
1496
         return True;
1497
      end;
1498
   end Vet;
1499
 
1500
end Ada.Containers.Restricted_Doubly_Linked_Lists;

powered by: WebSVN 2.1.0

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