1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_VECTORS --
9 -- Copyright (C) 2004 Free Software Foundation, Inc. --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the contents of the part following the private keyword. --
15 -- GNAT is free software; you can redistribute it and/or modify it under --
16 -- terms of the GNU General Public License as published by the Free Soft- --
17 -- ware Foundation; either version 2, or (at your option) any later ver- --
18 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
21 -- for more details. You should have received a copy of the GNU General --
22 -- Public License distributed with GNAT; see file COPYING. If not, write --
23 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
24 -- MA 02111-1307, USA. --
26 -- As a special exception, if other files instantiate generics from this --
27 -- unit, or you link this unit with other files to produce an executable, --
28 -- this unit does not by itself cause the resulting executable to be --
29 -- covered by the GNU General Public License. This exception does not --
30 -- however invalidate any other reasons why the executable file might be --
31 -- covered by the GNU Public License. --
33 -- This unit has originally being developed by Matthew J Heaney. --
34 ------------------------------------------------------------------------------
36 with Ada
.Containers
.Generic_Array_Sort
;
37 with Ada
.Unchecked_Deallocation
;
38 with System
; use type System
.Address
;
40 package body Ada
.Containers
.Indefinite_Vectors
is
43 type Int
is range System
.Min_Int
.. System
.Max_Int
;
46 new Ada
.Unchecked_Deallocation
(Elements_Type
, Elements_Access
);
49 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
52 procedure Adjust
(Container
: in out Vector
) is
55 if Container
.Elements
= null then
59 if Container
.Elements
'Length = 0
60 or else Container
.Last
< Index_Type
'First
62 Container
.Elements
:= null;
67 E
: Elements_Type
renames Container
.Elements
.all;
68 L
: constant Index_Type
:= Container
.Last
;
71 Container
.Elements
:= null;
72 Container
.Last
:= Index_Type
'Pred (Index_Type
'First);
74 Container
.Elements
:= new Elements_Type
(Index_Type
'First .. L
);
76 for I
in Container
.Elements
'Range loop
79 Container
.Elements
(I
) := new Element_Type
'(E (I).all);
91 procedure Finalize (Container : in out Vector) is
93 E : Elements_Access := Container.Elements;
94 L : constant Index_Type'Base := Container.Last;
98 Container.Elements := null;
99 Container.Last := Index_Type'Pred (Index_Type'First);
101 for I in Index_Type'First .. L loop
111 (Stream : access Root_Stream_Type'Class;
112 Container : in Vector) is
114 N : constant Count_Type := Length (Container);
118 Count_Type'Base'Write
(Stream
, N
);
125 E
: Elements_Type
renames Container
.Elements
.all;
127 for I
in Index_Type
'First .. Container
.Last
loop
129 -- There's another way to do this. Instead a separate
130 -- Boolean for each element, you could write a Boolean
131 -- followed by a count of how many nulls or non-nulls
132 -- follow in the array. Alternately you could use a
133 -- signed integer, and use the sign as the indicator
137 Boolean'Write (Stream
, False);
139 Boolean'Write (Stream
, True);
140 Element_Type
'Output (Stream
, E
(I
).all);
150 (Stream
: access Root_Stream_Type
'Class;
151 Container
: out Vector
) is
153 Length
: Count_Type
'Base;
154 Last
: Index_Type
'Base := Index_Type
'Pred (Index_Type
'First);
162 Count_Type
'Base'Read (Stream, Length);
164 if Length > Capacity (Container) then
165 Reserve_Capacity (Container, Capacity => Length);
168 for I in Count_Type range 1 .. Length loop
170 Last := Index_Type'Succ (Last);
172 Boolean'Read (Stream, B);
175 Container.Elements (Last) :=
176 new Element_Type'(Element_Type
'Input (Stream
));
179 Container
.Last
:= Last
;
186 function To_Vector
(Length
: Count_Type
) return Vector
is
195 First
: constant Int
:= Int
(Index_Type
'First);
197 Last_As_Int
: constant Int
'Base :=
198 First
+ Int
(Length
) - 1;
200 Last
: constant Index_Type
:=
201 Index_Type
(Last_As_Int
);
203 Elements
: constant Elements_Access
:=
204 new Elements_Type
(Index_Type
'First .. Last
);
208 return (Controlled
with Elements
, Last
);
217 (New_Item
: Element_Type
;
218 Length
: Count_Type
) return Vector
is
228 First
: constant Int
:= Int
(Index_Type
'First);
230 Last_As_Int
: constant Int
'Base :=
231 First
+ Int
(Length
) - 1;
233 Last
: constant Index_Type
:=
234 Index_Type
(Last_As_Int
);
236 Elements
: Elements_Access
:=
237 new Elements_Type
(Index_Type
'First .. Last
);
241 for I
in Elements
'Range loop
244 Elements
(I
) := new Element_Type
'(New_Item);
247 for J in Index_Type'First .. Index_Type'Pred (I) loop
257 return (Controlled with Elements, Last);
264 function "=" (Left, Right : Vector) return Boolean is
267 if Left'Address = Right'Address then
271 if Left.Last /= Right.Last then
275 for I in Index_Type'First .. Left.Last loop
278 -- I think it's a bounded error to read or otherwise manipulate
279 -- an "empty" element, which here means that it has the value
280 -- null. If it's a bounded error then an exception might
281 -- propagate, or it might not. We take advantage of that
282 -- permission here to allow empty elements to be compared.
284 -- Whether this is the right decision I'm not really sure. If
285 -- you have a contrary argument then let me know.
288 if Left.Elements (I) = null then
290 if Right.Elements (I) /= null then
294 elsif Right.Elements (I) = null then
298 elsif Left.Elements (I).all /= Right.Elements (I).all then
311 function Length (Container : Vector) return Count_Type is
313 L : constant Int := Int (Container.Last);
314 F : constant Int := Int (Index_Type'First);
316 N : constant Int'Base := L - F + 1;
318 return Count_Type (N);
322 function Is_Empty (Container : Vector) return Boolean is
324 return Container.Last < Index_Type'First;
329 (Container : in out Vector;
330 Length : in Count_Type) is
332 N : constant Count_Type := Indefinite_Vectors.Length (Container);
346 Last_As_Int : constant Int'Base :=
347 Int (Index_Type'First) + Int (Length) - 1;
349 Last : constant Index_Type :=
350 Index_Type (Last_As_Int);
355 if Length > Capacity (Container) then
356 Reserve_Capacity (Container, Capacity => Length);
359 Container.Last := Last;
365 for I in reverse Index_Type'Succ (Last) .. Container.Last loop
368 X : Element_Access := Container.Elements (I);
370 Container.Elements (I) := null;
371 Container.Last := Index_Type'Pred (Container.Last);
382 procedure Clear (Container : in out Vector) is
385 for I in reverse Index_Type'First .. Container.Last loop
388 X : Element_Access := Container.Elements (I);
390 Container.Elements (I) := null;
391 Container.Last := Index_Type'Pred (I);
400 procedure Append (Container : in out Vector;
401 New_Item : in Element_Type;
402 Count : in Count_Type := 1) is
410 Index_Type'Succ (Container.Last),
417 (Container : in out Vector;
418 Before : in Extended_Index;
419 New_Item : in Element_Type;
420 Count : in Count_Type := 1) is
422 Old_Last_As_Int : constant Int := Int (Container.Last);
424 N : constant Int := Int (Count);
426 New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N;
428 New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int);
432 Dst_Last : Index_Type;
433 Dst : Elements_Access;
442 subtype Before_Subtype is Index_Type'Base range
443 Index_Type'First .. Index_Type'Succ (Container.Last);
445 Old_First : constant Before_Subtype := Before;
447 Old_First_As_Int : constant Int := Int (Old_First);
449 New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
451 Index := Index_Type (New_First_As_Int);
454 if Container.Elements = null then
457 subtype Elements_Subtype is
458 Elements_Type (Index_Type'First .. New_Last);
460 Container.Elements := new Elements_Subtype;
461 Container.Last := Index_Type'Pred (Index_Type'First);
463 for I in Container.Elements'Range loop
464 Container.Elements (I) := new Element_Type'(New_Item
);
473 if New_Last
<= Container
.Elements
'Last then
476 E
: Elements_Type
renames Container
.Elements
.all;
478 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
479 Container
.Last
:= New_Last
;
482 -- Now we do the allocation. If it fails, we can propagate the
483 -- exception and invariants are more or less satisfied. The
484 -- issue is that we have some slots still null, and the client
485 -- has no way of detecting whether the slot is null (unless we
488 -- Another way is to allocate a subarray on the stack, do the
489 -- allocation into that array, and if that success then do
490 -- the insertion proper. The issue there is that you have to
491 -- allocate the subarray on the stack, and that may fail if the
494 -- Or we could try to roll-back the changes: deallocate the
495 -- elements we have successfully deallocated, and then copy
496 -- the elements ptrs back to their original posns.
499 -- NOTE: I have written the loop manually here. I could
500 -- have done it this way too:
501 -- E (Before .. Index_Type'Pred (Index)) :=
502 -- (others => new Element_Type'New_Item);
505 for I
in Before
.. Index_Type
'Pred (Index
) loop
508 E
(I
) := new Element_Type
'(New_Item);
511 E (I .. Index_Type'Pred (Index)) := (others => null);
524 First : constant Int := Int (Index_Type'First);
526 New_Size : constant Int'Base :=
527 New_Last_As_Int - First + 1;
529 Max_Size : constant Int'Base :=
530 Int (Index_Type'Last) - First + 1;
532 Size, Dst_Last_As_Int : Int'Base;
536 if New_Size >= Max_Size / 2 then
538 Dst_Last := Index_Type'Last;
542 Size := Container.Elements'Length;
548 while Size < New_Size loop
552 Dst_Last_As_Int := First + Size - 1;
553 Dst_Last := Index_Type (Dst_Last_As_Int);
559 Dst := new Elements_Type (Index_Type'First .. Dst_Last);
562 Src : Elements_Type renames Container.Elements.all;
564 Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
565 Src (Index_Type'First .. Index_Type'Pred (Before));
567 Dst (Index .. New_Last) := Src (Before .. Container.Last);
571 X : Elements_Access := Container.Elements;
573 Container.Elements := Dst;
574 Container.Last := New_Last;
580 -- Now do the allocation. If the allocation fails,
581 -- then the worst thing is that we have a few null slots.
582 -- Our invariants are otherwise satisfied.
585 for I in Before .. Index_Type'Pred (Index) loop
586 Dst (I) := new Element_Type'(New_Item
);
592 procedure Insert_Space
593 (Container
: in out Vector
;
594 Before
: in Extended_Index
;
595 Count
: in Count_Type
:= 1) is
597 Old_Last_As_Int
: constant Int
:= Int
(Container
.Last
);
599 N
: constant Int
:= Int
(Count
);
601 New_Last_As_Int
: constant Int
'Base := Old_Last_As_Int
+ N
;
603 New_Last
: constant Extended_Index
:= Extended_Index
(New_Last_As_Int
);
607 Dst_Last
: Index_Type
;
608 Dst
: Elements_Access
;
617 subtype Before_Subtype
is Index_Type
'Base range
618 Index_Type
'First .. Index_Type
'Succ (Container
.Last
);
620 Old_First
: constant Before_Subtype
:= Before
;
622 Old_First_As_Int
: constant Int
:= Int
(Old_First
);
624 New_First_As_Int
: constant Int
'Base := Old_First_As_Int
+ N
;
626 Index
:= Index_Type
(New_First_As_Int
);
629 if Container
.Elements
= null then
632 subtype Elements_Subtype
is
633 Elements_Type
(Index_Type
'First .. New_Last
);
635 Container
.Elements
:= new Elements_Subtype
;
636 Container
.Last
:= New_Last
;
643 if New_Last
<= Container
.Elements
'Last then
646 E
: Elements_Type
renames Container
.Elements
.all;
648 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
649 E
(Before
.. Index_Type
'Pred (Index
)) := (others => null);
651 Container
.Last
:= New_Last
;
660 First
: constant Int
:= Int
(Index_Type
'First);
662 New_Size
: constant Int
'Base :=
663 Int
(New_Last_As_Int
) - First
+ 1;
665 Max_Size
: constant Int
'Base :=
666 Int
(Index_Type
'Last) - First
+ 1;
668 Size
, Dst_Last_As_Int
: Int
'Base;
672 if New_Size
>= Max_Size
/ 2 then
674 Dst_Last
:= Index_Type
'Last;
678 Size
:= Container
.Elements
'Length;
684 while Size
< New_Size
loop
688 Dst_Last_As_Int
:= First
+ Size
- 1;
689 Dst_Last
:= Index_Type
(Dst_Last_As_Int
);
695 Dst
:= new Elements_Type
(Index_Type
'First .. Dst_Last
);
698 Src
: Elements_Type
renames Container
.Elements
.all;
700 Dst
(Index_Type
'First .. Index_Type
'Pred (Before
)) :=
701 Src
(Index_Type
'First .. Index_Type
'Pred (Before
));
703 Dst
(Index
.. New_Last
) := Src
(Before
.. Container
.Last
);
707 X
: Elements_Access
:= Container
.Elements
;
709 Container
.Elements
:= Dst
;
710 Container
.Last
:= New_Last
;
718 procedure Delete_First
(Container
: in out Vector
;
719 Count
: in Count_Type
:= 1) is
726 if Count
>= Length
(Container
) then
731 Delete
(Container
, Index_Type
'First, Count
);
736 procedure Delete_Last
(Container
: in out Vector
;
737 Count
: in Count_Type
:= 1) is
747 if Count
>= Length
(Container
) then
752 Index
:= Int
'Base (Container
.Last
) - Int
'Base (Count
) + 1;
754 Delete
(Container
, Index_Type
'Base (Index
), Count
);
760 (Container
: in out Vector
;
761 Index
: in Extended_Index
; -- TODO: verify in Atlanta
762 Count
: in Count_Type
:= 1) is
772 subtype I_Subtype
is Index_Type
'Base range
773 Index_Type
'First .. Container
.Last
;
775 I
: constant I_Subtype
:= Index
;
776 I_As_Int
: constant Int
:= Int
(I
);
778 Old_Last_As_Int
: constant Int
:= Int
(Container
.Last
);
780 Count1
: constant Int
'Base := Int
(Count
);
781 Count2
: constant Int
'Base := Old_Last_As_Int
- I_As_Int
+ 1;
783 N
: constant Int
'Base := Int
'Min (Count1
, Count2
);
785 J_As_Int
: constant Int
'Base := I_As_Int
+ N
;
786 J
: constant Index_Type
'Base := Index_Type
'Base (J_As_Int
);
788 E
: Elements_Type
renames Container
.Elements
.all;
790 New_Last_As_Int
: constant Int
'Base := Old_Last_As_Int
- N
;
792 New_Last
: constant Extended_Index
:=
793 Extended_Index
(New_Last_As_Int
);
797 for K
in I
.. Index_Type
'Pred (J
) loop
809 E
(I
.. New_Last
) := E
(J
.. Container
.Last
);
810 Container
.Last
:= New_Last
;
817 function Capacity
(Container
: Vector
) return Count_Type
is
819 if Container
.Elements
= null then
823 return Container
.Elements
'Length;
827 procedure Reserve_Capacity
(Container
: in out Vector
;
828 Capacity
: in Count_Type
) is
830 N
: constant Count_Type
:= Length
(Container
);
839 X
: Elements_Access
:= Container
.Elements
;
841 Container
.Elements
:= null;
845 elsif N
< Container
.Elements
'Length then
848 subtype Array_Index_Subtype
is Index_Type
'Base range
849 Index_Type
'First .. Container
.Last
;
851 Src
: Elements_Type
renames
852 Container
.Elements
(Array_Index_Subtype
);
854 subtype Array_Subtype
is
855 Elements_Type
(Array_Index_Subtype
);
857 X
: Elements_Access
:= Container
.Elements
;
859 Container
.Elements
:= new Array_Subtype
'(Src);
869 if Container.Elements = null then
872 Last_As_Int : constant Int'Base :=
873 Int (Index_Type'First) + Int (Capacity) - 1;
875 Last : constant Index_Type :=
876 Index_Type (Last_As_Int);
878 subtype Array_Subtype is
879 Elements_Type (Index_Type'First .. Last);
881 Container.Elements := new Array_Subtype;
888 if Capacity <= N then
890 if N < Container.Elements'Length then
893 subtype Array_Index_Subtype is Index_Type'Base range
894 Index_Type'First .. Container.Last;
896 Src : Elements_Type renames
897 Container.Elements (Array_Index_Subtype);
899 subtype Array_Subtype is
900 Elements_Type (Array_Index_Subtype);
902 X : Elements_Access := Container.Elements;
904 Container.Elements := new Array_Subtype'(Src
);
914 if Capacity
= Container
.Elements
'Length then
919 Last_As_Int
: constant Int
'Base :=
920 Int
(Index_Type
'First) + Int
(Capacity
) - 1;
922 Last
: constant Index_Type
:=
923 Index_Type
(Last_As_Int
);
925 subtype Array_Subtype
is
926 Elements_Type
(Index_Type
'First .. Last
);
928 X
: Elements_Access
:= Container
.Elements
;
930 Container
.Elements
:= new Array_Subtype
;
933 Src
: Elements_Type
renames
934 X
(Index_Type
'First .. Container
.Last
);
936 Tgt
: Elements_Type
renames
937 Container
.Elements
(Index_Type
'First .. Container
.Last
);
945 end Reserve_Capacity
;
948 function First_Index
(Container
: Vector
) return Index_Type
is
949 pragma Warnings
(Off
, Container
);
951 return Index_Type
'First;
955 function First_Element
(Container
: Vector
) return Element_Type
is
957 return Element
(Container
, Index_Type
'First);
961 function Last_Index
(Container
: Vector
) return Extended_Index
is
963 return Container
.Last
;
967 function Last_Element
(Container
: Vector
) return Element_Type
is
969 return Element
(Container
, Container
.Last
);
973 function Element
(Container
: Vector
;
975 return Element_Type
is
977 subtype T
is Index_Type
'Base range
978 Index_Type
'First .. Container
.Last
;
980 return Container
.Elements
(T
'(Index)).all;
984 procedure Replace_Element (Container : in Vector;
985 Index : in Index_Type;
986 By : in Element_Type) is
988 subtype T is Index_Type'Base range
989 Index_Type'First .. Container.Last;
991 X : Element_Access := Container.Elements (T'(Index
));
993 Container
.Elements
(T
'(Index)) := new Element_Type'(By
);
998 procedure Generic_Sort
(Container
: in Vector
) is
1000 function Is_Less
(L
, R
: Element_Access
) return Boolean;
1001 pragma Inline
(Is_Less
);
1003 function Is_Less
(L
, R
: Element_Access
) return Boolean is
1010 return L
.all < R
.all;
1015 new Generic_Array_Sort
1023 if Container
.Elements
= null then
1027 Sort
(Container
.Elements
(Index_Type
'First .. Container
.Last
));
1033 (Container
: Vector
;
1034 Item
: Element_Type
;
1035 Index
: Index_Type
:= Index_Type
'First)
1036 return Extended_Index
is
1040 for I
in Index
.. Container
.Last
loop
1041 if Container
.Elements
(I
) /= null
1042 and then Container
.Elements
(I
).all = Item
1053 function Reverse_Find_Index
1054 (Container
: Vector
;
1055 Item
: Element_Type
;
1056 Index
: Index_Type
:= Index_Type
'Last)
1057 return Extended_Index
is
1059 Last
: Index_Type
'Base;
1063 if Index
> Container
.Last
then
1064 Last
:= Container
.Last
;
1069 for I
in reverse Index_Type
'First .. Last
loop
1070 if Container
.Elements
(I
) /= null
1071 and then Container
.Elements
(I
).all = Item
1079 end Reverse_Find_Index
;
1082 function Contains
(Container
: Vector
;
1083 Item
: Element_Type
) return Boolean is
1085 return Find_Index
(Container
, Item
) /= No_Index
;
1091 (Target
: in out Vector
;
1092 Source
: in Vector
) is
1094 N
: constant Count_Type
:= Length
(Source
);
1098 if Target
'Address = Source
'Address then
1108 if N
> Capacity
(Target
) then
1109 Reserve_Capacity
(Target
, Capacity
=> N
);
1112 for I
in Index_Type
'First .. Source
.Last
loop
1115 EA
: constant Element_Access
:= Source
.Elements
(I
);
1118 Target
.Elements
(I
) := new Element_Type
'(EA.all);
1130 (Target : in out Vector;
1131 Source : in out Vector) is
1133 X : Elements_Access := Target.Elements;
1137 if Target'Address = Source'Address then
1141 if Target.Last >= Index_Type'First then
1142 raise Constraint_Error;
1145 Target.Elements := null;
1146 Free (X); -- shouldn't fail
1148 Target.Elements := Source.Elements;
1149 Target.Last := Source.Last;
1151 Source.Elements := null;
1152 Source.Last := Index_Type'Pred (Index_Type'First);
1157 procedure Query_Element
1158 (Container : in Vector;
1159 Index : in Index_Type;
1160 Process : not null access procedure (Element : in Element_Type)) is
1162 subtype T is Index_Type'Base range
1163 Index_Type'First .. Container.Last;
1165 Process (Container.Elements (T'(Index
)).all);
1169 procedure Update_Element
1170 (Container
: in Vector
;
1171 Index
: in Index_Type
;
1172 Process
: not null access procedure (Element
: in out Element_Type
)) is
1174 subtype T
is Index_Type
'Base range
1175 Index_Type
'First .. Container
.Last
;
1177 Process
(Container
.Elements
(T
'(Index)).all);
1181 procedure Prepend (Container : in out Vector;
1182 New_Item : in Element_Type;
1183 Count : in Count_Type := 1) is
1193 (Container : in Vector;
1194 I, J : in Index_Type) is
1196 subtype T is Index_Type'Base range
1197 Index_Type'First .. Container.Last;
1199 EI : constant Element_Access := Container.Elements (T'(I
));
1203 Container
.Elements
(T
'(I)) := Container.Elements (T'(J
));
1204 Container
.Elements
(T
'(J)) := EI;
1209 function "&" (Left, Right : Vector) return Vector is
1211 LN : constant Count_Type := Length (Left);
1212 RN : constant Count_Type := Length (Right);
1219 return Empty_Vector;
1223 RE : Elements_Type renames
1224 Right.Elements (Index_Type'First .. Right.Last);
1226 Elements : Elements_Access :=
1227 new Elements_Type (RE'Range);
1229 for I in Elements'Range loop
1231 if RE (I) /= null then
1232 Elements (I) := new Element_Type'(RE
(I
).all);
1236 for J
in Index_Type
'First .. Index_Type
'Pred (I
) loop
1237 Free
(Elements
(J
));
1245 return (Controlled
with Elements
, Right
.Last
);
1253 LE
: Elements_Type
renames
1254 Left
.Elements
(Index_Type
'First .. Left
.Last
);
1256 Elements
: Elements_Access
:=
1257 new Elements_Type
(LE
'Range);
1259 for I
in Elements
'Range loop
1261 if LE
(I
) /= null then
1262 Elements
(I
) := new Element_Type
'(LE (I).all);
1266 for J in Index_Type'First .. Index_Type'Pred (I) loop
1267 Free (Elements (J));
1275 return (Controlled with Elements, Left.Last);
1282 Last_As_Int : constant Int'Base :=
1283 Int (Index_Type'First) + Int (LN) + Int (RN) - 1;
1285 Last : constant Index_Type := Index_Type (Last_As_Int);
1287 LE : Elements_Type renames
1288 Left.Elements (Index_Type'First .. Left.Last);
1290 RE : Elements_Type renames
1291 Right.Elements (Index_Type'First .. Right.Last);
1293 Elements : Elements_Access :=
1294 new Elements_Type (Index_Type'First .. Last);
1296 I : Index_Type'Base := Index_Type'Pred (Index_Type'First);
1300 for LI in LE'Range loop
1302 I := Index_Type'Succ (I);
1305 if LE (LI) /= null then
1306 Elements (I) := new Element_Type'(LE
(LI
).all);
1310 for J
in Index_Type
'First .. Index_Type
'Pred (I
) loop
1311 Free
(Elements
(J
));
1320 for RI
in RE
'Range loop
1322 I
:= Index_Type
'Succ (I
);
1325 if RE
(RI
) /= null then
1326 Elements
(I
) := new Element_Type
'(RE (RI).all);
1330 for J in Index_Type'First .. Index_Type'Pred (I) loop
1331 Free (Elements (J));
1340 return (Controlled with Elements, Last);
1346 function "&" (Left : Vector;
1347 Right : Element_Type) return Vector is
1349 LN : constant Count_Type := Length (Left);
1356 Elements : Elements_Access :=
1357 new Elements_Type (Index_Type'First .. Index_Type'First);
1361 Elements (Elements'First) := new Element_Type'(Right
);
1368 return (Controlled
with Elements
, Index_Type
'First);
1376 Last_As_Int
: constant Int
'Base :=
1377 Int
(Index_Type
'First) + Int
(LN
);
1379 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
1381 LE
: Elements_Type
renames
1382 Left
.Elements
(Index_Type
'First .. Left
.Last
);
1384 Elements
: Elements_Access
:=
1385 new Elements_Type
(Index_Type
'First .. Last
);
1389 for I
in LE
'Range loop
1392 if LE
(I
) /= null then
1393 Elements
(I
) := new Element_Type
'(LE (I).all);
1397 for J in Index_Type'First .. Index_Type'Pred (I) loop
1398 Free (Elements (J));
1408 Elements (Elements'Last) := new Element_Type'(Right
);
1413 subtype J_Subtype
is Index_Type
'Base range
1414 Index_Type
'First .. Index_Type
'Pred (Elements
'Last);
1416 for J
in J_Subtype
loop
1417 Free
(Elements
(J
));
1425 return (Controlled
with Elements
, Last
);
1432 function "&" (Left
: Element_Type
;
1433 Right
: Vector
) return Vector
is
1435 RN
: constant Count_Type
:= Length
(Right
);
1442 Elements
: Elements_Access
:=
1443 new Elements_Type
(Index_Type
'First .. Index_Type
'First);
1447 Elements
(Elements
'First) := new Element_Type
'(Left);
1454 return (Controlled with Elements, Index_Type'First);
1462 Last_As_Int : constant Int'Base :=
1463 Int (Index_Type'First) + Int (RN);
1465 Last : constant Index_Type := Index_Type (Last_As_Int);
1467 RE : Elements_Type renames
1468 Right.Elements (Index_Type'First .. Right.Last);
1470 Elements : Elements_Access :=
1471 new Elements_Type (Index_Type'First .. Last);
1473 I : Index_Type'Base := Index_Type'First;
1478 Elements (I) := new Element_Type'(Left
);
1485 for RI
in RE
'Range loop
1487 I
:= Index_Type
'Succ (I
);
1490 if RE
(RI
) /= null then
1491 Elements
(I
) := new Element_Type
'(RE (RI).all);
1495 for J in Index_Type'First .. Index_Type'Pred (I) loop
1496 Free (Elements (J));
1505 return (Controlled with Elements, Last);
1511 function "&" (Left, Right : Element_Type) return Vector is
1513 subtype IT is Index_Type'Base range
1514 Index_Type'First .. Index_Type'Succ (Index_Type'First);
1516 Elements : Elements_Access := new Elements_Type (IT);
1521 Elements (Elements'First) := new Element_Type'(Left
);
1529 Elements
(Elements
'Last) := new Element_Type
'(Right);
1532 Free (Elements (Elements'First));
1537 return (Controlled with Elements, Elements'Last);
1542 function To_Cursor (Container : Vector;
1543 Index : Extended_Index)
1546 if Index not in Index_Type'First .. Container.Last then
1550 return Cursor'(Container
'Unchecked_Access, Index
);
1554 function To_Index
(Position
: Cursor
) return Extended_Index
is
1556 if Position
.Container
= null then
1560 if Position
.Index
<= Position
.Container
.Last
then
1561 return Position
.Index
;
1568 function Element
(Position
: Cursor
) return Element_Type
is
1570 return Element
(Position
.Container
.all, Position
.Index
);
1574 function Next
(Position
: Cursor
) return Cursor
is
1577 if Position
.Container
= null then
1581 if Position
.Index
< Position
.Container
.Last
then
1582 return (Position
.Container
, Index_Type
'Succ (Position
.Index
));
1590 function Previous
(Position
: Cursor
) return Cursor
is
1593 if Position
.Container
= null then
1597 if Position
.Index
> Index_Type
'First then
1598 return (Position
.Container
, Index_Type
'Pred (Position
.Index
));
1606 procedure Next
(Position
: in out Cursor
) is
1609 if Position
.Container
= null then
1613 if Position
.Index
< Position
.Container
.Last
then
1614 Position
.Index
:= Index_Type
'Succ (Position
.Index
);
1616 Position
:= No_Element
;
1622 procedure Previous
(Position
: in out Cursor
) is
1625 if Position
.Container
= null then
1629 if Position
.Index
> Index_Type
'First then
1630 Position
.Index
:= Index_Type
'Pred (Position
.Index
);
1632 Position
:= No_Element
;
1638 function Has_Element
(Position
: Cursor
) return Boolean is
1641 if Position
.Container
= null then
1645 return Position
.Index
<= Position
.Container
.Last
;
1651 (Container
: in Vector
;
1652 Process
: not null access procedure (Position
: in Cursor
)) is
1655 for I
in Index_Type
'First .. Container
.Last
loop
1656 Process
(Cursor
'(Container'Unchecked_Access, I));
1662 procedure Reverse_Iterate
1663 (Container : in Vector;
1664 Process : not null access procedure (Position : in Cursor)) is
1667 for I in reverse Index_Type'First .. Container.Last loop
1668 Process (Cursor'(Container
'Unchecked_Access, I
));
1671 end Reverse_Iterate
;
1674 procedure Query_Element
1675 (Position
: in Cursor
;
1676 Process
: not null access procedure (Element
: in Element_Type
)) is
1678 C
: Vector
renames Position
.Container
.all;
1679 E
: Elements_Type
renames C
.Elements
.all;
1681 subtype T
is Index_Type
'Base range
1682 Index_Type
'First .. C
.Last
;
1684 Process
(E
(T
'(Position.Index)).all);
1688 procedure Update_Element
1689 (Position : in Cursor;
1690 Process : not null access procedure (Element : in out Element_Type)) is
1692 C : Vector renames Position.Container.all;
1693 E : Elements_Type renames C.Elements.all;
1695 subtype T is Index_Type'Base range
1696 Index_Type'First .. C.Last;
1698 Process (E (T'(Position
.Index
)).all);
1702 procedure Replace_Element
(Position
: in Cursor
;
1703 By
: in Element_Type
) is
1705 C
: Vector
renames Position
.Container
.all;
1706 E
: Elements_Type
renames C
.Elements
.all;
1708 subtype T
is Index_Type
'Base range
1709 Index_Type
'First .. C
.Last
;
1711 X
: Element_Access
:= E
(T
'(Position.Index));
1713 E (T'(Position
.Index
)) := new Element_Type
'(By);
1715 end Replace_Element;
1718 procedure Insert (Container : in out Vector;
1719 Before : in Extended_Index;
1720 New_Item : in Vector) is
1722 N : constant Count_Type := Length (New_Item);
1730 Insert_Space (Container, Before, Count => N);
1732 if Container'Address = New_Item'Address then
1735 Dst_Last_As_Int : constant Int'Base :=
1736 Int'Base (Before) + Int'Base (N) - 1;
1738 Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
1740 Dst_Index : Index_Type'Base := Index_Type'Pred (Before);
1742 Dst : Elements_Type renames
1743 Container.Elements (Before .. Dst_Last);
1747 subtype Src_Index_Subtype is Index_Type'Base range
1748 Index_Type'First .. Index_Type'Pred (Before);
1750 Src : Elements_Type renames
1751 Container.Elements (Src_Index_Subtype);
1753 for Src_Index in Src'Range loop
1754 Dst_Index := Index_Type'Succ (Dst_Index);
1756 if Src (Src_Index) /= null then
1757 Dst (Dst_Index) := new Element_Type'(Src
(Src_Index
).all);
1763 subtype Src_Index_Subtype
is Index_Type
'Base range
1764 Index_Type
'Succ (Dst_Last
) .. Container
.Last
;
1766 Src
: Elements_Type
renames
1767 Container
.Elements
(Src_Index_Subtype
);
1769 for Src_Index
in Src
'Range loop
1770 Dst_Index
:= Index_Type
'Succ (Dst_Index
);
1772 if Src
(Src_Index
) /= null then
1773 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
1783 Dst_Last_As_Int : constant Int'Base :=
1784 Int'Base (Before) + Int'Base (N) - 1;
1786 Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
1788 Dst_Index : Index_Type'Base := Index_Type'Pred (Before);
1790 Src : Elements_Type renames
1791 New_Item.Elements (Index_Type'First .. New_Item.Last);
1793 Dst : Elements_Type renames
1794 Container.Elements (Before .. Dst_Last);
1796 for Src_Index in Src'Range loop
1797 Dst_Index := Index_Type'Succ (Dst_Index);
1799 if Src (Src_Index) /= null then
1800 Dst (Dst_Index) := new Element_Type'(Src
(Src_Index
).all);
1810 procedure Insert
(Container
: in out Vector
;
1812 New_Item
: in Vector
) is
1814 Index
: Index_Type
'Base;
1818 if Before
.Container
/= null
1819 and then Before
.Container
/= Vector_Access
'(Container'Unchecked_Access)
1821 raise Program_Error;
1824 if Is_Empty (New_Item) then
1828 if Before.Container = null
1829 or else Before.Index > Container.Last
1831 Index := Index_Type'Succ (Container.Last);
1833 Index := Before.Index;
1836 Insert (Container, Index, New_Item);
1842 procedure Insert (Container : in out Vector;
1844 New_Item : in Vector;
1845 Position : out Cursor) is
1847 Index : Index_Type'Base;
1851 if Before.Container /= null
1852 and then Before.Container /= Vector_Access'(Container
'Unchecked_Access)
1854 raise Program_Error
;
1857 if Is_Empty
(New_Item
) then
1859 if Before
.Container
= null
1860 or else Before
.Index
> Container
.Last
1862 Position
:= No_Element
;
1864 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1871 if Before
.Container
= null
1872 or else Before
.Index
> Container
.Last
1874 Index
:= Index_Type
'Succ (Container
.Last
);
1876 Index
:= Before
.Index
;
1879 Insert
(Container
, Index
, New_Item
);
1881 Position
:= (Container
'Unchecked_Access, Index
);
1886 procedure Insert
(Container
: in out Vector
;
1888 New_Item
: in Element_Type
;
1889 Count
: in Count_Type
:= 1) is
1891 Index
: Index_Type
'Base;
1895 if Before
.Container
/= null
1896 and then Before
.Container
/= Vector_Access
'(Container'Unchecked_Access)
1898 raise Program_Error;
1905 if Before.Container = null
1906 or else Before.Index > Container.Last
1908 Index := Index_Type'Succ (Container.Last);
1910 Index := Before.Index;
1913 Insert (Container, Index, New_Item, Count);
1918 procedure Insert (Container : in out Vector;
1920 New_Item : in Element_Type;
1921 Position : out Cursor;
1922 Count : in Count_Type := 1) is
1924 Index : Index_Type'Base;
1928 if Before.Container /= null
1929 and then Before.Container /= Vector_Access'(Container
'Unchecked_Access)
1931 raise Program_Error
;
1936 if Before
.Container
= null
1937 or else Before
.Index
> Container
.Last
1939 Position
:= No_Element
;
1941 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1948 if Before
.Container
= null
1949 or else Before
.Index
> Container
.Last
1951 Index
:= Index_Type
'Succ (Container
.Last
);
1953 Index
:= Before
.Index
;
1956 Insert
(Container
, Index
, New_Item
, Count
);
1958 Position
:= (Container
'Unchecked_Access, Index
);
1964 procedure Prepend
(Container
: in out Vector
;
1965 New_Item
: in Vector
) is
1967 Insert
(Container
, Index_Type
'First, New_Item
);
1971 procedure Append
(Container
: in out Vector
;
1972 New_Item
: in Vector
) is
1974 if Is_Empty
(New_Item
) then
1980 Index_Type
'Succ (Container
.Last
),
1986 procedure Insert_Space
(Container
: in out Vector
;
1988 Position
: out Cursor
;
1989 Count
: in Count_Type
:= 1) is
1991 Index
: Index_Type
'Base;
1995 if Before
.Container
/= null
1996 and then Before
.Container
/= Vector_Access
'(Container'Unchecked_Access)
1998 raise Program_Error;
2003 if Before.Container = null
2004 or else Before.Index > Container.Last
2006 Position := No_Element;
2008 Position := (Container'Unchecked_Access, Before.Index);
2015 if Before.Container = null
2016 or else Before.Index > Container.Last
2018 Index := Index_Type'Succ (Container.Last);
2020 Index := Before.Index;
2023 Insert_Space (Container, Index, Count);
2025 Position := (Container'Unchecked_Access, Index);
2030 procedure Delete (Container : in out Vector;
2031 Position : in out Cursor;
2032 Count : in Count_Type := 1) is
2035 if Position.Container /= null
2036 and then Position.Container /=
2037 Vector_Access'(Container
'Unchecked_Access)
2039 raise Program_Error
;
2042 if Position
.Container
= null
2043 or else Position
.Index
> Container
.Last
2045 Position
:= No_Element
;
2049 Delete
(Container
, Position
.Index
, Count
);
2051 if Position
.Index
<= Container
.Last
then
2052 Position
:= (Container
'Unchecked_Access, Position
.Index
);
2054 Position
:= No_Element
;
2060 function First
(Container
: Vector
) return Cursor
is
2062 if Is_Empty
(Container
) then
2066 return (Container
'Unchecked_Access, Index_Type
'First);
2070 function Last
(Container
: Vector
) return Cursor
is
2072 if Is_Empty
(Container
) then
2076 return (Container
'Unchecked_Access, Container
.Last
);
2080 procedure Swap
(I
, J
: in Cursor
) is
2082 -- NOTE: I've liberalized the behavior here, to
2083 -- allow I and J to designate different containers.
2084 -- TODO: I think this is suppose to raise P_E.
2086 subtype TI
is Index_Type
'Base range
2087 Index_Type
'First .. I
.Container
.Last
;
2089 EI
: Element_Access
renames
2090 I
.Container
.Elements
(TI
'(I.Index));
2092 EI_Copy : constant Element_Access := EI;
2094 subtype TJ is Index_Type'Base range
2095 Index_Type'First .. J.Container.Last;
2097 EJ : Element_Access renames
2098 J.Container.Elements (TJ'(J
.Index
));
2108 function Find
(Container
: Vector
;
2109 Item
: Element_Type
;
2110 Position
: Cursor
:= No_Element
) return Cursor
is
2114 if Position
.Container
/= null
2115 and then Position
.Container
/=
2116 Vector_Access
'(Container'Unchecked_Access)
2118 raise Program_Error;
2121 for I in Position.Index .. Container.Last loop
2122 if Container.Elements (I) /= null
2123 and then Container.Elements (I).all = Item
2125 return (Container'Unchecked_Access, I);
2134 function Reverse_Find (Container : Vector;
2135 Item : Element_Type;
2136 Position : Cursor := No_Element) return Cursor is
2138 Last : Index_Type'Base;
2142 if Position.Container /= null
2143 and then Position.Container /=
2144 Vector_Access'(Container
'Unchecked_Access)
2146 raise Program_Error
;
2149 if Position
.Container
= null
2150 or else Position
.Index
> Container
.Last
2152 Last
:= Container
.Last
;
2154 Last
:= Position
.Index
;
2157 for I
in reverse Index_Type
'First .. Last
loop
2158 if Container
.Elements
(I
) /= null
2159 and then Container
.Elements
(I
).all = Item
2161 return (Container
'Unchecked_Access, I
);
2170 end Ada
.Containers
.Indefinite_Vectors
;