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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT LIBRARY COMPONENTS                          --
4
--                                                                          --
5
--    A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S     --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2004-2012, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- This unit was originally developed by Matthew J Heaney.                  --
28
------------------------------------------------------------------------------
29
 
30
with Ada.Containers.Generic_Array_Sort;
31
with Ada.Unchecked_Deallocation;
32
 
33
with System; use type System.Address;
34
 
35
package body Ada.Containers.Indefinite_Vectors is
36
 
37
   procedure Free is
38
     new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
39
 
40
   procedure Free is
41
     new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
42
 
43
   type Iterator is new Limited_Controlled and
44
     Vector_Iterator_Interfaces.Reversible_Iterator with
45
   record
46
      Container : Vector_Access;
47
      Index     : Index_Type'Base;
48
   end record;
49
 
50
   overriding procedure Finalize (Object : in out Iterator);
51
 
52
   overriding function First (Object : Iterator) return Cursor;
53
   overriding function Last  (Object : Iterator) return Cursor;
54
 
55
   overriding function Next
56
     (Object   : Iterator;
57
      Position : Cursor) return Cursor;
58
 
59
   overriding function Previous
60
     (Object   : Iterator;
61
      Position : Cursor) return Cursor;
62
 
63
   ---------
64
   -- "&" --
65
   ---------
66
 
67
   function "&" (Left, Right : Vector) return Vector is
68
      LN   : constant Count_Type := Length (Left);
69
      RN   : constant Count_Type := Length (Right);
70
      N    : Count_Type'Base;  -- length of result
71
      J    : Count_Type'Base;  -- for computing intermediate values
72
      Last : Index_Type'Base;  -- Last index of result
73
 
74
   begin
75
      --  We decide that the capacity of the result is the sum of the lengths
76
      --  of the vector parameters. We could decide to make it larger, but we
77
      --  have no basis for knowing how much larger, so we just allocate the
78
      --  minimum amount of storage.
79
 
80
      --  Here we handle the easy cases first, when one of the vector
81
      --  parameters is empty. (We say "easy" because there's nothing to
82
      --  compute, that can potentially overflow.)
83
 
84
      if LN = 0 then
85
         if RN = 0 then
86
            return Empty_Vector;
87
         end if;
88
 
89
         declare
90
            RE : Elements_Array renames
91
                   Right.Elements.EA (Index_Type'First .. Right.Last);
92
 
93
            Elements : Elements_Access :=
94
                         new Elements_Type (Right.Last);
95
 
96
         begin
97
            --  Elements of an indefinite vector are allocated, so we cannot
98
            --  use simple slice assignment to give a value to our result.
99
            --  Hence we must walk the array of the Right vector, and copy
100
            --  each source element individually.
101
 
102
            for I in Elements.EA'Range loop
103
               begin
104
                  if RE (I) /= null then
105
                     Elements.EA (I) := new Element_Type'(RE (I).all);
106
                  end if;
107
 
108
               exception
109
                  when others =>
110
                     for J in Index_Type'First .. I - 1 loop
111
                        Free (Elements.EA (J));
112
                     end loop;
113
 
114
                     Free (Elements);
115
                     raise;
116
               end;
117
            end loop;
118
 
119
            return (Controlled with Elements, Right.Last, 0, 0);
120
         end;
121
 
122
      end if;
123
 
124
      if RN = 0 then
125
         declare
126
            LE : Elements_Array renames
127
                   Left.Elements.EA (Index_Type'First .. Left.Last);
128
 
129
            Elements : Elements_Access :=
130
                         new Elements_Type (Left.Last);
131
 
132
         begin
133
            --  Elements of an indefinite vector are allocated, so we cannot
134
            --  use simple slice assignment to give a value to our result.
135
            --  Hence we must walk the array of the Left vector, and copy
136
            --  each source element individually.
137
 
138
            for I in Elements.EA'Range loop
139
               begin
140
                  if LE (I) /= null then
141
                     Elements.EA (I) := new Element_Type'(LE (I).all);
142
                  end if;
143
 
144
               exception
145
                  when others =>
146
                     for J in Index_Type'First .. I - 1 loop
147
                        Free (Elements.EA (J));
148
                     end loop;
149
 
150
                     Free (Elements);
151
                     raise;
152
               end;
153
            end loop;
154
 
155
            return (Controlled with Elements, Left.Last, 0, 0);
156
         end;
157
      end if;
158
 
159
      --  Neither of the vector parameters is empty, so we must compute the
160
      --  length of the result vector and its last index. (This is the harder
161
      --  case, because our computations must avoid overflow.)
162
 
163
      --  There are two constraints we need to satisfy. The first constraint is
164
      --  that a container cannot have more than Count_Type'Last elements, so
165
      --  we must check the sum of the combined lengths. Note that we cannot
166
      --  simply add the lengths, because of the possibility of overflow.
167
 
168
      if LN > Count_Type'Last - RN then
169
         raise Constraint_Error with "new length is out of range";
170
      end if;
171
 
172
      --  It is now safe compute the length of the new vector.
173
 
174
      N := LN + RN;
175
 
176
      --  The second constraint is that the new Last index value cannot
177
      --  exceed Index_Type'Last. We use the wider of Index_Type'Base and
178
      --  Count_Type'Base as the type for intermediate values.
179
 
180
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
181
 
182
         --  We perform a two-part test. First we determine whether the
183
         --  computed Last value lies in the base range of the type, and then
184
         --  determine whether it lies in the range of the index (sub)type.
185
 
186
         --  Last must satisfy this relation:
187
         --    First + Length - 1 <= Last
188
         --  We regroup terms:
189
         --    First - 1 <= Last - Length
190
         --  Which can rewrite as:
191
         --    No_Index <= Last - Length
192
 
193
         if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
194
            raise Constraint_Error with "new length is out of range";
195
         end if;
196
 
197
         --  We now know that the computed value of Last is within the base
198
         --  range of the type, so it is safe to compute its value:
199
 
200
         Last := No_Index + Index_Type'Base (N);
201
 
202
         --  Finally we test whether the value is within the range of the
203
         --  generic actual index subtype:
204
 
205
         if Last > Index_Type'Last then
206
            raise Constraint_Error with "new length is out of range";
207
         end if;
208
 
209
      elsif Index_Type'First <= 0 then
210
 
211
         --  Here we can compute Last directly, in the normal way. We know that
212
         --  No_Index is less than 0, so there is no danger of overflow when
213
         --  adding the (positive) value of length.
214
 
215
         J := Count_Type'Base (No_Index) + N;  -- Last
216
 
217
         if J > Count_Type'Base (Index_Type'Last) then
218
            raise Constraint_Error with "new length is out of range";
219
         end if;
220
 
221
         --  We know that the computed value (having type Count_Type) of Last
222
         --  is within the range of the generic actual index subtype, so it is
223
         --  safe to convert to Index_Type:
224
 
225
         Last := Index_Type'Base (J);
226
 
227
      else
228
         --  Here Index_Type'First (and Index_Type'Last) is positive, so we
229
         --  must test the length indirectly (by working backwards from the
230
         --  largest possible value of Last), in order to prevent overflow.
231
 
232
         J := Count_Type'Base (Index_Type'Last) - N;  -- No_Index
233
 
234
         if J < Count_Type'Base (No_Index) then
235
            raise Constraint_Error with "new length is out of range";
236
         end if;
237
 
238
         --  We have determined that the result length would not create a Last
239
         --  index value outside of the range of Index_Type, so we can now
240
         --  safely compute its value.
241
 
242
         Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
243
      end if;
244
 
245
      declare
246
         LE : Elements_Array renames
247
                Left.Elements.EA (Index_Type'First .. Left.Last);
248
 
249
         RE : Elements_Array renames
250
                Right.Elements.EA (Index_Type'First .. Right.Last);
251
 
252
         Elements : Elements_Access := new Elements_Type (Last);
253
 
254
         I : Index_Type'Base := No_Index;
255
 
256
      begin
257
         --  Elements of an indefinite vector are allocated, so we cannot use
258
         --  simple slice assignment to give a value to our result. Hence we
259
         --  must walk the array of each vector parameter, and copy each source
260
         --  element individually.
261
 
262
         for LI in LE'Range loop
263
            I := I + 1;
264
 
265
            begin
266
               if LE (LI) /= null then
267
                  Elements.EA (I) := new Element_Type'(LE (LI).all);
268
               end if;
269
 
270
            exception
271
               when others =>
272
                  for J in Index_Type'First .. I - 1 loop
273
                     Free (Elements.EA (J));
274
                  end loop;
275
 
276
                  Free (Elements);
277
                  raise;
278
            end;
279
         end loop;
280
 
281
         for RI in RE'Range loop
282
            I := I + 1;
283
 
284
            begin
285
               if RE (RI) /= null then
286
                  Elements.EA (I) := new Element_Type'(RE (RI).all);
287
               end if;
288
 
289
            exception
290
               when others =>
291
                  for J in Index_Type'First .. I - 1 loop
292
                     Free (Elements.EA (J));
293
                  end loop;
294
 
295
                  Free (Elements);
296
                  raise;
297
            end;
298
         end loop;
299
 
300
         return (Controlled with Elements, Last, 0, 0);
301
      end;
302
   end "&";
303
 
304
   function "&" (Left : Vector; Right : Element_Type) return Vector is
305
   begin
306
      --  We decide that the capacity of the result is the sum of the lengths
307
      --  of the parameters. We could decide to make it larger, but we have no
308
      --  basis for knowing how much larger, so we just allocate the minimum
309
      --  amount of storage.
310
 
311
      --  Here we handle the easy case first, when the vector parameter (Left)
312
      --  is empty.
313
 
314
      if Left.Is_Empty then
315
         declare
316
            Elements : Elements_Access := new Elements_Type (Index_Type'First);
317
 
318
         begin
319
            begin
320
               Elements.EA (Index_Type'First) := new Element_Type'(Right);
321
            exception
322
               when others =>
323
                  Free (Elements);
324
                  raise;
325
            end;
326
 
327
            return (Controlled with Elements, Index_Type'First, 0, 0);
328
         end;
329
      end if;
330
 
331
      --  The vector parameter is not empty, so we must compute the length of
332
      --  the result vector and its last index, but in such a way that overflow
333
      --  is avoided. We must satisfy two constraints: the new length cannot
334
      --  exceed Count_Type'Last, and the new Last index cannot exceed
335
      --  Index_Type'Last.
336
 
337
      if Left.Length = Count_Type'Last then
338
         raise Constraint_Error with "new length is out of range";
339
      end if;
340
 
341
      if Left.Last >= Index_Type'Last then
342
         raise Constraint_Error with "new length is out of range";
343
      end if;
344
 
345
      declare
346
         Last : constant Index_Type := Left.Last + 1;
347
 
348
         LE : Elements_Array renames
349
                 Left.Elements.EA (Index_Type'First .. Left.Last);
350
 
351
         Elements : Elements_Access :=
352
                       new Elements_Type (Last);
353
 
354
      begin
355
         for I in LE'Range loop
356
            begin
357
               if LE (I) /= null then
358
                  Elements.EA (I) := new Element_Type'(LE (I).all);
359
               end if;
360
 
361
            exception
362
               when others =>
363
                  for J in Index_Type'First .. I - 1 loop
364
                     Free (Elements.EA (J));
365
                  end loop;
366
 
367
                  Free (Elements);
368
                  raise;
369
            end;
370
         end loop;
371
 
372
         begin
373
            Elements.EA (Last) := new Element_Type'(Right);
374
 
375
         exception
376
            when others =>
377
               for J in Index_Type'First .. Last - 1 loop
378
                  Free (Elements.EA (J));
379
               end loop;
380
 
381
               Free (Elements);
382
               raise;
383
         end;
384
 
385
         return (Controlled with Elements, Last, 0, 0);
386
      end;
387
   end "&";
388
 
389
   function "&" (Left : Element_Type; Right : Vector) return Vector is
390
   begin
391
      --  We decide that the capacity of the result is the sum of the lengths
392
      --  of the parameters. We could decide to make it larger, but we have no
393
      --  basis for knowing how much larger, so we just allocate the minimum
394
      --  amount of storage.
395
 
396
      --  Here we handle the easy case first, when the vector parameter (Right)
397
      --  is empty.
398
 
399
      if Right.Is_Empty then
400
         declare
401
            Elements : Elements_Access := new Elements_Type (Index_Type'First);
402
 
403
         begin
404
            begin
405
               Elements.EA (Index_Type'First) := new Element_Type'(Left);
406
            exception
407
               when others =>
408
                  Free (Elements);
409
                  raise;
410
            end;
411
 
412
            return (Controlled with Elements, Index_Type'First, 0, 0);
413
         end;
414
      end if;
415
 
416
      --  The vector parameter is not empty, so we must compute the length of
417
      --  the result vector and its last index, but in such a way that overflow
418
      --  is avoided. We must satisfy two constraints: the new length cannot
419
      --  exceed Count_Type'Last, and the new Last index cannot exceed
420
      --  Index_Type'Last.
421
 
422
      if Right.Length = Count_Type'Last then
423
         raise Constraint_Error with "new length is out of range";
424
      end if;
425
 
426
      if Right.Last >= Index_Type'Last then
427
         raise Constraint_Error with "new length is out of range";
428
      end if;
429
 
430
      declare
431
         Last : constant Index_Type := Right.Last + 1;
432
 
433
         RE : Elements_Array renames
434
                Right.Elements.EA (Index_Type'First .. Right.Last);
435
 
436
         Elements : Elements_Access :=
437
                      new Elements_Type (Last);
438
 
439
         I : Index_Type'Base := Index_Type'First;
440
 
441
      begin
442
         begin
443
            Elements.EA (I) := new Element_Type'(Left);
444
         exception
445
            when others =>
446
               Free (Elements);
447
               raise;
448
         end;
449
 
450
         for RI in RE'Range loop
451
            I := I + 1;
452
 
453
            begin
454
               if RE (RI) /= null then
455
                  Elements.EA (I) := new Element_Type'(RE (RI).all);
456
               end if;
457
 
458
            exception
459
               when others =>
460
                  for J in Index_Type'First .. I - 1 loop
461
                     Free (Elements.EA (J));
462
                  end loop;
463
 
464
                  Free (Elements);
465
                  raise;
466
            end;
467
         end loop;
468
 
469
         return (Controlled with Elements, Last, 0, 0);
470
      end;
471
   end "&";
472
 
473
   function "&" (Left, Right : Element_Type) return Vector is
474
   begin
475
      --  We decide that the capacity of the result is the sum of the lengths
476
      --  of the parameters. We could decide to make it larger, but we have no
477
      --  basis for knowing how much larger, so we just allocate the minimum
478
      --  amount of storage.
479
 
480
      --  We must compute the length of the result vector and its last index,
481
      --  but in such a way that overflow is avoided. We must satisfy two
482
      --  constraints: the new length cannot exceed Count_Type'Last (here, we
483
      --  know that that condition is satisfied), and the new Last index cannot
484
      --  exceed Index_Type'Last.
485
 
486
      if Index_Type'First >= Index_Type'Last then
487
         raise Constraint_Error with "new length is out of range";
488
      end if;
489
 
490
      declare
491
         Last     : constant Index_Type := Index_Type'First + 1;
492
         Elements : Elements_Access := new Elements_Type (Last);
493
 
494
      begin
495
         begin
496
            Elements.EA (Index_Type'First) := new Element_Type'(Left);
497
         exception
498
            when others =>
499
               Free (Elements);
500
               raise;
501
         end;
502
 
503
         begin
504
            Elements.EA (Last) := new Element_Type'(Right);
505
         exception
506
            when others =>
507
               Free (Elements.EA (Index_Type'First));
508
               Free (Elements);
509
               raise;
510
         end;
511
 
512
         return (Controlled with Elements, Last, 0, 0);
513
      end;
514
   end "&";
515
 
516
   ---------
517
   -- "=" --
518
   ---------
519
 
520
   overriding function "=" (Left, Right : Vector) return Boolean is
521
   begin
522
      if Left'Address = Right'Address then
523
         return True;
524
      end if;
525
 
526
      if Left.Last /= Right.Last then
527
         return False;
528
      end if;
529
 
530
      for J in Index_Type'First .. Left.Last loop
531
         if Left.Elements.EA (J) = null then
532
            if Right.Elements.EA (J) /= null then
533
               return False;
534
            end if;
535
 
536
         elsif Right.Elements.EA (J) = null then
537
            return False;
538
 
539
         elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
540
            return False;
541
         end if;
542
      end loop;
543
 
544
      return True;
545
   end "=";
546
 
547
   ------------
548
   -- Adjust --
549
   ------------
550
 
551
   procedure Adjust (Container : in out Vector) is
552
   begin
553
      if Container.Last = No_Index then
554
         Container.Elements := null;
555
         return;
556
      end if;
557
 
558
      declare
559
         L : constant Index_Type := Container.Last;
560
         E : Elements_Array renames
561
               Container.Elements.EA (Index_Type'First .. L);
562
 
563
      begin
564
         Container.Elements := null;
565
         Container.Last := No_Index;
566
         Container.Busy := 0;
567
         Container.Lock := 0;
568
 
569
         Container.Elements := new Elements_Type (L);
570
 
571
         for I in E'Range loop
572
            if E (I) /= null then
573
               Container.Elements.EA (I) := new Element_Type'(E (I).all);
574
            end if;
575
 
576
            Container.Last := I;
577
         end loop;
578
      end;
579
   end Adjust;
580
 
581
   procedure Adjust (Control : in out Reference_Control_Type) is
582
   begin
583
      if Control.Container /= null then
584
         declare
585
            C : Vector renames Control.Container.all;
586
            B : Natural renames C.Busy;
587
            L : Natural renames C.Lock;
588
         begin
589
            B := B + 1;
590
            L := L + 1;
591
         end;
592
      end if;
593
   end Adjust;
594
 
595
   ------------
596
   -- Append --
597
   ------------
598
 
599
   procedure Append (Container : in out Vector; New_Item : Vector) is
600
   begin
601
      if Is_Empty (New_Item) then
602
         return;
603
      end if;
604
 
605
      if Container.Last = Index_Type'Last then
606
         raise Constraint_Error with "vector is already at its maximum length";
607
      end if;
608
 
609
      Insert
610
        (Container,
611
         Container.Last + 1,
612
         New_Item);
613
   end Append;
614
 
615
   procedure Append
616
     (Container : in out Vector;
617
      New_Item  : Element_Type;
618
      Count     : Count_Type := 1)
619
   is
620
   begin
621
      if Count = 0 then
622
         return;
623
      end if;
624
 
625
      if Container.Last = Index_Type'Last then
626
         raise Constraint_Error with "vector is already at its maximum length";
627
      end if;
628
 
629
      Insert
630
        (Container,
631
         Container.Last + 1,
632
         New_Item,
633
         Count);
634
   end Append;
635
 
636
   ------------
637
   -- Assign --
638
   ------------
639
 
640
   procedure Assign (Target : in out Vector; Source : Vector) is
641
   begin
642
      if Target'Address = Source'Address then
643
         return;
644
      end if;
645
 
646
      Target.Clear;
647
      Target.Append (Source);
648
   end Assign;
649
 
650
   --------------
651
   -- Capacity --
652
   --------------
653
 
654
   function Capacity (Container : Vector) return Count_Type is
655
   begin
656
      if Container.Elements = null then
657
         return 0;
658
      end if;
659
 
660
      return Container.Elements.EA'Length;
661
   end Capacity;
662
 
663
   -----------
664
   -- Clear --
665
   -----------
666
 
667
   procedure Clear (Container : in out Vector) is
668
   begin
669
      if Container.Busy > 0 then
670
         raise Program_Error with
671
           "attempt to tamper with cursors (vector is busy)";
672
      end if;
673
 
674
      while Container.Last >= Index_Type'First loop
675
         declare
676
            X : Element_Access := Container.Elements.EA (Container.Last);
677
         begin
678
            Container.Elements.EA (Container.Last) := null;
679
            Container.Last := Container.Last - 1;
680
            Free (X);
681
         end;
682
      end loop;
683
   end Clear;
684
 
685
   ------------------------
686
   -- Constant_Reference --
687
   ------------------------
688
 
689
   function Constant_Reference
690
     (Container : aliased Vector;
691
      Position  : Cursor) return Constant_Reference_Type
692
   is
693
      E : Element_Access;
694
 
695
   begin
696
      if Position.Container = null then
697
         raise Constraint_Error with "Position cursor has no element";
698
      end if;
699
 
700
      if Position.Container /= Container'Unrestricted_Access then
701
         raise Program_Error with "Position cursor denotes wrong container";
702
      end if;
703
 
704
      if Position.Index > Position.Container.Last then
705
         raise Constraint_Error with "Position cursor is out of range";
706
      end if;
707
 
708
      E := Container.Elements.EA (Position.Index);
709
 
710
      if E = null then
711
         raise Constraint_Error with "element at Position is empty";
712
      end if;
713
 
714
      declare
715
         C : Vector renames Container'Unrestricted_Access.all;
716
         B : Natural renames C.Busy;
717
         L : Natural renames C.Lock;
718
      begin
719
         return R : constant Constant_Reference_Type :=
720
                      (Element => E.all'Access,
721
                       Control =>
722
                         (Controlled with Container'Unrestricted_Access))
723
         do
724
            B := B + 1;
725
            L := L + 1;
726
         end return;
727
      end;
728
   end Constant_Reference;
729
 
730
   function Constant_Reference
731
     (Container : aliased Vector;
732
      Index     : Index_Type) return Constant_Reference_Type
733
   is
734
      E : Element_Access;
735
 
736
   begin
737
      if Index > Container.Last then
738
         raise Constraint_Error with "Index is out of range";
739
      end if;
740
 
741
      E := Container.Elements.EA (Index);
742
 
743
      if E = null then
744
         raise Constraint_Error with "element at Index is empty";
745
      end if;
746
 
747
      declare
748
         C : Vector renames Container'Unrestricted_Access.all;
749
         B : Natural renames C.Busy;
750
         L : Natural renames C.Lock;
751
      begin
752
         return R : constant Constant_Reference_Type :=
753
                      (Element => E.all'Access,
754
                       Control =>
755
                         (Controlled with Container'Unrestricted_Access))
756
         do
757
            B := B + 1;
758
            L := L + 1;
759
         end return;
760
      end;
761
   end Constant_Reference;
762
 
763
   --------------
764
   -- Contains --
765
   --------------
766
 
767
   function Contains
768
     (Container : Vector;
769
      Item      : Element_Type) return Boolean
770
   is
771
   begin
772
      return Find_Index (Container, Item) /= No_Index;
773
   end Contains;
774
 
775
   ----------
776
   -- Copy --
777
   ----------
778
 
779
   function Copy
780
     (Source   : Vector;
781
      Capacity : Count_Type := 0) return Vector
782
   is
783
      C : Count_Type;
784
 
785
   begin
786
      if Capacity = 0 then
787
         C := Source.Length;
788
 
789
      elsif Capacity >= Source.Length then
790
         C := Capacity;
791
 
792
      else
793
         raise Capacity_Error
794
           with "Requested capacity is less than Source length";
795
      end if;
796
 
797
      return Target : Vector do
798
         Target.Reserve_Capacity (C);
799
         Target.Assign (Source);
800
      end return;
801
   end Copy;
802
 
803
   ------------
804
   -- Delete --
805
   ------------
806
 
807
   procedure Delete
808
     (Container : in out Vector;
809
      Index     : Extended_Index;
810
      Count     : Count_Type := 1)
811
   is
812
      Old_Last : constant Index_Type'Base := Container.Last;
813
      New_Last : Index_Type'Base;
814
      Count2   : Count_Type'Base;  -- count of items from Index to Old_Last
815
      J        : Index_Type'Base;  -- first index of items that slide down
816
 
817
   begin
818
      --  Delete removes items from the vector, the number of which is the
819
      --  minimum of the specified Count and the items (if any) that exist from
820
      --  Index to Container.Last. There are no constraints on the specified
821
      --  value of Count (it can be larger than what's available at this
822
      --  position in the vector, for example), but there are constraints on
823
      --  the allowed values of the Index.
824
 
825
      --  As a precondition on the generic actual Index_Type, the base type
826
      --  must include Index_Type'Pred (Index_Type'First); this is the value
827
      --  that Container.Last assumes when the vector is empty. However, we do
828
      --  not allow that as the value for Index when specifying which items
829
      --  should be deleted, so we must manually check. (That the user is
830
      --  allowed to specify the value at all here is a consequence of the
831
      --  declaration of the Extended_Index subtype, which includes the values
832
      --  in the base range that immediately precede and immediately follow the
833
      --  values in the Index_Type.)
834
 
835
      if Index < Index_Type'First then
836
         raise Constraint_Error with "Index is out of range (too small)";
837
      end if;
838
 
839
      --  We do allow a value greater than Container.Last to be specified as
840
      --  the Index, but only if it's immediately greater. This allows the
841
      --  corner case of deleting no items from the back end of the vector to
842
      --  be treated as a no-op. (It is assumed that specifying an index value
843
      --  greater than Last + 1 indicates some deeper flaw in the caller's
844
      --  algorithm, so that case is treated as a proper error.)
845
 
846
      if Index > Old_Last then
847
         if Index > Old_Last + 1 then
848
            raise Constraint_Error with "Index is out of range (too large)";
849
         end if;
850
 
851
         return;
852
      end if;
853
 
854
      --  Here and elsewhere we treat deleting 0 items from the container as a
855
      --  no-op, even when the container is busy, so we simply return.
856
 
857
      if Count = 0 then
858
         return;
859
      end if;
860
 
861
      --  The internal elements array isn't guaranteed to exist unless we have
862
      --  elements, so we handle that case here in order to avoid having to
863
      --  check it later. (Note that an empty vector can never be busy, so
864
      --  there's no semantic harm in returning early.)
865
 
866
      if Container.Is_Empty then
867
         return;
868
      end if;
869
 
870
      --  The tampering bits exist to prevent an item from being deleted (or
871
      --  otherwise harmfully manipulated) while it is being visited. Query,
872
      --  Update, and Iterate increment the busy count on entry, and decrement
873
      --  the count on exit. Delete checks the count to determine whether it is
874
      --  being called while the associated callback procedure is executing.
875
 
876
      if Container.Busy > 0 then
877
         raise Program_Error with
878
           "attempt to tamper with cursors (vector is busy)";
879
      end if;
880
 
881
      --  We first calculate what's available for deletion starting at
882
      --  Index. Here and elsewhere we use the wider of Index_Type'Base and
883
      --  Count_Type'Base as the type for intermediate values. (See function
884
      --  Length for more information.)
885
 
886
      if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
887
         Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
888
 
889
      else
890
         Count2 := Count_Type'Base (Old_Last - Index + 1);
891
      end if;
892
 
893
      --  If the number of elements requested (Count) for deletion is equal to
894
      --  (or greater than) the number of elements available (Count2) for
895
      --  deletion beginning at Index, then everything from Index to
896
      --  Container.Last is deleted (this is equivalent to Delete_Last).
897
 
898
      if Count >= Count2 then
899
         --  Elements in an indefinite vector are allocated, so we must iterate
900
         --  over the loop and deallocate elements one-at-a-time. We work from
901
         --  back to front, deleting the last element during each pass, in
902
         --  order to gracefully handle deallocation failures.
903
 
904
         declare
905
            EA : Elements_Array renames Container.Elements.EA;
906
 
907
         begin
908
            while Container.Last >= Index loop
909
               declare
910
                  K : constant Index_Type := Container.Last;
911
                  X : Element_Access := EA (K);
912
 
913
               begin
914
                  --  We first isolate the element we're deleting, removing it
915
                  --  from the vector before we attempt to deallocate it, in
916
                  --  case the deallocation fails.
917
 
918
                  EA (K) := null;
919
                  Container.Last := K - 1;
920
 
921
                  --  Container invariants have been restored, so it is now
922
                  --  safe to attempt to deallocate the element.
923
 
924
                  Free (X);
925
               end;
926
            end loop;
927
         end;
928
 
929
         return;
930
      end if;
931
 
932
      --  There are some elements that aren't being deleted (the requested
933
      --  count was less than the available count), so we must slide them down
934
      --  to Index. We first calculate the index values of the respective array
935
      --  slices, using the wider of Index_Type'Base and Count_Type'Base as the
936
      --  type for intermediate calculations. For the elements that slide down,
937
      --  index value New_Last is the last index value of their new home, and
938
      --  index value J is the first index of their old home.
939
 
940
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
941
         New_Last := Old_Last - Index_Type'Base (Count);
942
         J := Index + Index_Type'Base (Count);
943
 
944
      else
945
         New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
946
         J := Index_Type'Base (Count_Type'Base (Index) + Count);
947
      end if;
948
 
949
      --  The internal elements array isn't guaranteed to exist unless we have
950
      --  elements, but we have that guarantee here because we know we have
951
      --  elements to slide.  The array index values for each slice have
952
      --  already been determined, so what remains to be done is to first
953
      --  deallocate the elements that are being deleted, and then slide down
954
      --  to Index the elements that aren't being deleted.
955
 
956
      declare
957
         EA : Elements_Array renames Container.Elements.EA;
958
 
959
      begin
960
         --  Before we can slide down the elements that aren't being deleted,
961
         --  we need to deallocate the elements that are being deleted.
962
 
963
         for K in Index .. J - 1 loop
964
            declare
965
               X : Element_Access := EA (K);
966
 
967
            begin
968
               --  First we remove the element we're about to deallocate from
969
               --  the vector, in case the deallocation fails, in order to
970
               --  preserve representation invariants.
971
 
972
               EA (K) := null;
973
 
974
               --  The element has been removed from the vector, so it is now
975
               --  safe to attempt to deallocate it.
976
 
977
               Free (X);
978
            end;
979
         end loop;
980
 
981
         EA (Index .. New_Last) := EA (J .. Old_Last);
982
         Container.Last := New_Last;
983
      end;
984
   end Delete;
985
 
986
   procedure Delete
987
     (Container : in out Vector;
988
      Position  : in out Cursor;
989
      Count     : Count_Type := 1)
990
   is
991
      pragma Warnings (Off, Position);
992
 
993
   begin
994
      if Position.Container = null then
995
         raise Constraint_Error with "Position cursor has no element";
996
      end if;
997
 
998
      if Position.Container /= Container'Unrestricted_Access then
999
         raise Program_Error with "Position cursor denotes wrong container";
1000
      end if;
1001
 
1002
      if Position.Index > Container.Last then
1003
         raise Program_Error with "Position index is out of range";
1004
      end if;
1005
 
1006
      Delete (Container, Position.Index, Count);
1007
 
1008
      Position := No_Element;
1009
   end Delete;
1010
 
1011
   ------------------
1012
   -- Delete_First --
1013
   ------------------
1014
 
1015
   procedure Delete_First
1016
     (Container : in out Vector;
1017
      Count     : Count_Type := 1)
1018
   is
1019
   begin
1020
      if Count = 0 then
1021
         return;
1022
      end if;
1023
 
1024
      if Count >= Length (Container) then
1025
         Clear (Container);
1026
         return;
1027
      end if;
1028
 
1029
      Delete (Container, Index_Type'First, Count);
1030
   end Delete_First;
1031
 
1032
   -----------------
1033
   -- Delete_Last --
1034
   -----------------
1035
 
1036
   procedure Delete_Last
1037
     (Container : in out Vector;
1038
      Count     : Count_Type := 1)
1039
   is
1040
   begin
1041
      --  It is not permitted to delete items while the container is busy (for
1042
      --  example, we're in the middle of a passive iteration). However, we
1043
      --  always treat deleting 0 items as a no-op, even when we're busy, so we
1044
      --  simply return without checking.
1045
 
1046
      if Count = 0 then
1047
         return;
1048
      end if;
1049
 
1050
      --  We cannot simply subsume the empty case into the loop below (the loop
1051
      --  would iterate 0 times), because we rename the internal array object
1052
      --  (which is allocated), but an empty vector isn't guaranteed to have
1053
      --  actually allocated an array. (Note that an empty vector can never be
1054
      --  busy, so there's no semantic harm in returning early here.)
1055
 
1056
      if Container.Is_Empty then
1057
         return;
1058
      end if;
1059
 
1060
      --  The tampering bits exist to prevent an item from being deleted (or
1061
      --  otherwise harmfully manipulated) while it is being visited. Query,
1062
      --  Update, and Iterate increment the busy count on entry, and decrement
1063
      --  the count on exit. Delete_Last checks the count to determine whether
1064
      --  it is being called while the associated callback procedure is
1065
      --  executing.
1066
 
1067
      if Container.Busy > 0 then
1068
         raise Program_Error with
1069
           "attempt to tamper with cursors (vector is busy)";
1070
      end if;
1071
 
1072
      --  Elements in an indefinite vector are allocated, so we must iterate
1073
      --  over the loop and deallocate elements one-at-a-time. We work from
1074
      --  back to front, deleting the last element during each pass, in order
1075
      --  to gracefully handle deallocation failures.
1076
 
1077
      declare
1078
         E : Elements_Array renames Container.Elements.EA;
1079
 
1080
      begin
1081
         for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop
1082
            declare
1083
               J : constant Index_Type := Container.Last;
1084
               X : Element_Access := E (J);
1085
 
1086
            begin
1087
               --  Note that we first isolate the element we're deleting,
1088
               --  removing it from the vector, before we actually deallocate
1089
               --  it, in order to preserve representation invariants even if
1090
               --  the deallocation fails.
1091
 
1092
               E (J) := null;
1093
               Container.Last := J - 1;
1094
 
1095
               --  Container invariants have been restored, so it is now safe
1096
               --  to deallocate the element.
1097
 
1098
               Free (X);
1099
            end;
1100
         end loop;
1101
      end;
1102
   end Delete_Last;
1103
 
1104
   -------------
1105
   -- Element --
1106
   -------------
1107
 
1108
   function Element
1109
     (Container : Vector;
1110
      Index     : Index_Type) return Element_Type
1111
   is
1112
   begin
1113
      if Index > Container.Last then
1114
         raise Constraint_Error with "Index is out of range";
1115
      end if;
1116
 
1117
      declare
1118
         EA : constant Element_Access := Container.Elements.EA (Index);
1119
 
1120
      begin
1121
         if EA = null then
1122
            raise Constraint_Error with "element is empty";
1123
         end if;
1124
 
1125
         return EA.all;
1126
      end;
1127
   end Element;
1128
 
1129
   function Element (Position : Cursor) return Element_Type is
1130
   begin
1131
      if Position.Container = null then
1132
         raise Constraint_Error with "Position cursor has no element";
1133
      end if;
1134
 
1135
      if Position.Index > Position.Container.Last then
1136
         raise Constraint_Error with "Position cursor is out of range";
1137
      end if;
1138
 
1139
      declare
1140
         EA : constant Element_Access :=
1141
                Position.Container.Elements.EA (Position.Index);
1142
 
1143
      begin
1144
         if EA = null then
1145
            raise Constraint_Error with "element is empty";
1146
         end if;
1147
 
1148
         return EA.all;
1149
      end;
1150
   end Element;
1151
 
1152
   --------------
1153
   -- Finalize --
1154
   --------------
1155
 
1156
   procedure Finalize (Container : in out Vector) is
1157
   begin
1158
      Clear (Container);  --  Checks busy-bit
1159
 
1160
      declare
1161
         X : Elements_Access := Container.Elements;
1162
      begin
1163
         Container.Elements := null;
1164
         Free (X);
1165
      end;
1166
   end Finalize;
1167
 
1168
   procedure Finalize (Object : in out Iterator) is
1169
      B : Natural renames Object.Container.Busy;
1170
   begin
1171
      B := B - 1;
1172
   end Finalize;
1173
 
1174
   procedure Finalize (Control : in out Reference_Control_Type) is
1175
   begin
1176
      if Control.Container /= null then
1177
         declare
1178
            C : Vector renames Control.Container.all;
1179
            B : Natural renames C.Busy;
1180
            L : Natural renames C.Lock;
1181
         begin
1182
            B := B - 1;
1183
            L := L - 1;
1184
         end;
1185
 
1186
         Control.Container := null;
1187
      end if;
1188
   end Finalize;
1189
 
1190
   ----------
1191
   -- Find --
1192
   ----------
1193
 
1194
   function Find
1195
     (Container : Vector;
1196
      Item      : Element_Type;
1197
      Position  : Cursor := No_Element) return Cursor
1198
   is
1199
   begin
1200
      if Position.Container /= null then
1201
         if Position.Container /= Container'Unrestricted_Access then
1202
            raise Program_Error with "Position cursor denotes wrong container";
1203
         end if;
1204
 
1205
         if Position.Index > Container.Last then
1206
            raise Program_Error with "Position index is out of range";
1207
         end if;
1208
      end if;
1209
 
1210
      for J in Position.Index .. Container.Last loop
1211
         if Container.Elements.EA (J) /= null
1212
           and then Container.Elements.EA (J).all = Item
1213
         then
1214
            return (Container'Unrestricted_Access, J);
1215
         end if;
1216
      end loop;
1217
 
1218
      return No_Element;
1219
   end Find;
1220
 
1221
   ----------------
1222
   -- Find_Index --
1223
   ----------------
1224
 
1225
   function Find_Index
1226
     (Container : Vector;
1227
      Item      : Element_Type;
1228
      Index     : Index_Type := Index_Type'First) return Extended_Index
1229
   is
1230
   begin
1231
      for Indx in Index .. Container.Last loop
1232
         if Container.Elements.EA (Indx) /= null
1233
           and then Container.Elements.EA (Indx).all = Item
1234
         then
1235
            return Indx;
1236
         end if;
1237
      end loop;
1238
 
1239
      return No_Index;
1240
   end Find_Index;
1241
 
1242
   -----------
1243
   -- First --
1244
   -----------
1245
 
1246
   function First (Container : Vector) return Cursor is
1247
   begin
1248
      if Is_Empty (Container) then
1249
         return No_Element;
1250
      end if;
1251
 
1252
      return (Container'Unrestricted_Access, Index_Type'First);
1253
   end First;
1254
 
1255
   function First (Object : Iterator) return Cursor is
1256
   begin
1257
      --  The value of the iterator object's Index component influences the
1258
      --  behavior of the First (and Last) selector function.
1259
 
1260
      --  When the Index component is No_Index, this means the iterator
1261
      --  object was constructed without a start expression, in which case the
1262
      --  (forward) iteration starts from the (logical) beginning of the entire
1263
      --  sequence of items (corresponding to Container.First, for a forward
1264
      --  iterator).
1265
 
1266
      --  Otherwise, this is iteration over a partial sequence of items.
1267
      --  When the Index component isn't No_Index, the iterator object was
1268
      --  constructed with a start expression, that specifies the position
1269
      --  from which the (forward) partial iteration begins.
1270
 
1271
      if Object.Index = No_Index then
1272
         return First (Object.Container.all);
1273
      else
1274
         return Cursor'(Object.Container, Object.Index);
1275
      end if;
1276
   end First;
1277
 
1278
   -------------------
1279
   -- First_Element --
1280
   -------------------
1281
 
1282
   function First_Element (Container : Vector) return Element_Type is
1283
   begin
1284
      if Container.Last = No_Index then
1285
         raise Constraint_Error with "Container is empty";
1286
      end if;
1287
 
1288
      declare
1289
         EA : constant Element_Access :=
1290
                Container.Elements.EA (Index_Type'First);
1291
 
1292
      begin
1293
         if EA = null then
1294
            raise Constraint_Error with "first element is empty";
1295
         end if;
1296
 
1297
         return EA.all;
1298
      end;
1299
   end First_Element;
1300
 
1301
   -----------------
1302
   -- First_Index --
1303
   -----------------
1304
 
1305
   function First_Index (Container : Vector) return Index_Type is
1306
      pragma Unreferenced (Container);
1307
   begin
1308
      return Index_Type'First;
1309
   end First_Index;
1310
 
1311
   ---------------------
1312
   -- Generic_Sorting --
1313
   ---------------------
1314
 
1315
   package body Generic_Sorting is
1316
 
1317
      -----------------------
1318
      -- Local Subprograms --
1319
      -----------------------
1320
 
1321
      function Is_Less (L, R : Element_Access) return Boolean;
1322
      pragma Inline (Is_Less);
1323
 
1324
      -------------
1325
      -- Is_Less --
1326
      -------------
1327
 
1328
      function Is_Less (L, R : Element_Access) return Boolean is
1329
      begin
1330
         if L = null then
1331
            return R /= null;
1332
         elsif R = null then
1333
            return False;
1334
         else
1335
            return L.all < R.all;
1336
         end if;
1337
      end Is_Less;
1338
 
1339
      ---------------
1340
      -- Is_Sorted --
1341
      ---------------
1342
 
1343
      function Is_Sorted (Container : Vector) return Boolean is
1344
      begin
1345
         if Container.Last <= Index_Type'First then
1346
            return True;
1347
         end if;
1348
 
1349
         declare
1350
            E : Elements_Array renames Container.Elements.EA;
1351
         begin
1352
            for I in Index_Type'First .. Container.Last - 1 loop
1353
               if Is_Less (E (I + 1), E (I)) then
1354
                  return False;
1355
               end if;
1356
            end loop;
1357
         end;
1358
 
1359
         return True;
1360
      end Is_Sorted;
1361
 
1362
      -----------
1363
      -- Merge --
1364
      -----------
1365
 
1366
      procedure Merge (Target, Source : in out Vector) is
1367
         I, J : Index_Type'Base;
1368
 
1369
      begin
1370
 
1371
         --  The semantics of Merge changed slightly per AI05-0021. It was
1372
         --  originally the case that if Target and Source denoted the same
1373
         --  container object, then the GNAT implementation of Merge did
1374
         --  nothing. However, it was argued that RM05 did not precisely
1375
         --  specify the semantics for this corner case. The decision of the
1376
         --  ARG was that if Target and Source denote the same non-empty
1377
         --  container object, then Program_Error is raised.
1378
 
1379
         if Source.Last < Index_Type'First then  -- Source is empty
1380
            return;
1381
         end if;
1382
 
1383
         if Target'Address = Source'Address then
1384
            raise Program_Error with
1385
              "Target and Source denote same non-empty container";
1386
         end if;
1387
 
1388
         if Target.Last < Index_Type'First then  -- Target is empty
1389
            Move (Target => Target, Source => Source);
1390
            return;
1391
         end if;
1392
 
1393
         if Source.Busy > 0 then
1394
            raise Program_Error with
1395
              "attempt to tamper with cursors (vector is busy)";
1396
         end if;
1397
 
1398
         I := Target.Last;  -- original value (before Set_Length)
1399
         Target.Set_Length (Length (Target) + Length (Source));
1400
 
1401
         J := Target.Last;  -- new value (after Set_Length)
1402
         while Source.Last >= Index_Type'First loop
1403
            pragma Assert
1404
              (Source.Last <= Index_Type'First
1405
                 or else not (Is_Less
1406
                                (Source.Elements.EA (Source.Last),
1407
                                 Source.Elements.EA (Source.Last - 1))));
1408
 
1409
            if I < Index_Type'First then
1410
               declare
1411
                  Src : Elements_Array renames
1412
                    Source.Elements.EA (Index_Type'First .. Source.Last);
1413
 
1414
               begin
1415
                  Target.Elements.EA (Index_Type'First .. J) := Src;
1416
                  Src := (others => null);
1417
               end;
1418
 
1419
               Source.Last := No_Index;
1420
               return;
1421
            end if;
1422
 
1423
            pragma Assert
1424
              (I <= Index_Type'First
1425
                 or else not (Is_Less
1426
                                (Target.Elements.EA (I),
1427
                                 Target.Elements.EA (I - 1))));
1428
 
1429
            declare
1430
               Src : Element_Access renames Source.Elements.EA (Source.Last);
1431
               Tgt : Element_Access renames Target.Elements.EA (I);
1432
 
1433
            begin
1434
               if Is_Less (Src, Tgt) then
1435
                  Target.Elements.EA (J) := Tgt;
1436
                  Tgt := null;
1437
                  I := I - 1;
1438
 
1439
               else
1440
                  Target.Elements.EA (J) := Src;
1441
                  Src := null;
1442
                  Source.Last := Source.Last - 1;
1443
               end if;
1444
            end;
1445
 
1446
            J := J - 1;
1447
         end loop;
1448
      end Merge;
1449
 
1450
      ----------
1451
      -- Sort --
1452
      ----------
1453
 
1454
      procedure Sort (Container : in out Vector) is
1455
         procedure Sort is new Generic_Array_Sort
1456
           (Index_Type   => Index_Type,
1457
            Element_Type => Element_Access,
1458
            Array_Type   => Elements_Array,
1459
            "<"          => Is_Less);
1460
 
1461
      --  Start of processing for Sort
1462
 
1463
      begin
1464
         if Container.Last <= Index_Type'First then
1465
            return;
1466
         end if;
1467
 
1468
         --  The exception behavior for the vector container must match that
1469
         --  for the list container, so we check for cursor tampering here
1470
         --  (which will catch more things) instead of for element tampering
1471
         --  (which will catch fewer things). It's true that the elements of
1472
         --  this vector container could be safely moved around while (say) an
1473
         --  iteration is taking place (iteration only increments the busy
1474
         --  counter), and so technically all we would need here is a test for
1475
         --  element tampering (indicated by the lock counter), that's simply
1476
         --  an artifact of our array-based implementation. Logically Sort
1477
         --  requires a check for cursor tampering.
1478
 
1479
         if Container.Busy > 0 then
1480
            raise Program_Error with
1481
              "attempt to tamper with cursors (vector is busy)";
1482
         end if;
1483
 
1484
         Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1485
      end Sort;
1486
 
1487
   end Generic_Sorting;
1488
 
1489
   -----------------
1490
   -- Has_Element --
1491
   -----------------
1492
 
1493
   function Has_Element (Position : Cursor) return Boolean is
1494
   begin
1495
      if Position.Container = null then
1496
         return False;
1497
      end if;
1498
 
1499
      return Position.Index <= Position.Container.Last;
1500
   end Has_Element;
1501
 
1502
   ------------
1503
   -- Insert --
1504
   ------------
1505
 
1506
   procedure Insert
1507
     (Container : in out Vector;
1508
      Before    : Extended_Index;
1509
      New_Item  : Element_Type;
1510
      Count     : Count_Type := 1)
1511
   is
1512
      Old_Length : constant Count_Type := Container.Length;
1513
 
1514
      Max_Length : Count_Type'Base;  -- determined from range of Index_Type
1515
      New_Length : Count_Type'Base;  -- sum of current length and Count
1516
      New_Last   : Index_Type'Base;  -- last index of vector after insertion
1517
 
1518
      Index : Index_Type'Base;  -- scratch for intermediate values
1519
      J     : Count_Type'Base;  -- scratch
1520
 
1521
      New_Capacity : Count_Type'Base;  -- length of new, expanded array
1522
      Dst_Last     : Index_Type'Base;  -- last index of new, expanded array
1523
      Dst          : Elements_Access;  -- new, expanded internal array
1524
 
1525
   begin
1526
      --  As a precondition on the generic actual Index_Type, the base type
1527
      --  must include Index_Type'Pred (Index_Type'First); this is the value
1528
      --  that Container.Last assumes when the vector is empty. However, we do
1529
      --  not allow that as the value for Index when specifying where the new
1530
      --  items should be inserted, so we must manually check. (That the user
1531
      --  is allowed to specify the value at all here is a consequence of the
1532
      --  declaration of the Extended_Index subtype, which includes the values
1533
      --  in the base range that immediately precede and immediately follow the
1534
      --  values in the Index_Type.)
1535
 
1536
      if Before < Index_Type'First then
1537
         raise Constraint_Error with
1538
           "Before index is out of range (too small)";
1539
      end if;
1540
 
1541
      --  We do allow a value greater than Container.Last to be specified as
1542
      --  the Index, but only if it's immediately greater. This allows for the
1543
      --  case of appending items to the back end of the vector. (It is assumed
1544
      --  that specifying an index value greater than Last + 1 indicates some
1545
      --  deeper flaw in the caller's algorithm, so that case is treated as a
1546
      --  proper error.)
1547
 
1548
      if Before > Container.Last
1549
        and then Before > Container.Last + 1
1550
      then
1551
         raise Constraint_Error with
1552
           "Before index is out of range (too large)";
1553
      end if;
1554
 
1555
      --  We treat inserting 0 items into the container as a no-op, even when
1556
      --  the container is busy, so we simply return.
1557
 
1558
      if Count = 0 then
1559
         return;
1560
      end if;
1561
 
1562
      --  There are two constraints we need to satisfy. The first constraint is
1563
      --  that a container cannot have more than Count_Type'Last elements, so
1564
      --  we must check the sum of the current length and the insertion count.
1565
      --  Note that we cannot simply add these values, because of the
1566
      --  possibility of overflow.
1567
 
1568
      if Old_Length > Count_Type'Last - Count then
1569
         raise Constraint_Error with "Count is out of range";
1570
      end if;
1571
 
1572
      --  It is now safe compute the length of the new vector, without fear of
1573
      --  overflow.
1574
 
1575
      New_Length := Old_Length + Count;
1576
 
1577
      --  The second constraint is that the new Last index value cannot exceed
1578
      --  Index_Type'Last. In each branch below, we calculate the maximum
1579
      --  length (computed from the range of values in Index_Type), and then
1580
      --  compare the new length to the maximum length. If the new length is
1581
      --  acceptable, then we compute the new last index from that.
1582
 
1583
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1584
 
1585
         --  We have to handle the case when there might be more values in the
1586
         --  range of Index_Type than in the range of Count_Type.
1587
 
1588
         if Index_Type'First <= 0 then
1589
 
1590
            --  We know that No_Index (the same as Index_Type'First - 1) is
1591
            --  less than 0, so it is safe to compute the following sum without
1592
            --  fear of overflow.
1593
 
1594
            Index := No_Index + Index_Type'Base (Count_Type'Last);
1595
 
1596
            if Index <= Index_Type'Last then
1597
 
1598
               --  We have determined that range of Index_Type has at least as
1599
               --  many values as in Count_Type, so Count_Type'Last is the
1600
               --  maximum number of items that are allowed.
1601
 
1602
               Max_Length := Count_Type'Last;
1603
 
1604
            else
1605
               --  The range of Index_Type has fewer values than in Count_Type,
1606
               --  so the maximum number of items is computed from the range of
1607
               --  the Index_Type.
1608
 
1609
               Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1610
            end if;
1611
 
1612
         else
1613
            --  No_Index is equal or greater than 0, so we can safely compute
1614
            --  the difference without fear of overflow (which we would have to
1615
            --  worry about if No_Index were less than 0, but that case is
1616
            --  handled above).
1617
 
1618
            Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1619
         end if;
1620
 
1621
      elsif Index_Type'First <= 0 then
1622
 
1623
         --  We know that No_Index (the same as Index_Type'First - 1) is less
1624
         --  than 0, so it is safe to compute the following sum without fear of
1625
         --  overflow.
1626
 
1627
         J := Count_Type'Base (No_Index) + Count_Type'Last;
1628
 
1629
         if J <= Count_Type'Base (Index_Type'Last) then
1630
 
1631
            --  We have determined that range of Index_Type has at least as
1632
            --  many values as in Count_Type, so Count_Type'Last is the maximum
1633
            --  number of items that are allowed.
1634
 
1635
            Max_Length := Count_Type'Last;
1636
 
1637
         else
1638
            --  The range of Index_Type has fewer values than Count_Type does,
1639
            --  so the maximum number of items is computed from the range of
1640
            --  the Index_Type.
1641
 
1642
            Max_Length :=
1643
              Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1644
         end if;
1645
 
1646
      else
1647
         --  No_Index is equal or greater than 0, so we can safely compute the
1648
         --  difference without fear of overflow (which we would have to worry
1649
         --  about if No_Index were less than 0, but that case is handled
1650
         --  above).
1651
 
1652
         Max_Length :=
1653
           Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1654
      end if;
1655
 
1656
      --  We have just computed the maximum length (number of items). We must
1657
      --  now compare the requested length to the maximum length, as we do not
1658
      --  allow a vector expand beyond the maximum (because that would create
1659
      --  an internal array with a last index value greater than
1660
      --  Index_Type'Last, with no way to index those elements).
1661
 
1662
      if New_Length > Max_Length then
1663
         raise Constraint_Error with "Count is out of range";
1664
      end if;
1665
 
1666
      --  New_Last is the last index value of the items in the container after
1667
      --  insertion.  Use the wider of Index_Type'Base and Count_Type'Base to
1668
      --  compute its value from the New_Length.
1669
 
1670
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1671
         New_Last := No_Index + Index_Type'Base (New_Length);
1672
 
1673
      else
1674
         New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1675
      end if;
1676
 
1677
      if Container.Elements = null then
1678
         pragma Assert (Container.Last = No_Index);
1679
 
1680
         --  This is the simplest case, with which we must always begin: we're
1681
         --  inserting items into an empty vector that hasn't allocated an
1682
         --  internal array yet. Note that we don't need to check the busy bit
1683
         --  here, because an empty container cannot be busy.
1684
 
1685
         --  In an indefinite vector, elements are allocated individually, and
1686
         --  stored as access values on the internal array (the length of which
1687
         --  represents the vector "capacity"), which is separately allocated.
1688
 
1689
         Container.Elements := new Elements_Type (New_Last);
1690
 
1691
         --  The element backbone has been successfully allocated, so now we
1692
         --  allocate the elements.
1693
 
1694
         for Idx in Container.Elements.EA'Range loop
1695
 
1696
            --  In order to preserve container invariants, we always attempt
1697
            --  the element allocation first, before setting the Last index
1698
            --  value, in case the allocation fails (either because there is no
1699
            --  storage available, or because element initialization fails).
1700
 
1701
            Container.Elements.EA (Idx) := new Element_Type'(New_Item);
1702
 
1703
            --  The allocation of the element succeeded, so it is now safe to
1704
            --  update the Last index, restoring container invariants.
1705
 
1706
            Container.Last := Idx;
1707
         end loop;
1708
 
1709
         return;
1710
      end if;
1711
 
1712
      --  The tampering bits exist to prevent an item from being harmfully
1713
      --  manipulated while it is being visited. Query, Update, and Iterate
1714
      --  increment the busy count on entry, and decrement the count on
1715
      --  exit. Insert checks the count to determine whether it is being called
1716
      --  while the associated callback procedure is executing.
1717
 
1718
      if Container.Busy > 0 then
1719
         raise Program_Error with
1720
           "attempt to tamper with cursors (vector is busy)";
1721
      end if;
1722
 
1723
      if New_Length <= Container.Elements.EA'Length then
1724
 
1725
         --  In this case, we're inserting elements into a vector that has
1726
         --  already allocated an internal array, and the existing array has
1727
         --  enough unused storage for the new items.
1728
 
1729
         declare
1730
            E : Elements_Array renames Container.Elements.EA;
1731
            K : Index_Type'Base;
1732
 
1733
         begin
1734
            if Before > Container.Last then
1735
 
1736
               --  The new items are being appended to the vector, so no
1737
               --  sliding of existing elements is required.
1738
 
1739
               for Idx in Before .. New_Last loop
1740
 
1741
                  --  In order to preserve container invariants, we always
1742
                  --  attempt the element allocation first, before setting the
1743
                  --  Last index value, in case the allocation fails (either
1744
                  --  because there is no storage available, or because element
1745
                  --  initialization fails).
1746
 
1747
                  E (Idx) := new Element_Type'(New_Item);
1748
 
1749
                  --  The allocation of the element succeeded, so it is now
1750
                  --  safe to update the Last index, restoring container
1751
                  --  invariants.
1752
 
1753
                  Container.Last := Idx;
1754
               end loop;
1755
 
1756
            else
1757
               --  The new items are being inserted before some existing
1758
               --  elements, so we must slide the existing elements up to their
1759
               --  new home. We use the wider of Index_Type'Base and
1760
               --  Count_Type'Base as the type for intermediate index values.
1761
 
1762
               if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1763
                  Index := Before + Index_Type'Base (Count);
1764
               else
1765
                  Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1766
               end if;
1767
 
1768
               --  The new items are being inserted in the middle of the array,
1769
               --  in the range [Before, Index). Copy the existing elements to
1770
               --  the end of the array, to make room for the new items.
1771
 
1772
               E (Index .. New_Last) := E (Before .. Container.Last);
1773
               Container.Last := New_Last;
1774
 
1775
               --  We have copied the existing items up to the end of the
1776
               --  array, to make room for the new items in the middle of
1777
               --  the array.  Now we actually allocate the new items.
1778
 
1779
               --  Note: initialize K outside loop to make it clear that
1780
               --  K always has a value if the exception handler triggers.
1781
 
1782
               K := Before;
1783
               begin
1784
                  while K < Index loop
1785
                     E (K) := new Element_Type'(New_Item);
1786
                     K := K + 1;
1787
                  end loop;
1788
 
1789
               exception
1790
                  when others =>
1791
 
1792
                     --  Values in the range [Before, K) were successfully
1793
                     --  allocated, but values in the range [K, Index) are
1794
                     --  stale (these array positions contain copies of the
1795
                     --  old items, that did not get assigned a new item,
1796
                     --  because the allocation failed). We must finish what
1797
                     --  we started by clearing out all of the stale values,
1798
                     --  leaving a "hole" in the middle of the array.
1799
 
1800
                     E (K .. Index - 1) := (others => null);
1801
                     raise;
1802
               end;
1803
            end if;
1804
         end;
1805
 
1806
         return;
1807
      end if;
1808
 
1809
      --  In this case, we're inserting elements into a vector that has already
1810
      --  allocated an internal array, but the existing array does not have
1811
      --  enough storage, so we must allocate a new, longer array. In order to
1812
      --  guarantee that the amortized insertion cost is O(1), we always
1813
      --  allocate an array whose length is some power-of-two factor of the
1814
      --  current array length. (The new array cannot have a length less than
1815
      --  the New_Length of the container, but its last index value cannot be
1816
      --  greater than Index_Type'Last.)
1817
 
1818
      New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1819
      while New_Capacity < New_Length loop
1820
         if New_Capacity > Count_Type'Last / 2 then
1821
            New_Capacity := Count_Type'Last;
1822
            exit;
1823
         end if;
1824
 
1825
         New_Capacity := 2 * New_Capacity;
1826
      end loop;
1827
 
1828
      if New_Capacity > Max_Length then
1829
 
1830
         --  We have reached the limit of capacity, so no further expansion
1831
         --  will occur. (This is not a problem, as there is never a need to
1832
         --  have more capacity than the maximum container length.)
1833
 
1834
         New_Capacity := Max_Length;
1835
      end if;
1836
 
1837
      --  We have computed the length of the new internal array (and this is
1838
      --  what "vector capacity" means), so use that to compute its last index.
1839
 
1840
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1841
         Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1842
 
1843
      else
1844
         Dst_Last :=
1845
           Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1846
      end if;
1847
 
1848
      --  Now we allocate the new, longer internal array. If the allocation
1849
      --  fails, we have not changed any container state, so no side-effect
1850
      --  will occur as a result of propagating the exception.
1851
 
1852
      Dst := new Elements_Type (Dst_Last);
1853
 
1854
      --  We have our new internal array. All that needs to be done now is to
1855
      --  copy the existing items (if any) from the old array (the "source"
1856
      --  array) to the new array (the "destination" array), and then
1857
      --  deallocate the old array.
1858
 
1859
      declare
1860
         Src : Elements_Access := Container.Elements;
1861
 
1862
      begin
1863
         Dst.EA (Index_Type'First .. Before - 1) :=
1864
           Src.EA (Index_Type'First .. Before - 1);
1865
 
1866
         if Before > Container.Last then
1867
 
1868
            --  The new items are being appended to the vector, so no
1869
            --  sliding of existing elements is required.
1870
 
1871
            --  We have copied the elements from to the old, source array to
1872
            --  the new, destination array, so we can now deallocate the old
1873
            --  array.
1874
 
1875
            Container.Elements := Dst;
1876
            Free (Src);
1877
 
1878
            --  Now we append the new items.
1879
 
1880
            for Idx in Before .. New_Last loop
1881
 
1882
               --  In order to preserve container invariants, we always
1883
               --  attempt the element allocation first, before setting the
1884
               --  Last index value, in case the allocation fails (either
1885
               --  because there is no storage available, or because element
1886
               --  initialization fails).
1887
 
1888
               Dst.EA (Idx) := new Element_Type'(New_Item);
1889
 
1890
               --  The allocation of the element succeeded, so it is now safe
1891
               --  to update the Last index, restoring container invariants.
1892
 
1893
               Container.Last := Idx;
1894
            end loop;
1895
 
1896
         else
1897
            --  The new items are being inserted before some existing elements,
1898
            --  so we must slide the existing elements up to their new home.
1899
 
1900
            if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1901
               Index := Before + Index_Type'Base (Count);
1902
 
1903
            else
1904
               Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1905
            end if;
1906
 
1907
            Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1908
 
1909
            --  We have copied the elements from to the old, source array to
1910
            --  the new, destination array, so we can now deallocate the old
1911
            --  array.
1912
 
1913
            Container.Elements := Dst;
1914
            Container.Last := New_Last;
1915
            Free (Src);
1916
 
1917
            --  The new array has a range in the middle containing null access
1918
            --  values. We now fill in that partition of the array with the new
1919
            --  items.
1920
 
1921
            for Idx in Before .. Index - 1 loop
1922
 
1923
               --  Note that container invariants have already been satisfied
1924
               --  (in particular, the Last index value of the vector has
1925
               --  already been updated), so if this allocation fails we simply
1926
               --  let it propagate.
1927
 
1928
               Dst.EA (Idx) := new Element_Type'(New_Item);
1929
            end loop;
1930
         end if;
1931
      end;
1932
   end Insert;
1933
 
1934
   procedure Insert
1935
     (Container : in out Vector;
1936
      Before    : Extended_Index;
1937
      New_Item  : Vector)
1938
   is
1939
      N : constant Count_Type := Length (New_Item);
1940
      J : Index_Type'Base;
1941
 
1942
   begin
1943
      --  Use Insert_Space to create the "hole" (the destination slice) into
1944
      --  which we copy the source items.
1945
 
1946
      Insert_Space (Container, Before, Count => N);
1947
 
1948
      if N = 0 then
1949
 
1950
         --  There's nothing else to do here (vetting of parameters was
1951
         --  performed already in Insert_Space), so we simply return.
1952
 
1953
         return;
1954
      end if;
1955
 
1956
      if Container'Address /= New_Item'Address then
1957
 
1958
         --  This is the simple case.  New_Item denotes an object different
1959
         --  from Container, so there's nothing special we need to do to copy
1960
         --  the source items to their destination, because all of the source
1961
         --  items are contiguous.
1962
 
1963
         declare
1964
            subtype Src_Index_Subtype is Index_Type'Base range
1965
              Index_Type'First .. New_Item.Last;
1966
 
1967
            Src : Elements_Array renames
1968
                    New_Item.Elements.EA (Src_Index_Subtype);
1969
 
1970
            Dst : Elements_Array renames Container.Elements.EA;
1971
 
1972
            Dst_Index : Index_Type'Base;
1973
 
1974
         begin
1975
            Dst_Index := Before - 1;
1976
            for Src_Index in Src'Range loop
1977
               Dst_Index := Dst_Index + 1;
1978
 
1979
               if Src (Src_Index) /= null then
1980
                  Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1981
               end if;
1982
            end loop;
1983
         end;
1984
 
1985
         return;
1986
      end if;
1987
 
1988
      --  New_Item denotes the same object as Container, so an insertion has
1989
      --  potentially split the source items.  The first source slice is
1990
      --  [Index_Type'First, Before), and the second source slice is
1991
      --  [J, Container.Last], where index value J is the first index of the
1992
      --  second slice. (J gets computed below, but only after we have
1993
      --  determined that the second source slice is non-empty.) The
1994
      --  destination slice is always the range [Before, J). We perform the
1995
      --  copy in two steps, using each of the two slices of the source items.
1996
 
1997
      declare
1998
         L : constant Index_Type'Base := Before - 1;
1999
 
2000
         subtype Src_Index_Subtype is Index_Type'Base range
2001
           Index_Type'First .. L;
2002
 
2003
         Src : Elements_Array renames
2004
                 Container.Elements.EA (Src_Index_Subtype);
2005
 
2006
         Dst : Elements_Array renames Container.Elements.EA;
2007
 
2008
         Dst_Index : Index_Type'Base;
2009
 
2010
      begin
2011
         --  We first copy the source items that precede the space we
2012
         --  inserted. (If Before equals Index_Type'First, then this first
2013
         --  source slice will be empty, which is harmless.)
2014
 
2015
         Dst_Index := Before - 1;
2016
         for Src_Index in Src'Range loop
2017
            Dst_Index := Dst_Index + 1;
2018
 
2019
            if Src (Src_Index) /= null then
2020
               Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
2021
            end if;
2022
         end loop;
2023
 
2024
         if Src'Length = N then
2025
 
2026
            --  The new items were effectively appended to the container, so we
2027
            --  have already copied all of the items that need to be copied.
2028
            --  We return early here, even though the source slice below is
2029
            --  empty (so the assignment would be harmless), because we want to
2030
            --  avoid computing J, which will overflow if J is greater than
2031
            --  Index_Type'Base'Last.
2032
 
2033
            return;
2034
         end if;
2035
      end;
2036
 
2037
      --  Index value J is the first index of the second source slice. (It is
2038
      --  also 1 greater than the last index of the destination slice.) Note:
2039
      --  avoid computing J if J is greater than Index_Type'Base'Last, in order
2040
      --  to avoid overflow. Prevent that by returning early above, immediately
2041
      --  after copying the first slice of the source, and determining that
2042
      --  this second slice of the source is empty.
2043
 
2044
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2045
         J := Before + Index_Type'Base (N);
2046
 
2047
      else
2048
         J := Index_Type'Base (Count_Type'Base (Before) + N);
2049
      end if;
2050
 
2051
      declare
2052
         subtype Src_Index_Subtype is Index_Type'Base range
2053
           J .. Container.Last;
2054
 
2055
         Src : Elements_Array renames
2056
                 Container.Elements.EA (Src_Index_Subtype);
2057
 
2058
         Dst : Elements_Array renames Container.Elements.EA;
2059
 
2060
         Dst_Index : Index_Type'Base;
2061
 
2062
      begin
2063
         --  We next copy the source items that follow the space we inserted.
2064
         --  Index value Dst_Index is the first index of that portion of the
2065
         --  destination that receives this slice of the source. (For the
2066
         --  reasons given above, this slice is guaranteed to be non-empty.)
2067
 
2068
         if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2069
            Dst_Index := J - Index_Type'Base (Src'Length);
2070
 
2071
         else
2072
            Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length);
2073
         end if;
2074
 
2075
         for Src_Index in Src'Range loop
2076
            if Src (Src_Index) /= null then
2077
               Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
2078
            end if;
2079
 
2080
            Dst_Index := Dst_Index + 1;
2081
         end loop;
2082
      end;
2083
   end Insert;
2084
 
2085
   procedure Insert
2086
     (Container : in out Vector;
2087
      Before    : Cursor;
2088
      New_Item  : Vector)
2089
   is
2090
      Index : Index_Type'Base;
2091
 
2092
   begin
2093
      if Before.Container /= null
2094
        and then Before.Container /= Container'Unrestricted_Access
2095
      then
2096
         raise Program_Error with "Before cursor denotes wrong container";
2097
      end if;
2098
 
2099
      if Is_Empty (New_Item) then
2100
         return;
2101
      end if;
2102
 
2103
      if Before.Container = null
2104
        or else Before.Index > Container.Last
2105
      then
2106
         if Container.Last = Index_Type'Last then
2107
            raise Constraint_Error with
2108
              "vector is already at its maximum length";
2109
         end if;
2110
 
2111
         Index := Container.Last + 1;
2112
 
2113
      else
2114
         Index := Before.Index;
2115
      end if;
2116
 
2117
      Insert (Container, Index, New_Item);
2118
   end Insert;
2119
 
2120
   procedure Insert
2121
     (Container : in out Vector;
2122
      Before    : Cursor;
2123
      New_Item  : Vector;
2124
      Position  : out Cursor)
2125
   is
2126
      Index : Index_Type'Base;
2127
 
2128
   begin
2129
      if Before.Container /= null
2130
        and then Before.Container /=
2131
                   Vector_Access'(Container'Unrestricted_Access)
2132
      then
2133
         raise Program_Error with "Before cursor denotes wrong container";
2134
      end if;
2135
 
2136
      if Is_Empty (New_Item) then
2137
         if Before.Container = null
2138
           or else Before.Index > Container.Last
2139
         then
2140
            Position := No_Element;
2141
         else
2142
            Position := (Container'Unrestricted_Access, Before.Index);
2143
         end if;
2144
 
2145
         return;
2146
      end if;
2147
 
2148
      if Before.Container = null
2149
        or else Before.Index > Container.Last
2150
      then
2151
         if Container.Last = Index_Type'Last then
2152
            raise Constraint_Error with
2153
              "vector is already at its maximum length";
2154
         end if;
2155
 
2156
         Index := Container.Last + 1;
2157
 
2158
      else
2159
         Index := Before.Index;
2160
      end if;
2161
 
2162
      Insert (Container, Index, New_Item);
2163
 
2164
      Position := Cursor'(Container'Unrestricted_Access, Index);
2165
   end Insert;
2166
 
2167
   procedure Insert
2168
     (Container : in out Vector;
2169
      Before    : Cursor;
2170
      New_Item  : Element_Type;
2171
      Count     : Count_Type := 1)
2172
   is
2173
      Index : Index_Type'Base;
2174
 
2175
   begin
2176
      if Before.Container /= null
2177
        and then Before.Container /= Container'Unrestricted_Access
2178
      then
2179
         raise Program_Error with "Before cursor denotes wrong container";
2180
      end if;
2181
 
2182
      if Count = 0 then
2183
         return;
2184
      end if;
2185
 
2186
      if Before.Container = null
2187
        or else Before.Index > Container.Last
2188
      then
2189
         if Container.Last = Index_Type'Last then
2190
            raise Constraint_Error with
2191
              "vector is already at its maximum length";
2192
         end if;
2193
 
2194
         Index := Container.Last + 1;
2195
 
2196
      else
2197
         Index := Before.Index;
2198
      end if;
2199
 
2200
      Insert (Container, Index, New_Item, Count);
2201
   end Insert;
2202
 
2203
   procedure Insert
2204
     (Container : in out Vector;
2205
      Before    : Cursor;
2206
      New_Item  : Element_Type;
2207
      Position  : out Cursor;
2208
      Count     : Count_Type := 1)
2209
   is
2210
      Index : Index_Type'Base;
2211
 
2212
   begin
2213
      if Before.Container /= null
2214
        and then Before.Container /= Container'Unrestricted_Access
2215
      then
2216
         raise Program_Error with "Before cursor denotes wrong container";
2217
      end if;
2218
 
2219
      if Count = 0 then
2220
         if Before.Container = null
2221
           or else Before.Index > Container.Last
2222
         then
2223
            Position := No_Element;
2224
         else
2225
            Position := (Container'Unrestricted_Access, Before.Index);
2226
         end if;
2227
 
2228
         return;
2229
      end if;
2230
 
2231
      if Before.Container = null
2232
        or else Before.Index > Container.Last
2233
      then
2234
         if Container.Last = Index_Type'Last then
2235
            raise Constraint_Error with
2236
              "vector is already at its maximum length";
2237
         end if;
2238
 
2239
         Index := Container.Last + 1;
2240
 
2241
      else
2242
         Index := Before.Index;
2243
      end if;
2244
 
2245
      Insert (Container, Index, New_Item, Count);
2246
 
2247
      Position := (Container'Unrestricted_Access, Index);
2248
   end Insert;
2249
 
2250
   ------------------
2251
   -- Insert_Space --
2252
   ------------------
2253
 
2254
   procedure Insert_Space
2255
     (Container : in out Vector;
2256
      Before    : Extended_Index;
2257
      Count     : Count_Type := 1)
2258
   is
2259
      Old_Length : constant Count_Type := Container.Length;
2260
 
2261
      Max_Length : Count_Type'Base;  -- determined from range of Index_Type
2262
      New_Length : Count_Type'Base;  -- sum of current length and Count
2263
      New_Last   : Index_Type'Base;  -- last index of vector after insertion
2264
 
2265
      Index : Index_Type'Base;  -- scratch for intermediate values
2266
      J     : Count_Type'Base;  -- scratch
2267
 
2268
      New_Capacity : Count_Type'Base;  -- length of new, expanded array
2269
      Dst_Last     : Index_Type'Base;  -- last index of new, expanded array
2270
      Dst          : Elements_Access;  -- new, expanded internal array
2271
 
2272
   begin
2273
      --  As a precondition on the generic actual Index_Type, the base type
2274
      --  must include Index_Type'Pred (Index_Type'First); this is the value
2275
      --  that Container.Last assumes when the vector is empty. However, we do
2276
      --  not allow that as the value for Index when specifying where the new
2277
      --  items should be inserted, so we must manually check. (That the user
2278
      --  is allowed to specify the value at all here is a consequence of the
2279
      --  declaration of the Extended_Index subtype, which includes the values
2280
      --  in the base range that immediately precede and immediately follow the
2281
      --  values in the Index_Type.)
2282
 
2283
      if Before < Index_Type'First then
2284
         raise Constraint_Error with
2285
           "Before index is out of range (too small)";
2286
      end if;
2287
 
2288
      --  We do allow a value greater than Container.Last to be specified as
2289
      --  the Index, but only if it's immediately greater. This allows for the
2290
      --  case of appending items to the back end of the vector. (It is assumed
2291
      --  that specifying an index value greater than Last + 1 indicates some
2292
      --  deeper flaw in the caller's algorithm, so that case is treated as a
2293
      --  proper error.)
2294
 
2295
      if Before > Container.Last
2296
        and then Before > Container.Last + 1
2297
      then
2298
         raise Constraint_Error with
2299
           "Before index is out of range (too large)";
2300
      end if;
2301
 
2302
      --  We treat inserting 0 items into the container as a no-op, even when
2303
      --  the container is busy, so we simply return.
2304
 
2305
      if Count = 0 then
2306
         return;
2307
      end if;
2308
 
2309
      --  There are two constraints we need to satisfy. The first constraint is
2310
      --  that a container cannot have more than Count_Type'Last elements, so
2311
      --  we must check the sum of the current length and the insertion
2312
      --  count. Note that we cannot simply add these values, because of the
2313
      --  possibility of overflow.
2314
 
2315
      if Old_Length > Count_Type'Last - Count then
2316
         raise Constraint_Error with "Count is out of range";
2317
      end if;
2318
 
2319
      --  It is now safe compute the length of the new vector, without fear of
2320
      --  overflow.
2321
 
2322
      New_Length := Old_Length + Count;
2323
 
2324
      --  The second constraint is that the new Last index value cannot exceed
2325
      --  Index_Type'Last. In each branch below, we calculate the maximum
2326
      --  length (computed from the range of values in Index_Type), and then
2327
      --  compare the new length to the maximum length. If the new length is
2328
      --  acceptable, then we compute the new last index from that.
2329
 
2330
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2331
         --  We have to handle the case when there might be more values in the
2332
         --  range of Index_Type than in the range of Count_Type.
2333
 
2334
         if Index_Type'First <= 0 then
2335
 
2336
            --  We know that No_Index (the same as Index_Type'First - 1) is
2337
            --  less than 0, so it is safe to compute the following sum without
2338
            --  fear of overflow.
2339
 
2340
            Index := No_Index + Index_Type'Base (Count_Type'Last);
2341
 
2342
            if Index <= Index_Type'Last then
2343
 
2344
               --  We have determined that range of Index_Type has at least as
2345
               --  many values as in Count_Type, so Count_Type'Last is the
2346
               --  maximum number of items that are allowed.
2347
 
2348
               Max_Length := Count_Type'Last;
2349
 
2350
            else
2351
               --  The range of Index_Type has fewer values than in Count_Type,
2352
               --  so the maximum number of items is computed from the range of
2353
               --  the Index_Type.
2354
 
2355
               Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
2356
            end if;
2357
 
2358
         else
2359
            --  No_Index is equal or greater than 0, so we can safely compute
2360
            --  the difference without fear of overflow (which we would have to
2361
            --  worry about if No_Index were less than 0, but that case is
2362
            --  handled above).
2363
 
2364
            Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
2365
         end if;
2366
 
2367
      elsif Index_Type'First <= 0 then
2368
 
2369
         --  We know that No_Index (the same as Index_Type'First - 1) is less
2370
         --  than 0, so it is safe to compute the following sum without fear of
2371
         --  overflow.
2372
 
2373
         J := Count_Type'Base (No_Index) + Count_Type'Last;
2374
 
2375
         if J <= Count_Type'Base (Index_Type'Last) then
2376
 
2377
            --  We have determined that range of Index_Type has at least as
2378
            --  many values as in Count_Type, so Count_Type'Last is the maximum
2379
            --  number of items that are allowed.
2380
 
2381
            Max_Length := Count_Type'Last;
2382
 
2383
         else
2384
            --  The range of Index_Type has fewer values than Count_Type does,
2385
            --  so the maximum number of items is computed from the range of
2386
            --  the Index_Type.
2387
 
2388
            Max_Length :=
2389
              Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
2390
         end if;
2391
 
2392
      else
2393
         --  No_Index is equal or greater than 0, so we can safely compute the
2394
         --  difference without fear of overflow (which we would have to worry
2395
         --  about if No_Index were less than 0, but that case is handled
2396
         --  above).
2397
 
2398
         Max_Length :=
2399
           Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
2400
      end if;
2401
 
2402
      --  We have just computed the maximum length (number of items). We must
2403
      --  now compare the requested length to the maximum length, as we do not
2404
      --  allow a vector expand beyond the maximum (because that would create
2405
      --  an internal array with a last index value greater than
2406
      --  Index_Type'Last, with no way to index those elements).
2407
 
2408
      if New_Length > Max_Length then
2409
         raise Constraint_Error with "Count is out of range";
2410
      end if;
2411
 
2412
      --  New_Last is the last index value of the items in the container after
2413
      --  insertion.  Use the wider of Index_Type'Base and Count_Type'Base to
2414
      --  compute its value from the New_Length.
2415
 
2416
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2417
         New_Last := No_Index + Index_Type'Base (New_Length);
2418
 
2419
      else
2420
         New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
2421
      end if;
2422
 
2423
      if Container.Elements = null then
2424
         pragma Assert (Container.Last = No_Index);
2425
 
2426
         --  This is the simplest case, with which we must always begin: we're
2427
         --  inserting items into an empty vector that hasn't allocated an
2428
         --  internal array yet. Note that we don't need to check the busy bit
2429
         --  here, because an empty container cannot be busy.
2430
 
2431
         --  In an indefinite vector, elements are allocated individually, and
2432
         --  stored as access values on the internal array (the length of which
2433
         --  represents the vector "capacity"), which is separately allocated.
2434
         --  We have no elements here (because we're inserting "space"), so all
2435
         --  we need to do is allocate the backbone.
2436
 
2437
         Container.Elements := new Elements_Type (New_Last);
2438
         Container.Last := New_Last;
2439
 
2440
         return;
2441
      end if;
2442
 
2443
      --  The tampering bits exist to prevent an item from being harmfully
2444
      --  manipulated while it is being visited. Query, Update, and Iterate
2445
      --  increment the busy count on entry, and decrement the count on exit.
2446
      --  Insert checks the count to determine whether it is being called while
2447
      --  the associated callback procedure is executing.
2448
 
2449
      if Container.Busy > 0 then
2450
         raise Program_Error with
2451
           "attempt to tamper with cursors (vector is busy)";
2452
      end if;
2453
 
2454
      if New_Length <= Container.Elements.EA'Length then
2455
         --  In this case, we're inserting elements into a vector that has
2456
         --  already allocated an internal array, and the existing array has
2457
         --  enough unused storage for the new items.
2458
 
2459
         declare
2460
            E : Elements_Array renames Container.Elements.EA;
2461
 
2462
         begin
2463
            if Before <= Container.Last then
2464
 
2465
               --  The new space is being inserted before some existing
2466
               --  elements, so we must slide the existing elements up to their
2467
               --  new home. We use the wider of Index_Type'Base and
2468
               --  Count_Type'Base as the type for intermediate index values.
2469
 
2470
               if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2471
                  Index := Before + Index_Type'Base (Count);
2472
 
2473
               else
2474
                  Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2475
               end if;
2476
 
2477
               E (Index .. New_Last) := E (Before .. Container.Last);
2478
               E (Before .. Index - 1) := (others => null);
2479
            end if;
2480
         end;
2481
 
2482
         Container.Last := New_Last;
2483
         return;
2484
      end if;
2485
 
2486
      --  In this case, we're inserting elements into a vector that has already
2487
      --  allocated an internal array, but the existing array does not have
2488
      --  enough storage, so we must allocate a new, longer array. In order to
2489
      --  guarantee that the amortized insertion cost is O(1), we always
2490
      --  allocate an array whose length is some power-of-two factor of the
2491
      --  current array length. (The new array cannot have a length less than
2492
      --  the New_Length of the container, but its last index value cannot be
2493
      --  greater than Index_Type'Last.)
2494
 
2495
      New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
2496
      while New_Capacity < New_Length loop
2497
         if New_Capacity > Count_Type'Last / 2 then
2498
            New_Capacity := Count_Type'Last;
2499
            exit;
2500
         end if;
2501
 
2502
         New_Capacity := 2 * New_Capacity;
2503
      end loop;
2504
 
2505
      if New_Capacity > Max_Length then
2506
 
2507
         --  We have reached the limit of capacity, so no further expansion
2508
         --  will occur. (This is not a problem, as there is never a need to
2509
         --  have more capacity than the maximum container length.)
2510
 
2511
         New_Capacity := Max_Length;
2512
      end if;
2513
 
2514
      --  We have computed the length of the new internal array (and this is
2515
      --  what "vector capacity" means), so use that to compute its last index.
2516
 
2517
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2518
         Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2519
 
2520
      else
2521
         Dst_Last :=
2522
           Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2523
      end if;
2524
 
2525
      --  Now we allocate the new, longer internal array. If the allocation
2526
      --  fails, we have not changed any container state, so no side-effect
2527
      --  will occur as a result of propagating the exception.
2528
 
2529
      Dst := new Elements_Type (Dst_Last);
2530
 
2531
      --  We have our new internal array. All that needs to be done now is to
2532
      --  copy the existing items (if any) from the old array (the "source"
2533
      --  array) to the new array (the "destination" array), and then
2534
      --  deallocate the old array.
2535
 
2536
      declare
2537
         Src : Elements_Access := Container.Elements;
2538
 
2539
      begin
2540
         Dst.EA (Index_Type'First .. Before - 1) :=
2541
           Src.EA (Index_Type'First .. Before - 1);
2542
 
2543
         if Before <= Container.Last then
2544
 
2545
            --  The new items are being inserted before some existing elements,
2546
            --  so we must slide the existing elements up to their new home.
2547
 
2548
            if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2549
               Index := Before + Index_Type'Base (Count);
2550
 
2551
            else
2552
               Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2553
            end if;
2554
 
2555
            Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
2556
         end if;
2557
 
2558
         --  We have copied the elements from to the old, source array to the
2559
         --  new, destination array, so we can now restore invariants, and
2560
         --  deallocate the old array.
2561
 
2562
         Container.Elements := Dst;
2563
         Container.Last := New_Last;
2564
         Free (Src);
2565
      end;
2566
   end Insert_Space;
2567
 
2568
   procedure Insert_Space
2569
     (Container : in out Vector;
2570
      Before    : Cursor;
2571
      Position  : out Cursor;
2572
      Count     : Count_Type := 1)
2573
   is
2574
      Index : Index_Type'Base;
2575
 
2576
   begin
2577
      if Before.Container /= null
2578
        and then Before.Container /= Container'Unrestricted_Access
2579
      then
2580
         raise Program_Error with "Before cursor denotes wrong container";
2581
      end if;
2582
 
2583
      if Count = 0 then
2584
         if Before.Container = null
2585
           or else Before.Index > Container.Last
2586
         then
2587
            Position := No_Element;
2588
         else
2589
            Position := (Container'Unrestricted_Access, Before.Index);
2590
         end if;
2591
 
2592
         return;
2593
      end if;
2594
 
2595
      if Before.Container = null
2596
        or else Before.Index > Container.Last
2597
      then
2598
         if Container.Last = Index_Type'Last then
2599
            raise Constraint_Error with
2600
              "vector is already at its maximum length";
2601
         end if;
2602
 
2603
         Index := Container.Last + 1;
2604
 
2605
      else
2606
         Index := Before.Index;
2607
      end if;
2608
 
2609
      Insert_Space (Container, Index, Count);
2610
 
2611
      Position := Cursor'(Container'Unrestricted_Access, Index);
2612
   end Insert_Space;
2613
 
2614
   --------------
2615
   -- Is_Empty --
2616
   --------------
2617
 
2618
   function Is_Empty (Container : Vector) return Boolean is
2619
   begin
2620
      return Container.Last < Index_Type'First;
2621
   end Is_Empty;
2622
 
2623
   -------------
2624
   -- Iterate --
2625
   -------------
2626
 
2627
   procedure Iterate
2628
     (Container : Vector;
2629
      Process   : not null access procedure (Position : Cursor))
2630
   is
2631
      B : Natural renames Container'Unrestricted_Access.all.Busy;
2632
 
2633
   begin
2634
      B := B + 1;
2635
 
2636
      begin
2637
         for Indx in Index_Type'First .. Container.Last loop
2638
            Process (Cursor'(Container'Unrestricted_Access, Indx));
2639
         end loop;
2640
      exception
2641
         when others =>
2642
            B := B - 1;
2643
            raise;
2644
      end;
2645
 
2646
      B := B - 1;
2647
   end Iterate;
2648
 
2649
   function Iterate (Container : Vector)
2650
      return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2651
   is
2652
      V : constant Vector_Access := Container'Unrestricted_Access;
2653
      B : Natural renames V.Busy;
2654
 
2655
   begin
2656
      --  The value of its Index component influences the behavior of the First
2657
      --  and Last selector functions of the iterator object. When the Index
2658
      --  component is No_Index (as is the case here), this means the iterator
2659
      --  object was constructed without a start expression. This is a complete
2660
      --  iterator, meaning that the iteration starts from the (logical)
2661
      --  beginning of the sequence of items.
2662
 
2663
      --  Note: For a forward iterator, Container.First is the beginning, and
2664
      --  for a reverse iterator, Container.Last is the beginning.
2665
 
2666
      return It : constant Iterator :=
2667
                    (Limited_Controlled with
2668
                       Container => V,
2669
                       Index     => No_Index)
2670
      do
2671
         B := B + 1;
2672
      end return;
2673
   end Iterate;
2674
 
2675
   function Iterate
2676
     (Container : Vector;
2677
      Start     : Cursor)
2678
      return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2679
   is
2680
      V : constant Vector_Access := Container'Unrestricted_Access;
2681
      B : Natural renames V.Busy;
2682
 
2683
   begin
2684
      --  It was formerly the case that when Start = No_Element, the partial
2685
      --  iterator was defined to behave the same as for a complete iterator,
2686
      --  and iterate over the entire sequence of items. However, those
2687
      --  semantics were unintuitive and arguably error-prone (it is too easy
2688
      --  to accidentally create an endless loop), and so they were changed,
2689
      --  per the ARG meeting in Denver on 2011/11. However, there was no
2690
      --  consensus about what positive meaning this corner case should have,
2691
      --  and so it was decided to simply raise an exception. This does imply,
2692
      --  however, that it is not possible to use a partial iterator to specify
2693
      --  an empty sequence of items.
2694
 
2695
      if Start.Container = null then
2696
         raise Constraint_Error with
2697
           "Start position for iterator equals No_Element";
2698
      end if;
2699
 
2700
      if Start.Container /= V then
2701
         raise Program_Error with
2702
           "Start cursor of Iterate designates wrong vector";
2703
      end if;
2704
 
2705
      if Start.Index > V.Last then
2706
         raise Constraint_Error with
2707
           "Start position for iterator equals No_Element";
2708
      end if;
2709
 
2710
      --  The value of its Index component influences the behavior of the First
2711
      --  and Last selector functions of the iterator object. When the Index
2712
      --  component is not No_Index (as is the case here), it means that this
2713
      --  is a partial iteration, over a subset of the complete sequence of
2714
      --  items. The iterator object was constructed with a start expression,
2715
      --  indicating the position from which the iteration begins. Note that
2716
      --  the start position has the same value irrespective of whether this
2717
      --  is a forward or reverse iteration.
2718
 
2719
      return It : constant Iterator :=
2720
                    (Limited_Controlled with
2721
                       Container => V,
2722
                       Index     => Start.Index)
2723
      do
2724
         B := B + 1;
2725
      end return;
2726
   end Iterate;
2727
 
2728
   ----------
2729
   -- Last --
2730
   ----------
2731
 
2732
   function Last (Container : Vector) return Cursor is
2733
   begin
2734
      if Is_Empty (Container) then
2735
         return No_Element;
2736
      end if;
2737
 
2738
      return (Container'Unrestricted_Access, Container.Last);
2739
   end Last;
2740
 
2741
   function Last (Object : Iterator) return Cursor is
2742
   begin
2743
      --  The value of the iterator object's Index component influences the
2744
      --  behavior of the Last (and First) selector function.
2745
 
2746
      --  When the Index component is No_Index, this means the iterator
2747
      --  object was constructed without a start expression, in which case the
2748
      --  (reverse) iteration starts from the (logical) beginning of the entire
2749
      --  sequence (corresponding to Container.Last, for a reverse iterator).
2750
 
2751
      --  Otherwise, this is iteration over a partial sequence of items.
2752
      --  When the Index component is not No_Index, the iterator object was
2753
      --  constructed with a start expression, that specifies the position
2754
      --  from which the (reverse) partial iteration begins.
2755
 
2756
      if Object.Index = No_Index then
2757
         return Last (Object.Container.all);
2758
      else
2759
         return Cursor'(Object.Container, Object.Index);
2760
      end if;
2761
   end Last;
2762
 
2763
   -----------------
2764
   -- Last_Element --
2765
   ------------------
2766
 
2767
   function Last_Element (Container : Vector) return Element_Type is
2768
   begin
2769
      if Container.Last = No_Index then
2770
         raise Constraint_Error with "Container is empty";
2771
      end if;
2772
 
2773
      declare
2774
         EA : constant Element_Access :=
2775
                Container.Elements.EA (Container.Last);
2776
 
2777
      begin
2778
         if EA = null then
2779
            raise Constraint_Error with "last element is empty";
2780
         end if;
2781
 
2782
         return EA.all;
2783
      end;
2784
   end Last_Element;
2785
 
2786
   ----------------
2787
   -- Last_Index --
2788
   ----------------
2789
 
2790
   function Last_Index (Container : Vector) return Extended_Index is
2791
   begin
2792
      return Container.Last;
2793
   end Last_Index;
2794
 
2795
   ------------
2796
   -- Length --
2797
   ------------
2798
 
2799
   function Length (Container : Vector) return Count_Type is
2800
      L : constant Index_Type'Base := Container.Last;
2801
      F : constant Index_Type := Index_Type'First;
2802
 
2803
   begin
2804
      --  The base range of the index type (Index_Type'Base) might not include
2805
      --  all values for length (Count_Type). Contrariwise, the index type
2806
      --  might include values outside the range of length.  Hence we use
2807
      --  whatever type is wider for intermediate values when calculating
2808
      --  length. Note that no matter what the index type is, the maximum
2809
      --  length to which a vector is allowed to grow is always the minimum
2810
      --  of Count_Type'Last and (IT'Last - IT'First + 1).
2811
 
2812
      --  For example, an Index_Type with range -127 .. 127 is only guaranteed
2813
      --  to have a base range of -128 .. 127, but the corresponding vector
2814
      --  would have lengths in the range 0 .. 255. In this case we would need
2815
      --  to use Count_Type'Base for intermediate values.
2816
 
2817
      --  Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2818
      --  vector would have a maximum length of 10, but the index values lie
2819
      --  outside the range of Count_Type (which is only 32 bits). In this
2820
      --  case we would need to use Index_Type'Base for intermediate values.
2821
 
2822
      if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
2823
         return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2824
      else
2825
         return Count_Type (L - F + 1);
2826
      end if;
2827
   end Length;
2828
 
2829
   ----------
2830
   -- Move --
2831
   ----------
2832
 
2833
   procedure Move
2834
     (Target : in out Vector;
2835
      Source : in out Vector)
2836
   is
2837
   begin
2838
      if Target'Address = Source'Address then
2839
         return;
2840
      end if;
2841
 
2842
      if Source.Busy > 0 then
2843
         raise Program_Error with
2844
           "attempt to tamper with cursors (Source is busy)";
2845
      end if;
2846
 
2847
      Clear (Target);  --  Checks busy-bit
2848
 
2849
      declare
2850
         Target_Elements : constant Elements_Access := Target.Elements;
2851
      begin
2852
         Target.Elements := Source.Elements;
2853
         Source.Elements := Target_Elements;
2854
      end;
2855
 
2856
      Target.Last := Source.Last;
2857
      Source.Last := No_Index;
2858
   end Move;
2859
 
2860
   ----------
2861
   -- Next --
2862
   ----------
2863
 
2864
   function Next (Position : Cursor) return Cursor is
2865
   begin
2866
      if Position.Container = null then
2867
         return No_Element;
2868
      end if;
2869
 
2870
      if Position.Index < Position.Container.Last then
2871
         return (Position.Container, Position.Index + 1);
2872
      end if;
2873
 
2874
      return No_Element;
2875
   end Next;
2876
 
2877
   function Next (Object : Iterator; Position : Cursor) return Cursor is
2878
   begin
2879
      if Position.Container = null then
2880
         return No_Element;
2881
      end if;
2882
 
2883
      if Position.Container /= Object.Container then
2884
         raise Program_Error with
2885
           "Position cursor of Next designates wrong vector";
2886
      end if;
2887
 
2888
      return Next (Position);
2889
   end Next;
2890
 
2891
   procedure Next (Position : in out Cursor) is
2892
   begin
2893
      if Position.Container = null then
2894
         return;
2895
      end if;
2896
 
2897
      if Position.Index < Position.Container.Last then
2898
         Position.Index := Position.Index + 1;
2899
      else
2900
         Position := No_Element;
2901
      end if;
2902
   end Next;
2903
 
2904
   -------------
2905
   -- Prepend --
2906
   -------------
2907
 
2908
   procedure Prepend (Container : in out Vector; New_Item : Vector) is
2909
   begin
2910
      Insert (Container, Index_Type'First, New_Item);
2911
   end Prepend;
2912
 
2913
   procedure Prepend
2914
     (Container : in out Vector;
2915
      New_Item  : Element_Type;
2916
      Count     : Count_Type := 1)
2917
   is
2918
   begin
2919
      Insert (Container,
2920
              Index_Type'First,
2921
              New_Item,
2922
              Count);
2923
   end Prepend;
2924
 
2925
   --------------
2926
   -- Previous --
2927
   --------------
2928
 
2929
   procedure Previous (Position : in out Cursor) is
2930
   begin
2931
      if Position.Container = null then
2932
         return;
2933
      end if;
2934
 
2935
      if Position.Index > Index_Type'First then
2936
         Position.Index := Position.Index - 1;
2937
      else
2938
         Position := No_Element;
2939
      end if;
2940
   end Previous;
2941
 
2942
   function Previous (Position : Cursor) return Cursor is
2943
   begin
2944
      if Position.Container = null then
2945
         return No_Element;
2946
      end if;
2947
 
2948
      if Position.Index > Index_Type'First then
2949
         return (Position.Container, Position.Index - 1);
2950
      end if;
2951
 
2952
      return No_Element;
2953
   end Previous;
2954
 
2955
   function Previous (Object : Iterator; Position : Cursor) return Cursor is
2956
   begin
2957
      if Position.Container = null then
2958
         return No_Element;
2959
      end if;
2960
 
2961
      if Position.Container /= Object.Container then
2962
         raise Program_Error with
2963
           "Position cursor of Previous designates wrong vector";
2964
      end if;
2965
 
2966
      return Previous (Position);
2967
   end Previous;
2968
 
2969
   -------------------
2970
   -- Query_Element --
2971
   -------------------
2972
 
2973
   procedure Query_Element
2974
     (Container : Vector;
2975
      Index     : Index_Type;
2976
      Process   : not null access procedure (Element : Element_Type))
2977
   is
2978
      V : Vector renames Container'Unrestricted_Access.all;
2979
      B : Natural renames V.Busy;
2980
      L : Natural renames V.Lock;
2981
 
2982
   begin
2983
      if Index > Container.Last then
2984
         raise Constraint_Error with "Index is out of range";
2985
      end if;
2986
 
2987
      if V.Elements.EA (Index) = null then
2988
         raise Constraint_Error with "element is null";
2989
      end if;
2990
 
2991
      B := B + 1;
2992
      L := L + 1;
2993
 
2994
      begin
2995
         Process (V.Elements.EA (Index).all);
2996
      exception
2997
         when others =>
2998
            L := L - 1;
2999
            B := B - 1;
3000
            raise;
3001
      end;
3002
 
3003
      L := L - 1;
3004
      B := B - 1;
3005
   end Query_Element;
3006
 
3007
   procedure Query_Element
3008
     (Position : Cursor;
3009
      Process  : not null access procedure (Element : Element_Type))
3010
   is
3011
   begin
3012
      if Position.Container = null then
3013
         raise Constraint_Error with "Position cursor has no element";
3014
      end if;
3015
 
3016
      Query_Element (Position.Container.all, Position.Index, Process);
3017
   end Query_Element;
3018
 
3019
   ----------
3020
   -- Read --
3021
   ----------
3022
 
3023
   procedure Read
3024
     (Stream    : not null access Root_Stream_Type'Class;
3025
      Container : out Vector)
3026
   is
3027
      Length : Count_Type'Base;
3028
      Last   : Index_Type'Base := Index_Type'Pred (Index_Type'First);
3029
 
3030
      B : Boolean;
3031
 
3032
   begin
3033
      Clear (Container);
3034
 
3035
      Count_Type'Base'Read (Stream, Length);
3036
 
3037
      if Length > Capacity (Container) then
3038
         Reserve_Capacity (Container, Capacity => Length);
3039
      end if;
3040
 
3041
      for J in Count_Type range 1 .. Length loop
3042
         Last := Last + 1;
3043
 
3044
         Boolean'Read (Stream, B);
3045
 
3046
         if B then
3047
            Container.Elements.EA (Last) :=
3048
              new Element_Type'(Element_Type'Input (Stream));
3049
         end if;
3050
 
3051
         Container.Last := Last;
3052
      end loop;
3053
   end Read;
3054
 
3055
   procedure Read
3056
     (Stream   : not null access Root_Stream_Type'Class;
3057
      Position : out Cursor)
3058
   is
3059
   begin
3060
      raise Program_Error with "attempt to stream vector cursor";
3061
   end Read;
3062
 
3063
   procedure Read
3064
     (Stream : not null access Root_Stream_Type'Class;
3065
      Item   : out Reference_Type)
3066
   is
3067
   begin
3068
      raise Program_Error with "attempt to stream reference";
3069
   end Read;
3070
 
3071
   procedure Read
3072
     (Stream : not null access Root_Stream_Type'Class;
3073
      Item   : out Constant_Reference_Type)
3074
   is
3075
   begin
3076
      raise Program_Error with "attempt to stream reference";
3077
   end Read;
3078
 
3079
   ---------------
3080
   -- Reference --
3081
   ---------------
3082
 
3083
   function Reference
3084
     (Container : aliased in out Vector;
3085
      Position  : Cursor) return Reference_Type
3086
   is
3087
      E : Element_Access;
3088
 
3089
   begin
3090
      if Position.Container = null then
3091
         raise Constraint_Error with "Position cursor has no element";
3092
      end if;
3093
 
3094
      if Position.Container /= Container'Unrestricted_Access then
3095
         raise Program_Error with "Position cursor denotes wrong container";
3096
      end if;
3097
 
3098
      if Position.Index > Position.Container.Last then
3099
         raise Constraint_Error with "Position cursor is out of range";
3100
      end if;
3101
 
3102
      E := Container.Elements.EA (Position.Index);
3103
 
3104
      if E = null then
3105
         raise Constraint_Error with "element at Position is empty";
3106
      end if;
3107
 
3108
      declare
3109
         C : Vector renames Container'Unrestricted_Access.all;
3110
         B : Natural renames C.Busy;
3111
         L : Natural renames C.Lock;
3112
      begin
3113
         return R : constant Reference_Type :=
3114
                      (Element => E.all'Access,
3115
                       Control => (Controlled with Position.Container))
3116
         do
3117
            B := B + 1;
3118
            L := L + 1;
3119
         end return;
3120
      end;
3121
   end Reference;
3122
 
3123
   function Reference
3124
     (Container : aliased in out Vector;
3125
      Index     : Index_Type) return Reference_Type
3126
   is
3127
      E : Element_Access;
3128
 
3129
   begin
3130
      if Index > Container.Last then
3131
         raise Constraint_Error with "Index is out of range";
3132
      end if;
3133
 
3134
      E := Container.Elements.EA (Index);
3135
 
3136
      if E = null then
3137
         raise Constraint_Error with "element at Index is empty";
3138
      end if;
3139
 
3140
      declare
3141
         C : Vector renames Container'Unrestricted_Access.all;
3142
         B : Natural renames C.Busy;
3143
         L : Natural renames C.Lock;
3144
      begin
3145
         return R : constant Reference_Type :=
3146
                      (Element => E.all'Access,
3147
                       Control =>
3148
                         (Controlled with Container'Unrestricted_Access))
3149
         do
3150
            B := B + 1;
3151
            L := L + 1;
3152
         end return;
3153
      end;
3154
   end Reference;
3155
 
3156
   ---------------------
3157
   -- Replace_Element --
3158
   ---------------------
3159
 
3160
   procedure Replace_Element
3161
     (Container : in out Vector;
3162
      Index     : Index_Type;
3163
      New_Item  : Element_Type)
3164
   is
3165
   begin
3166
      if Index > Container.Last then
3167
         raise Constraint_Error with "Index is out of range";
3168
      end if;
3169
 
3170
      if Container.Lock > 0 then
3171
         raise Program_Error with
3172
           "attempt to tamper with elements (vector is locked)";
3173
      end if;
3174
 
3175
      declare
3176
         X : Element_Access := Container.Elements.EA (Index);
3177
      begin
3178
         Container.Elements.EA (Index) := new Element_Type'(New_Item);
3179
         Free (X);
3180
      end;
3181
   end Replace_Element;
3182
 
3183
   procedure Replace_Element
3184
     (Container : in out Vector;
3185
      Position  : Cursor;
3186
      New_Item  : Element_Type)
3187
   is
3188
   begin
3189
      if Position.Container = null then
3190
         raise Constraint_Error with "Position cursor has no element";
3191
      end if;
3192
 
3193
      if Position.Container /= Container'Unrestricted_Access then
3194
         raise Program_Error with "Position cursor denotes wrong container";
3195
      end if;
3196
 
3197
      if Position.Index > Container.Last then
3198
         raise Constraint_Error with "Position cursor is out of range";
3199
      end if;
3200
 
3201
      if Container.Lock > 0 then
3202
         raise Program_Error with
3203
           "attempt to tamper with elements (vector is locked)";
3204
      end if;
3205
 
3206
      declare
3207
         X : Element_Access := Container.Elements.EA (Position.Index);
3208
      begin
3209
         Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
3210
         Free (X);
3211
      end;
3212
   end Replace_Element;
3213
 
3214
   ----------------------
3215
   -- Reserve_Capacity --
3216
   ----------------------
3217
 
3218
   procedure Reserve_Capacity
3219
     (Container : in out Vector;
3220
      Capacity  : Count_Type)
3221
   is
3222
      N : constant Count_Type := Length (Container);
3223
 
3224
      Index : Count_Type'Base;
3225
      Last  : Index_Type'Base;
3226
 
3227
   begin
3228
      --  Reserve_Capacity can be used to either expand the storage available
3229
      --  for elements (this would be its typical use, in anticipation of
3230
      --  future insertion), or to trim back storage. In the latter case,
3231
      --  storage can only be trimmed back to the limit of the container
3232
      --  length. Note that Reserve_Capacity neither deletes (active) elements
3233
      --  nor inserts elements; it only affects container capacity, never
3234
      --  container length.
3235
 
3236
      if Capacity = 0 then
3237
 
3238
         --  This is a request to trim back storage, to the minimum amount
3239
         --  possible given the current state of the container.
3240
 
3241
         if N = 0 then
3242
 
3243
            --  The container is empty, so in this unique case we can
3244
            --  deallocate the entire internal array. Note that an empty
3245
            --  container can never be busy, so there's no need to check the
3246
            --  tampering bits.
3247
 
3248
            declare
3249
               X : Elements_Access := Container.Elements;
3250
 
3251
            begin
3252
               --  First we remove the internal array from the container, to
3253
               --  handle the case when the deallocation raises an exception
3254
               --  (although that's unlikely, since this is simply an array of
3255
               --  access values, all of which are null).
3256
 
3257
               Container.Elements := null;
3258
 
3259
               --  Container invariants have been restored, so it is now safe
3260
               --  to attempt to deallocate the internal array.
3261
 
3262
               Free (X);
3263
            end;
3264
 
3265
         elsif N < Container.Elements.EA'Length then
3266
 
3267
            --  The container is not empty, and the current length is less than
3268
            --  the current capacity, so there's storage available to trim. In
3269
            --  this case, we allocate a new internal array having a length
3270
            --  that exactly matches the number of items in the
3271
            --  container. (Reserve_Capacity does not delete active elements,
3272
            --  so this is the best we can do with respect to minimizing
3273
            --  storage).
3274
 
3275
            if Container.Busy > 0 then
3276
               raise Program_Error with
3277
                 "attempt to tamper with cursors (vector is busy)";
3278
            end if;
3279
 
3280
            declare
3281
               subtype Array_Index_Subtype is Index_Type'Base range
3282
                 Index_Type'First .. Container.Last;
3283
 
3284
               Src : Elements_Array renames
3285
                       Container.Elements.EA (Array_Index_Subtype);
3286
 
3287
               X : Elements_Access := Container.Elements;
3288
 
3289
            begin
3290
               --  Although we have isolated the old internal array that we're
3291
               --  going to deallocate, we don't deallocate it until we have
3292
               --  successfully allocated a new one. If there is an exception
3293
               --  during allocation (because there is not enough storage), we
3294
               --  let it propagate without causing any side-effect.
3295
 
3296
               Container.Elements := new Elements_Type'(Container.Last, Src);
3297
 
3298
               --  We have successfully allocated a new internal array (with a
3299
               --  smaller length than the old one, and containing a copy of
3300
               --  just the active elements in the container), so we can
3301
               --  deallocate the old array.
3302
 
3303
               Free (X);
3304
            end;
3305
         end if;
3306
 
3307
         return;
3308
      end if;
3309
 
3310
      --  Reserve_Capacity can be used to expand the storage available for
3311
      --  elements, but we do not let the capacity grow beyond the number of
3312
      --  values in Index_Type'Range. (Were it otherwise, there would be no way
3313
      --  to refer to the elements with index values greater than
3314
      --  Index_Type'Last, so that storage would be wasted.) Here we compute
3315
      --  the Last index value of the new internal array, in a way that avoids
3316
      --  any possibility of overflow.
3317
 
3318
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3319
 
3320
         --  We perform a two-part test. First we determine whether the
3321
         --  computed Last value lies in the base range of the type, and then
3322
         --  determine whether it lies in the range of the index (sub)type.
3323
 
3324
         --  Last must satisfy this relation:
3325
         --    First + Length - 1 <= Last
3326
         --  We regroup terms:
3327
         --    First - 1 <= Last - Length
3328
         --  Which can rewrite as:
3329
         --    No_Index <= Last - Length
3330
 
3331
         if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then
3332
            raise Constraint_Error with "Capacity is out of range";
3333
         end if;
3334
 
3335
         --  We now know that the computed value of Last is within the base
3336
         --  range of the type, so it is safe to compute its value:
3337
 
3338
         Last := No_Index + Index_Type'Base (Capacity);
3339
 
3340
         --  Finally we test whether the value is within the range of the
3341
         --  generic actual index subtype:
3342
 
3343
         if Last > Index_Type'Last then
3344
            raise Constraint_Error with "Capacity is out of range";
3345
         end if;
3346
 
3347
      elsif Index_Type'First <= 0 then
3348
 
3349
         --  Here we can compute Last directly, in the normal way. We know that
3350
         --  No_Index is less than 0, so there is no danger of overflow when
3351
         --  adding the (positive) value of Capacity.
3352
 
3353
         Index := Count_Type'Base (No_Index) + Capacity;  -- Last
3354
 
3355
         if Index > Count_Type'Base (Index_Type'Last) then
3356
            raise Constraint_Error with "Capacity is out of range";
3357
         end if;
3358
 
3359
         --  We know that the computed value (having type Count_Type) of Last
3360
         --  is within the range of the generic actual index subtype, so it is
3361
         --  safe to convert to Index_Type:
3362
 
3363
         Last := Index_Type'Base (Index);
3364
 
3365
      else
3366
         --  Here Index_Type'First (and Index_Type'Last) is positive, so we
3367
         --  must test the length indirectly (by working backwards from the
3368
         --  largest possible value of Last), in order to prevent overflow.
3369
 
3370
         Index := Count_Type'Base (Index_Type'Last) - Capacity;  -- No_Index
3371
 
3372
         if Index < Count_Type'Base (No_Index) then
3373
            raise Constraint_Error with "Capacity is out of range";
3374
         end if;
3375
 
3376
         --  We have determined that the value of Capacity would not create a
3377
         --  Last index value outside of the range of Index_Type, so we can now
3378
         --  safely compute its value.
3379
 
3380
         Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
3381
      end if;
3382
 
3383
      --  The requested capacity is non-zero, but we don't know yet whether
3384
      --  this is a request for expansion or contraction of storage.
3385
 
3386
      if Container.Elements = null then
3387
 
3388
         --  The container is empty (it doesn't even have an internal array),
3389
         --  so this represents a request to allocate storage having the given
3390
         --  capacity.
3391
 
3392
         Container.Elements := new Elements_Type (Last);
3393
         return;
3394
      end if;
3395
 
3396
      if Capacity <= N then
3397
 
3398
         --  This is a request to trim back storage, but only to the limit of
3399
         --  what's already in the container. (Reserve_Capacity never deletes
3400
         --  active elements, it only reclaims excess storage.)
3401
 
3402
         if N < Container.Elements.EA'Length then
3403
 
3404
            --  The container is not empty (because the requested capacity is
3405
            --  positive, and less than or equal to the container length), and
3406
            --  the current length is less than the current capacity, so there
3407
            --  is storage available to trim. In this case, we allocate a new
3408
            --  internal array having a length that exactly matches the number
3409
            --  of items in the container.
3410
 
3411
            if Container.Busy > 0 then
3412
               raise Program_Error with
3413
                 "attempt to tamper with cursors (vector is busy)";
3414
            end if;
3415
 
3416
            declare
3417
               subtype Array_Index_Subtype is Index_Type'Base range
3418
                 Index_Type'First .. Container.Last;
3419
 
3420
               Src : Elements_Array renames
3421
                       Container.Elements.EA (Array_Index_Subtype);
3422
 
3423
               X : Elements_Access := Container.Elements;
3424
 
3425
            begin
3426
               --  Although we have isolated the old internal array that we're
3427
               --  going to deallocate, we don't deallocate it until we have
3428
               --  successfully allocated a new one. If there is an exception
3429
               --  during allocation (because there is not enough storage), we
3430
               --  let it propagate without causing any side-effect.
3431
 
3432
               Container.Elements := new Elements_Type'(Container.Last, Src);
3433
 
3434
               --  We have successfully allocated a new internal array (with a
3435
               --  smaller length than the old one, and containing a copy of
3436
               --  just the active elements in the container), so it is now
3437
               --  safe to deallocate the old array.
3438
 
3439
               Free (X);
3440
            end;
3441
         end if;
3442
 
3443
         return;
3444
      end if;
3445
 
3446
      --  The requested capacity is larger than the container length (the
3447
      --  number of active elements). Whether this represents a request for
3448
      --  expansion or contraction of the current capacity depends on what the
3449
      --  current capacity is.
3450
 
3451
      if Capacity = Container.Elements.EA'Length then
3452
 
3453
         --  The requested capacity matches the existing capacity, so there's
3454
         --  nothing to do here. We treat this case as a no-op, and simply
3455
         --  return without checking the busy bit.
3456
 
3457
         return;
3458
      end if;
3459
 
3460
      --  There is a change in the capacity of a non-empty container, so a new
3461
      --  internal array will be allocated. (The length of the new internal
3462
      --  array could be less or greater than the old internal array. We know
3463
      --  only that the length of the new internal array is greater than the
3464
      --  number of active elements in the container.) We must check whether
3465
      --  the container is busy before doing anything else.
3466
 
3467
      if Container.Busy > 0 then
3468
         raise Program_Error with
3469
           "attempt to tamper with cursors (vector is busy)";
3470
      end if;
3471
 
3472
      --  We now allocate a new internal array, having a length different from
3473
      --  its current value.
3474
 
3475
      declare
3476
         X : Elements_Access := Container.Elements;
3477
 
3478
         subtype Index_Subtype is Index_Type'Base range
3479
           Index_Type'First .. Container.Last;
3480
 
3481
      begin
3482
         --  We now allocate a new internal array, having a length different
3483
         --  from its current value.
3484
 
3485
         Container.Elements := new Elements_Type (Last);
3486
 
3487
         --  We have successfully allocated the new internal array, so now we
3488
         --  move the existing elements from the existing the old internal
3489
         --  array onto the new one. Note that we're just copying access
3490
         --  values, to this should not raise any exceptions.
3491
 
3492
         Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype);
3493
 
3494
         --  We have moved the elements from the old internal array, so now we
3495
         --  can deallocate it.
3496
 
3497
         Free (X);
3498
      end;
3499
   end Reserve_Capacity;
3500
 
3501
   ----------------------
3502
   -- Reverse_Elements --
3503
   ----------------------
3504
 
3505
   procedure Reverse_Elements (Container : in out Vector) is
3506
   begin
3507
      if Container.Length <= 1 then
3508
         return;
3509
      end if;
3510
 
3511
      --  The exception behavior for the vector container must match that for
3512
      --  the list container, so we check for cursor tampering here (which will
3513
      --  catch more things) instead of for element tampering (which will catch
3514
      --  fewer things). It's true that the elements of this vector container
3515
      --  could be safely moved around while (say) an iteration is taking place
3516
      --  (iteration only increments the busy counter), and so technically all
3517
      --  we would need here is a test for element tampering (indicated by the
3518
      --  lock counter), that's simply an artifact of our array-based
3519
      --  implementation. Logically Reverse_Elements requires a check for
3520
      --  cursor tampering.
3521
 
3522
      if Container.Busy > 0 then
3523
         raise Program_Error with
3524
           "attempt to tamper with cursors (vector is busy)";
3525
      end if;
3526
 
3527
      declare
3528
         I : Index_Type;
3529
         J : Index_Type;
3530
         E : Elements_Array renames Container.Elements.EA;
3531
 
3532
      begin
3533
         I := Index_Type'First;
3534
         J := Container.Last;
3535
         while I < J loop
3536
            declare
3537
               EI : constant Element_Access := E (I);
3538
 
3539
            begin
3540
               E (I) := E (J);
3541
               E (J) := EI;
3542
            end;
3543
 
3544
            I := I + 1;
3545
            J := J - 1;
3546
         end loop;
3547
      end;
3548
   end Reverse_Elements;
3549
 
3550
   ------------------
3551
   -- Reverse_Find --
3552
   ------------------
3553
 
3554
   function Reverse_Find
3555
     (Container : Vector;
3556
      Item      : Element_Type;
3557
      Position  : Cursor := No_Element) return Cursor
3558
   is
3559
      Last : Index_Type'Base;
3560
 
3561
   begin
3562
      if Position.Container /= null
3563
        and then Position.Container /= Container'Unrestricted_Access
3564
      then
3565
         raise Program_Error with "Position cursor denotes wrong container";
3566
      end if;
3567
 
3568
      if Position.Container = null
3569
        or else Position.Index > Container.Last
3570
      then
3571
         Last := Container.Last;
3572
      else
3573
         Last := Position.Index;
3574
      end if;
3575
 
3576
      for Indx in reverse Index_Type'First .. Last loop
3577
         if Container.Elements.EA (Indx) /= null
3578
           and then Container.Elements.EA (Indx).all = Item
3579
         then
3580
            return (Container'Unrestricted_Access, Indx);
3581
         end if;
3582
      end loop;
3583
 
3584
      return No_Element;
3585
   end Reverse_Find;
3586
 
3587
   ------------------------
3588
   -- Reverse_Find_Index --
3589
   ------------------------
3590
 
3591
   function Reverse_Find_Index
3592
     (Container : Vector;
3593
      Item      : Element_Type;
3594
      Index     : Index_Type := Index_Type'Last) return Extended_Index
3595
   is
3596
      Last : constant Index_Type'Base :=
3597
               (if Index > Container.Last then Container.Last else Index);
3598
   begin
3599
      for Indx in reverse Index_Type'First .. Last loop
3600
         if Container.Elements.EA (Indx) /= null
3601
           and then Container.Elements.EA (Indx).all = Item
3602
         then
3603
            return Indx;
3604
         end if;
3605
      end loop;
3606
 
3607
      return No_Index;
3608
   end Reverse_Find_Index;
3609
 
3610
   ---------------------
3611
   -- Reverse_Iterate --
3612
   ---------------------
3613
 
3614
   procedure Reverse_Iterate
3615
     (Container : Vector;
3616
      Process   : not null access procedure (Position : Cursor))
3617
   is
3618
      V : Vector renames Container'Unrestricted_Access.all;
3619
      B : Natural renames V.Busy;
3620
 
3621
   begin
3622
      B := B + 1;
3623
 
3624
      begin
3625
         for Indx in reverse Index_Type'First .. Container.Last loop
3626
            Process (Cursor'(Container'Unrestricted_Access, Indx));
3627
         end loop;
3628
      exception
3629
         when others =>
3630
            B := B - 1;
3631
            raise;
3632
      end;
3633
 
3634
      B := B - 1;
3635
   end Reverse_Iterate;
3636
 
3637
   ----------------
3638
   -- Set_Length --
3639
   ----------------
3640
 
3641
   procedure Set_Length
3642
     (Container : in out Vector;
3643
      Length    : Count_Type)
3644
   is
3645
      Count : constant Count_Type'Base := Container.Length - Length;
3646
 
3647
   begin
3648
      --  Set_Length allows the user to set the length explicitly, instead of
3649
      --  implicitly as a side-effect of deletion or insertion. If the
3650
      --  requested length is less than the current length, this is equivalent
3651
      --  to deleting items from the back end of the vector. If the requested
3652
      --  length is greater than the current length, then this is equivalent to
3653
      --  inserting "space" (nonce items) at the end.
3654
 
3655
      if Count >= 0 then
3656
         Container.Delete_Last (Count);
3657
 
3658
      elsif Container.Last >= Index_Type'Last then
3659
         raise Constraint_Error with "vector is already at its maximum length";
3660
 
3661
      else
3662
         Container.Insert_Space (Container.Last + 1, -Count);
3663
      end if;
3664
   end Set_Length;
3665
 
3666
   ----------
3667
   -- Swap --
3668
   ----------
3669
 
3670
   procedure Swap
3671
     (Container : in out Vector;
3672
      I, J      : Index_Type)
3673
   is
3674
   begin
3675
      if I > Container.Last then
3676
         raise Constraint_Error with "I index is out of range";
3677
      end if;
3678
 
3679
      if J > Container.Last then
3680
         raise Constraint_Error with "J index is out of range";
3681
      end if;
3682
 
3683
      if I = J then
3684
         return;
3685
      end if;
3686
 
3687
      if Container.Lock > 0 then
3688
         raise Program_Error with
3689
           "attempt to tamper with elements (vector is locked)";
3690
      end if;
3691
 
3692
      declare
3693
         EI : Element_Access renames Container.Elements.EA (I);
3694
         EJ : Element_Access renames Container.Elements.EA (J);
3695
 
3696
         EI_Copy : constant Element_Access := EI;
3697
 
3698
      begin
3699
         EI := EJ;
3700
         EJ := EI_Copy;
3701
      end;
3702
   end Swap;
3703
 
3704
   procedure Swap
3705
     (Container : in out Vector;
3706
      I, J      : Cursor)
3707
   is
3708
   begin
3709
      if I.Container = null then
3710
         raise Constraint_Error with "I cursor has no element";
3711
      end if;
3712
 
3713
      if J.Container = null then
3714
         raise Constraint_Error with "J cursor has no element";
3715
      end if;
3716
 
3717
      if I.Container /= Container'Unrestricted_Access then
3718
         raise Program_Error with "I cursor denotes wrong container";
3719
      end if;
3720
 
3721
      if J.Container /= Container'Unrestricted_Access then
3722
         raise Program_Error with "J cursor denotes wrong container";
3723
      end if;
3724
 
3725
      Swap (Container, I.Index, J.Index);
3726
   end Swap;
3727
 
3728
   ---------------
3729
   -- To_Cursor --
3730
   ---------------
3731
 
3732
   function To_Cursor
3733
     (Container : Vector;
3734
      Index     : Extended_Index) return Cursor
3735
   is
3736
   begin
3737
      if Index not in Index_Type'First .. Container.Last then
3738
         return No_Element;
3739
      end if;
3740
 
3741
      return Cursor'(Container'Unrestricted_Access, Index);
3742
   end To_Cursor;
3743
 
3744
   --------------
3745
   -- To_Index --
3746
   --------------
3747
 
3748
   function To_Index (Position : Cursor) return Extended_Index is
3749
   begin
3750
      if Position.Container = null then
3751
         return No_Index;
3752
      end if;
3753
 
3754
      if Position.Index <= Position.Container.Last then
3755
         return Position.Index;
3756
      end if;
3757
 
3758
      return No_Index;
3759
   end To_Index;
3760
 
3761
   ---------------
3762
   -- To_Vector --
3763
   ---------------
3764
 
3765
   function To_Vector (Length : Count_Type) return Vector is
3766
      Index    : Count_Type'Base;
3767
      Last     : Index_Type'Base;
3768
      Elements : Elements_Access;
3769
 
3770
   begin
3771
      if Length = 0 then
3772
         return Empty_Vector;
3773
      end if;
3774
 
3775
      --  We create a vector object with a capacity that matches the specified
3776
      --  Length, but we do not allow the vector capacity (the length of the
3777
      --  internal array) to exceed the number of values in Index_Type'Range
3778
      --  (otherwise, there would be no way to refer to those components via an
3779
      --  index).  We must therefore check whether the specified Length would
3780
      --  create a Last index value greater than Index_Type'Last.
3781
 
3782
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3783
 
3784
         --  We perform a two-part test. First we determine whether the
3785
         --  computed Last value lies in the base range of the type, and then
3786
         --  determine whether it lies in the range of the index (sub)type.
3787
 
3788
         --  Last must satisfy this relation:
3789
         --    First + Length - 1 <= Last
3790
         --  We regroup terms:
3791
         --    First - 1 <= Last - Length
3792
         --  Which can rewrite as:
3793
         --    No_Index <= Last - Length
3794
 
3795
         if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3796
            raise Constraint_Error with "Length is out of range";
3797
         end if;
3798
 
3799
         --  We now know that the computed value of Last is within the base
3800
         --  range of the type, so it is safe to compute its value:
3801
 
3802
         Last := No_Index + Index_Type'Base (Length);
3803
 
3804
         --  Finally we test whether the value is within the range of the
3805
         --  generic actual index subtype:
3806
 
3807
         if Last > Index_Type'Last then
3808
            raise Constraint_Error with "Length is out of range";
3809
         end if;
3810
 
3811
      elsif Index_Type'First <= 0 then
3812
 
3813
         --  Here we can compute Last directly, in the normal way. We know that
3814
         --  No_Index is less than 0, so there is no danger of overflow when
3815
         --  adding the (positive) value of Length.
3816
 
3817
         Index := Count_Type'Base (No_Index) + Length;  -- Last
3818
 
3819
         if Index > Count_Type'Base (Index_Type'Last) then
3820
            raise Constraint_Error with "Length is out of range";
3821
         end if;
3822
 
3823
         --  We know that the computed value (having type Count_Type) of Last
3824
         --  is within the range of the generic actual index subtype, so it is
3825
         --  safe to convert to Index_Type:
3826
 
3827
         Last := Index_Type'Base (Index);
3828
 
3829
      else
3830
         --  Here Index_Type'First (and Index_Type'Last) is positive, so we
3831
         --  must test the length indirectly (by working backwards from the
3832
         --  largest possible value of Last), in order to prevent overflow.
3833
 
3834
         Index := Count_Type'Base (Index_Type'Last) - Length;  -- No_Index
3835
 
3836
         if Index < Count_Type'Base (No_Index) then
3837
            raise Constraint_Error with "Length is out of range";
3838
         end if;
3839
 
3840
         --  We have determined that the value of Length would not create a
3841
         --  Last index value outside of the range of Index_Type, so we can now
3842
         --  safely compute its value.
3843
 
3844
         Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3845
      end if;
3846
 
3847
      Elements := new Elements_Type (Last);
3848
 
3849
      return Vector'(Controlled with Elements, Last, 0, 0);
3850
   end To_Vector;
3851
 
3852
   function To_Vector
3853
     (New_Item : Element_Type;
3854
      Length   : Count_Type) return Vector
3855
   is
3856
      Index    : Count_Type'Base;
3857
      Last     : Index_Type'Base;
3858
      Elements : Elements_Access;
3859
 
3860
   begin
3861
      if Length = 0 then
3862
         return Empty_Vector;
3863
      end if;
3864
 
3865
      --  We create a vector object with a capacity that matches the specified
3866
      --  Length, but we do not allow the vector capacity (the length of the
3867
      --  internal array) to exceed the number of values in Index_Type'Range
3868
      --  (otherwise, there would be no way to refer to those components via an
3869
      --  index). We must therefore check whether the specified Length would
3870
      --  create a Last index value greater than Index_Type'Last.
3871
 
3872
      if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3873
 
3874
         --  We perform a two-part test. First we determine whether the
3875
         --  computed Last value lies in the base range of the type, and then
3876
         --  determine whether it lies in the range of the index (sub)type.
3877
 
3878
         --  Last must satisfy this relation:
3879
         --    First + Length - 1 <= Last
3880
         --  We regroup terms:
3881
         --    First - 1 <= Last - Length
3882
         --  Which can rewrite as:
3883
         --    No_Index <= Last - Length
3884
 
3885
         if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3886
            raise Constraint_Error with "Length is out of range";
3887
         end if;
3888
 
3889
         --  We now know that the computed value of Last is within the base
3890
         --  range of the type, so it is safe to compute its value:
3891
 
3892
         Last := No_Index + Index_Type'Base (Length);
3893
 
3894
         --  Finally we test whether the value is within the range of the
3895
         --  generic actual index subtype:
3896
 
3897
         if Last > Index_Type'Last then
3898
            raise Constraint_Error with "Length is out of range";
3899
         end if;
3900
 
3901
      elsif Index_Type'First <= 0 then
3902
 
3903
         --  Here we can compute Last directly, in the normal way. We know that
3904
         --  No_Index is less than 0, so there is no danger of overflow when
3905
         --  adding the (positive) value of Length.
3906
 
3907
         Index := Count_Type'Base (No_Index) + Length;  -- Last
3908
 
3909
         if Index > Count_Type'Base (Index_Type'Last) then
3910
            raise Constraint_Error with "Length is out of range";
3911
         end if;
3912
 
3913
         --  We know that the computed value (having type Count_Type) of Last
3914
         --  is within the range of the generic actual index subtype, so it is
3915
         --  safe to convert to Index_Type:
3916
 
3917
         Last := Index_Type'Base (Index);
3918
 
3919
      else
3920
         --  Here Index_Type'First (and Index_Type'Last) is positive, so we
3921
         --  must test the length indirectly (by working backwards from the
3922
         --  largest possible value of Last), in order to prevent overflow.
3923
 
3924
         Index := Count_Type'Base (Index_Type'Last) - Length;  -- No_Index
3925
 
3926
         if Index < Count_Type'Base (No_Index) then
3927
            raise Constraint_Error with "Length is out of range";
3928
         end if;
3929
 
3930
         --  We have determined that the value of Length would not create a
3931
         --  Last index value outside of the range of Index_Type, so we can now
3932
         --  safely compute its value.
3933
 
3934
         Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3935
      end if;
3936
 
3937
      Elements := new Elements_Type (Last);
3938
 
3939
      --  We use Last as the index of the loop used to populate the internal
3940
      --  array with items. In general, we prefer to initialize the loop index
3941
      --  immediately prior to entering the loop. However, Last is also used in
3942
      --  the exception handler (to reclaim elements that have been allocated,
3943
      --  before propagating the exception), and the initialization of Last
3944
      --  after entering the block containing the handler confuses some static
3945
      --  analysis tools, with respect to whether Last has been properly
3946
      --  initialized when the handler executes. So here we initialize our loop
3947
      --  variable earlier than we prefer, before entering the block, so there
3948
      --  is no ambiguity.
3949
 
3950
      Last := Index_Type'First;
3951
 
3952
      begin
3953
         loop
3954
            Elements.EA (Last) := new Element_Type'(New_Item);
3955
            exit when Last = Elements.Last;
3956
            Last := Last + 1;
3957
         end loop;
3958
 
3959
      exception
3960
         when others =>
3961
            for J in Index_Type'First .. Last - 1 loop
3962
               Free (Elements.EA (J));
3963
            end loop;
3964
 
3965
            Free (Elements);
3966
            raise;
3967
      end;
3968
 
3969
      return (Controlled with Elements, Last, 0, 0);
3970
   end To_Vector;
3971
 
3972
   --------------------
3973
   -- Update_Element --
3974
   --------------------
3975
 
3976
   procedure Update_Element
3977
     (Container : in out Vector;
3978
      Index     : Index_Type;
3979
      Process   : not null access procedure (Element : in out Element_Type))
3980
   is
3981
      B : Natural renames Container.Busy;
3982
      L : Natural renames Container.Lock;
3983
 
3984
   begin
3985
      if Index > Container.Last then
3986
         raise Constraint_Error with "Index is out of range";
3987
      end if;
3988
 
3989
      if Container.Elements.EA (Index) = null then
3990
         raise Constraint_Error with "element is null";
3991
      end if;
3992
 
3993
      B := B + 1;
3994
      L := L + 1;
3995
 
3996
      begin
3997
         Process (Container.Elements.EA (Index).all);
3998
      exception
3999
         when others =>
4000
            L := L - 1;
4001
            B := B - 1;
4002
            raise;
4003
      end;
4004
 
4005
      L := L - 1;
4006
      B := B - 1;
4007
   end Update_Element;
4008
 
4009
   procedure Update_Element
4010
     (Container : in out Vector;
4011
      Position  : Cursor;
4012
      Process   : not null access procedure (Element : in out Element_Type))
4013
   is
4014
   begin
4015
      if Position.Container = null then
4016
         raise Constraint_Error with "Position cursor has no element";
4017
      end if;
4018
 
4019
      if Position.Container /= Container'Unrestricted_Access then
4020
         raise Program_Error with "Position cursor denotes wrong container";
4021
      end if;
4022
 
4023
      Update_Element (Container, Position.Index, Process);
4024
   end Update_Element;
4025
 
4026
   -----------
4027
   -- Write --
4028
   -----------
4029
 
4030
   procedure Write
4031
     (Stream    : not null access Root_Stream_Type'Class;
4032
      Container : Vector)
4033
   is
4034
      N : constant Count_Type := Length (Container);
4035
 
4036
   begin
4037
      Count_Type'Base'Write (Stream, N);
4038
 
4039
      if N = 0 then
4040
         return;
4041
      end if;
4042
 
4043
      declare
4044
         E : Elements_Array renames Container.Elements.EA;
4045
 
4046
      begin
4047
         for Indx in Index_Type'First .. Container.Last loop
4048
            if E (Indx) = null then
4049
               Boolean'Write (Stream, False);
4050
            else
4051
               Boolean'Write (Stream, True);
4052
               Element_Type'Output (Stream, E (Indx).all);
4053
            end if;
4054
         end loop;
4055
      end;
4056
   end Write;
4057
 
4058
   procedure Write
4059
     (Stream   : not null access Root_Stream_Type'Class;
4060
      Position : Cursor)
4061
   is
4062
   begin
4063
      raise Program_Error with "attempt to stream vector cursor";
4064
   end Write;
4065
 
4066
   procedure Write
4067
     (Stream : not null access Root_Stream_Type'Class;
4068
      Item   : Reference_Type)
4069
   is
4070
   begin
4071
      raise Program_Error with "attempt to stream reference";
4072
   end Write;
4073
 
4074
   procedure Write
4075
     (Stream : not null access Root_Stream_Type'Class;
4076
      Item   : Constant_Reference_Type)
4077
   is
4078
   begin
4079
      raise Program_Error with "attempt to stream reference";
4080
   end Write;
4081
 
4082
end Ada.Containers.Indefinite_Vectors;

powered by: WebSVN 2.1.0

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