1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
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 --
9 -- Copyright (C) 2004-2005, 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, 51 Franklin Street, Fifth Floor, --
24 -- Boston, MA 02110-1301, 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
42 type Int
is range System
.Min_Int
.. System
.Max_Int
;
45 new Ada
.Unchecked_Deallocation
(Elements_Type
, Elements_Access
);
48 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
54 function "&" (Left
, Right
: Vector
) return Vector
is
55 LN
: constant Count_Type
:= Length
(Left
);
56 RN
: constant Count_Type
:= Length
(Right
);
65 RE
: Elements_Type
renames
66 Right
.Elements
(Index_Type
'First .. Right
.Last
);
68 Elements
: Elements_Access
:=
69 new Elements_Type
(RE
'Range);
72 for I
in Elements
'Range loop
74 if RE
(I
) /= null then
75 Elements
(I
) := new Element_Type
'(RE (I).all);
79 for J in Index_Type'First .. I - 1 loop
88 return (Controlled with Elements, Right.Last, 0, 0);
95 LE : Elements_Type renames
96 Left.Elements (Index_Type'First .. Left.Last);
98 Elements : Elements_Access :=
99 new Elements_Type (LE'Range);
102 for I in Elements'Range loop
104 if LE (I) /= null then
105 Elements (I) := new Element_Type'(LE
(I
).all);
109 for J
in Index_Type
'First .. I
- 1 loop
118 return (Controlled
with Elements
, Left
.Last
, 0, 0);
123 Last_As_Int
: constant Int
'Base := -- TODO: handle overflow
124 Int
(Index_Type
'First) + Int
(LN
) + Int
(RN
) - 1;
127 if Last_As_Int
> Index_Type
'Pos (Index_Type
'Last) then
128 raise Constraint_Error
;
132 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
134 LE
: Elements_Type
renames
135 Left
.Elements
(Index_Type
'First .. Left
.Last
);
137 RE
: Elements_Type
renames
138 Right
.Elements
(Index_Type
'First .. Right
.Last
);
140 Elements
: Elements_Access
:=
141 new Elements_Type
(Index_Type
'First .. Last
);
143 I
: Index_Type
'Base := No_Index
;
146 for LI
in LE
'Range loop
150 if LE
(LI
) /= null then
151 Elements
(I
) := new Element_Type
'(LE (LI).all);
155 for J in Index_Type'First .. I - 1 loop
164 for RI in RE'Range loop
168 if RE (RI) /= null then
169 Elements (I) := new Element_Type'(RE
(RI
).all);
173 for J
in Index_Type
'First .. I
- 1 loop
182 return (Controlled
with Elements
, Last
, 0, 0);
187 function "&" (Left
: Vector
; Right
: Element_Type
) return Vector
is
188 LN
: constant Count_Type
:= Length
(Left
);
193 subtype Elements_Subtype
is
194 Elements_Type
(Index_Type
'First .. Index_Type
'First);
196 Elements
: Elements_Access
:= new Elements_Subtype
;
200 Elements
(Elements
'First) := new Element_Type
'(Right);
207 return (Controlled with Elements, Index_Type'First, 0, 0);
212 Last_As_Int : constant Int'Base :=
213 Int (Index_Type'First) + Int (LN);
216 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
217 raise Constraint_Error;
221 Last : constant Index_Type := Index_Type (Last_As_Int);
223 LE : Elements_Type renames
224 Left.Elements (Index_Type'First .. Left.Last);
226 Elements : Elements_Access :=
227 new Elements_Type (Index_Type'First .. Last);
230 for I in LE'Range loop
232 if LE (I) /= null then
233 Elements (I) := new Element_Type'(LE
(I
).all);
237 for J
in Index_Type
'First .. I
- 1 loop
247 Elements
(Elements
'Last) := new Element_Type
'(Right);
250 for J in Index_Type'First .. Elements'Last - 1 loop
258 return (Controlled with Elements, Last, 0, 0);
263 function "&" (Left : Element_Type; Right : Vector) return Vector is
264 RN : constant Count_Type := Length (Right);
269 subtype Elements_Subtype is
270 Elements_Type (Index_Type'First .. Index_Type'First);
272 Elements : Elements_Access := new Elements_Subtype;
276 Elements (Elements'First) := new Element_Type'(Left
);
283 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
288 Last_As_Int
: constant Int
'Base :=
289 Int
(Index_Type
'First) + Int
(RN
);
292 if Last_As_Int
> Index_Type
'Pos (Index_Type
'Last) then
293 raise Constraint_Error
;
297 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
299 RE
: Elements_Type
renames
300 Right
.Elements
(Index_Type
'First .. Right
.Last
);
302 Elements
: Elements_Access
:=
303 new Elements_Type
(Index_Type
'First .. Last
);
305 I
: Index_Type
'Base := Index_Type
'First;
309 Elements
(I
) := new Element_Type
'(Left);
316 for RI in RE'Range loop
320 if RE (RI) /= null then
321 Elements (I) := new Element_Type'(RE
(RI
).all);
325 for J
in Index_Type
'First .. I
- 1 loop
334 return (Controlled
with Elements
, Last
, 0, 0);
339 function "&" (Left
, Right
: Element_Type
) return Vector
is
341 if Index_Type
'First >= Index_Type
'Last then
342 raise Constraint_Error
;
346 Last
: constant Index_Type
:= Index_Type
'First + 1;
348 subtype ET
is Elements_Type
(Index_Type
'First .. Last
);
350 Elements
: Elements_Access
:= new ET
;
353 Elements
(Elements
'First) := new Element_Type
'(Left);
361 Elements (Elements'Last) := new Element_Type'(Right
);
364 Free
(Elements
(Elements
'First));
369 return (Controlled
with Elements
, Elements
'Last, 0, 0);
377 function "=" (Left
, Right
: Vector
) return Boolean is
379 if Left
'Address = Right
'Address then
383 if Left
.Last
/= Right
.Last
then
387 for J
in Index_Type
'First .. Left
.Last
loop
388 if Left
.Elements
(J
) = null then
389 if Right
.Elements
(J
) /= null then
393 elsif Right
.Elements
(J
) = null then
396 elsif Left
.Elements
(J
).all /= Right
.Elements
(J
).all then
408 procedure Adjust
(Container
: in out Vector
) is
410 if Container
.Last
= No_Index
then
411 Container
.Elements
:= null;
416 E
: Elements_Type
renames Container
.Elements
.all;
417 L
: constant Index_Type
:= Container
.Last
;
420 Container
.Elements
:= null;
421 Container
.Last
:= No_Index
;
425 Container
.Elements
:= new Elements_Type
(Index_Type
'First .. L
);
427 for I
in Container
.Elements
'Range loop
428 if E
(I
) /= null then
429 Container
.Elements
(I
) := new Element_Type
'(E (I).all);
441 procedure Append (Container : in out Vector; New_Item : Vector) is
443 if Is_Empty (New_Item) then
447 if Container.Last = Index_Type'Last then
448 raise Constraint_Error;
458 (Container : in out Vector;
459 New_Item : Element_Type;
460 Count : Count_Type := 1)
467 if Container.Last = Index_Type'Last then
468 raise Constraint_Error;
482 function Capacity (Container : Vector) return Count_Type is
484 if Container.Elements = null then
488 return Container.Elements'Length;
495 procedure Clear (Container : in out Vector) is
497 if Container.Busy > 0 then
501 while Container.Last >= Index_Type'First loop
503 X : Element_Access := Container.Elements (Container.Last);
505 Container.Elements (Container.Last) := null;
506 Container.Last := Container.Last - 1;
518 Item : Element_Type) return Boolean
521 return Find_Index (Container, Item) /= No_Index;
529 (Container : in out Vector;
530 Index : Extended_Index;
531 Count : Count_Type := 1)
534 if Index < Index_Type'First then
535 raise Constraint_Error;
538 if Index > Container.Last then
539 if Index > Container.Last + 1 then
540 raise Constraint_Error;
550 if Container.Busy > 0 then
555 Index_As_Int : constant Int := Int (Index);
556 Old_Last_As_Int : constant Int := Int (Container.Last);
558 -- TODO: somewhat vestigial...fix ???
559 Count1 : constant Int'Base := Int (Count);
560 Count2 : constant Int'Base := Old_Last_As_Int - Index_As_Int + 1;
561 N : constant Int'Base := Int'Min (Count1, Count2);
563 J_As_Int : constant Int'Base := Index_As_Int + N;
564 E : Elements_Type renames Container.Elements.all;
567 if J_As_Int > Old_Last_As_Int then
568 while Container.Last >= Index loop
570 K : constant Index_Type := Container.Last;
571 X : Element_Access := E (K);
575 Container.Last := K - 1;
582 J : constant Index_Type := Index_Type (J_As_Int);
584 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
585 New_Last : constant Index_Type :=
586 Index_Type (New_Last_As_Int);
589 for K in Index .. J - 1 loop
591 X : Element_Access := E (K);
598 E (Index .. New_Last) := E (J .. Container.Last);
599 Container.Last := New_Last;
606 (Container : in out Vector;
607 Position : in out Cursor;
608 Count : Count_Type := 1)
611 if Position.Container = null then
612 raise Constraint_Error;
615 if Position.Container /= Container'Unchecked_Access
616 or else Position.Index > Container.Last
621 Delete (Container, Position.Index, Count);
623 Position := No_Element; -- See comment in a-convec.adb
630 procedure Delete_First
631 (Container : in out Vector;
632 Count : Count_Type := 1)
639 if Count >= Length (Container) then
644 Delete (Container, Index_Type'First, Count);
651 procedure Delete_Last
652 (Container : in out Vector;
653 Count : Count_Type := 1)
655 N : constant Count_Type := Length (Container);
664 if Container.Busy > 0 then
669 E : Elements_Type renames Container.Elements.all;
672 for Indx in 1 .. Count_Type'Min (Count, N) loop
674 J : constant Index_Type := Container.Last;
675 X : Element_Access := E (J);
679 Container.Last := J - 1;
692 Index : Index_Type) return Element_Type
695 if Index > Container.Last then
696 raise Constraint_Error;
700 EA : constant Element_Access := Container.Elements (Index);
704 raise Constraint_Error;
711 function Element (Position : Cursor) return Element_Type is
713 if Position.Container = null then
714 raise Constraint_Error;
717 return Element (Position.Container.all, Position.Index);
724 procedure Finalize (Container : in out Vector) is
729 X : Elements_Access := Container.Elements;
731 Container.Elements := null;
743 Position : Cursor := No_Element) return Cursor
746 if Position.Container /= null
747 and then (Position.Container /= Container'Unchecked_Access
748 or else Position.Index > Container.Last)
753 for J in Position.Index .. Container.Last loop
754 if Container.Elements (J) /= null
755 and then Container.Elements (J).all = Item
757 return (Container'Unchecked_Access, J);
771 Index : Index_Type := Index_Type'First) return Extended_Index
774 for Indx in Index .. Container.Last loop
775 if Container.Elements (Indx) /= null
776 and then Container.Elements (Indx).all = Item
789 function First (Container : Vector) return Cursor is
791 if Is_Empty (Container) then
795 return (Container'Unchecked_Access, Index_Type'First);
802 function First_Element (Container : Vector) return Element_Type is
804 return Element (Container, Index_Type'First);
811 function First_Index (Container : Vector) return Index_Type is
812 pragma Unreferenced (Container);
814 return Index_Type'First;
817 ---------------------
818 -- Generic_Sorting --
819 ---------------------
821 package body Generic_Sorting is
823 -----------------------
824 -- Local Subprograms --
825 -----------------------
827 function Is_Less (L, R : Element_Access) return Boolean;
828 pragma Inline (Is_Less);
834 function Is_Less (L, R : Element_Access) return Boolean is
841 return L.all < R.all;
849 function Is_Sorted (Container : Vector) return Boolean is
851 if Container.Last <= Index_Type'First then
856 E : Elements_Type renames Container.Elements.all;
858 for I in Index_Type'First .. Container.Last - 1 loop
859 if Is_Less (E (I + 1), E (I)) then
872 procedure Merge (Target, Source : in out Vector) is
873 I : Index_Type'Base := Target.Last;
877 if Target.Last < Index_Type'First then
878 Move (Target => Target, Source => Source);
882 if Target'Address = Source'Address then
886 if Source.Last < Index_Type'First then
890 if Source.Busy > 0 then
894 Target.Set_Length (Length (Target) + Length (Source));
897 while Source.Last >= Index_Type'First loop
899 (Source.Last <= Index_Type'First
901 (Source.Elements (Source.Last),
902 Source.Elements (Source.Last - 1))));
904 if I < Index_Type'First then
906 Src : Elements_Type renames
907 Source.Elements (Index_Type'First .. Source.Last);
910 Target.Elements (Index_Type'First .. J) := Src;
911 Src := (others => null);
914 Source.Last := No_Index;
919 (I <= Index_Type'First
921 (Target.Elements (I),
922 Target.Elements (I - 1))));
925 Src : Element_Access renames Source.Elements (Source.Last);
926 Tgt : Element_Access renames Target.Elements (I);
929 if Is_Less (Src, Tgt) then
930 Target.Elements (J) := Tgt;
935 Target.Elements (J) := Src;
937 Source.Last := Source.Last - 1;
949 procedure Sort (Container : in out Vector)
952 new Generic_Array_Sort
953 (Index_Type => Index_Type,
954 Element_Type => Element_Access,
955 Array_Type => Elements_Type,
958 -- Start of processing for Sort
961 if Container.Last <= Index_Type'First then
965 if Container.Lock > 0 then
969 Sort (Container.Elements (Index_Type'First .. Container.Last));
978 function Has_Element (Position : Cursor) return Boolean is
980 if Position.Container = null then
984 return Position.Index <= Position.Container.Last;
992 (Container : in out Vector;
993 Before : Extended_Index;
994 New_Item : Element_Type;
995 Count : Count_Type := 1)
997 N : constant Int := Int (Count);
999 New_Last_As_Int : Int'Base;
1000 New_Last : Index_Type;
1002 Dst : Elements_Access;
1005 if Before < Index_Type'First then
1006 raise Constraint_Error;
1009 if Before > Container.Last
1010 and then Before > Container.Last + 1
1012 raise Constraint_Error;
1020 Old_Last_As_Int : constant Int := Int (Container.Last);
1023 New_Last_As_Int := Old_Last_As_Int + N;
1025 if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1026 raise Constraint_Error;
1029 New_Last := Index_Type (New_Last_As_Int);
1032 if Container.Busy > 0 then
1033 raise Program_Error;
1036 if Container.Elements = null then
1037 Container.Elements :=
1038 new Elements_Type (Index_Type'First .. New_Last);
1040 Container.Last := No_Index;
1042 for J in Container.Elements'Range loop
1043 Container.Elements (J) := new Element_Type'(New_Item
);
1044 Container
.Last
:= J
;
1050 if New_Last
<= Container
.Elements
'Last then
1052 E
: Elements_Type
renames Container
.Elements
.all;
1054 if Before
<= Container
.Last
then
1056 Index_As_Int
: constant Int
'Base :=
1057 Index_Type
'Pos (Before
) + N
;
1059 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1061 J
: Index_Type
'Base := Before
;
1064 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
1065 Container
.Last
:= New_Last
;
1067 while J
< Index
loop
1068 E
(J
) := new Element_Type
'(New_Item);
1073 E (J .. Index - 1) := (others => null);
1078 for J in Before .. New_Last loop
1079 E (J) := new Element_Type'(New_Item
);
1080 Container
.Last
:= J
;
1089 First
: constant Int
:= Int
(Index_Type
'First);
1090 New_Size
: constant Int
'Base := New_Last_As_Int
- First
+ 1;
1091 Size
: Int
'Base := Int
'Max (1, Container
.Elements
'Length);
1094 while Size
< New_Size
loop
1095 if Size
> Int
'Last / 2 then
1103 -- TODO: The following calculations aren't quite right, since
1104 -- there will be overflow if Index_Type'Range is very large
1105 -- (e.g. this package is instantiated with a 64-bit integer).
1109 Max_Size
: constant Int
'Base := Int
(Index_Type
'Last) - First
+ 1;
1111 if Size
> Max_Size
then
1117 Dst_Last
: constant Index_Type
:= Index_Type
(First
+ Size
- 1);
1119 Dst
:= new Elements_Type
(Index_Type
'First .. Dst_Last
);
1123 if Before
<= Container
.Last
then
1125 Index_As_Int
: constant Int
'Base :=
1126 Index_Type
'Pos (Before
) + N
;
1128 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1130 Src
: Elements_Access
:= Container
.Elements
;
1133 Dst
(Index_Type
'First .. Before
- 1) :=
1134 Src
(Index_Type
'First .. Before
- 1);
1136 Dst
(Index
.. New_Last
) := Src
(Before
.. Container
.Last
);
1138 Container
.Elements
:= Dst
;
1139 Container
.Last
:= New_Last
;
1142 for J
in Before
.. Index
- 1 loop
1143 Dst
(J
) := new Element_Type
'(New_Item);
1149 Src : Elements_Access := Container.Elements;
1152 Dst (Index_Type'First .. Container.Last) :=
1153 Src (Index_Type'First .. Container.Last);
1155 Container.Elements := Dst;
1158 for J in Before .. New_Last loop
1159 Dst (J) := new Element_Type'(New_Item
);
1160 Container
.Last
:= J
;
1167 (Container
: in out Vector
;
1168 Before
: Extended_Index
;
1171 N
: constant Count_Type
:= Length
(New_Item
);
1174 if Before
< Index_Type
'First then
1175 raise Constraint_Error
;
1178 if Before
> Container
.Last
1179 and then Before
> Container
.Last
+ 1
1181 raise Constraint_Error
;
1188 Insert_Space
(Container
, Before
, Count
=> N
);
1191 Dst_Last_As_Int
: constant Int
'Base :=
1192 Int
'Base (Before
) + Int
'Base (N
) - 1;
1194 Dst_Last
: constant Index_Type
:= Index_Type
(Dst_Last_As_Int
);
1196 Dst
: Elements_Type
renames
1197 Container
.Elements
(Before
.. Dst_Last
);
1199 Dst_Index
: Index_Type
'Base := Before
- 1;
1202 if Container
'Address /= New_Item
'Address then
1204 Src
: Elements_Type
renames
1205 New_Item
.Elements
(Index_Type
'First .. New_Item
.Last
);
1208 for Src_Index
in Src
'Range loop
1209 Dst_Index
:= Dst_Index
+ 1;
1211 if Src
(Src_Index
) /= null then
1212 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
1221 subtype Src_Index_Subtype is Index_Type'Base range
1222 Index_Type'First .. Before - 1;
1224 Src : Elements_Type renames
1225 Container.Elements (Src_Index_Subtype);
1228 for Src_Index in Src'Range loop
1229 Dst_Index := Dst_Index + 1;
1231 if Src (Src_Index) /= null then
1232 Dst (Dst_Index) := new Element_Type'(Src
(Src_Index
).all);
1237 if Dst_Last
= Container
.Last
then
1242 subtype Src_Index_Subtype
is Index_Type
'Base range
1243 Dst_Last
+ 1 .. Container
.Last
;
1245 Src
: Elements_Type
renames
1246 Container
.Elements
(Src_Index_Subtype
);
1249 for Src_Index
in Src
'Range loop
1250 Dst_Index
:= Dst_Index
+ 1;
1252 if Src
(Src_Index
) /= null then
1253 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
1261 (Container : in out Vector;
1265 Index : Index_Type'Base;
1268 if Before.Container /= null
1269 and then Before.Container /= Container'Unchecked_Access
1271 raise Program_Error;
1274 if Is_Empty (New_Item) then
1278 if Before.Container = null
1279 or else Before.Index > Container.Last
1281 if Container.Last = Index_Type'Last then
1282 raise Constraint_Error;
1285 Index := Container.Last + 1;
1288 Index := Before.Index;
1291 Insert (Container, Index, New_Item);
1295 (Container : in out Vector;
1298 Position : out Cursor)
1300 Index : Index_Type'Base;
1303 if Before.Container /= null
1304 and then Before.Container /= Vector_Access'(Container
'Unchecked_Access)
1306 raise Program_Error
;
1309 if Is_Empty
(New_Item
) then
1310 if Before
.Container
= null
1311 or else Before
.Index
> Container
.Last
1313 Position
:= No_Element
;
1315 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1321 if Before
.Container
= null
1322 or else Before
.Index
> Container
.Last
1324 if Container
.Last
= Index_Type
'Last then
1325 raise Constraint_Error
;
1328 Index
:= Container
.Last
+ 1;
1331 Index
:= Before
.Index
;
1334 Insert
(Container
, Index
, New_Item
);
1336 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1340 (Container : in out Vector;
1342 New_Item : Element_Type;
1343 Count : Count_Type := 1)
1345 Index : Index_Type'Base;
1348 if Before.Container /= null
1349 and then Before.Container /= Vector_Access'(Container
'Unchecked_Access)
1351 raise Program_Error
;
1358 if Before
.Container
= null
1359 or else Before
.Index
> Container
.Last
1361 if Container
.Last
= Index_Type
'Last then
1362 raise Constraint_Error
;
1365 Index
:= Container
.Last
+ 1;
1368 Index
:= Before
.Index
;
1371 Insert
(Container
, Index
, New_Item
, Count
);
1375 (Container
: in out Vector
;
1377 New_Item
: Element_Type
;
1378 Position
: out Cursor
;
1379 Count
: Count_Type
:= 1)
1381 Index
: Index_Type
'Base;
1384 if Before
.Container
/= null
1385 and then Before
.Container
/= Vector_Access
'(Container'Unchecked_Access)
1387 raise Program_Error;
1391 if Before.Container = null
1392 or else Before.Index > Container.Last
1394 Position := No_Element;
1396 Position := (Container'Unchecked_Access, Before.Index);
1402 if Before.Container = null
1403 or else Before.Index > Container.Last
1405 if Container.Last = Index_Type'Last then
1406 raise Constraint_Error;
1409 Index := Container.Last + 1;
1412 Index := Before.Index;
1415 Insert (Container, Index, New_Item, Count);
1417 Position := (Container'Unchecked_Access, Index);
1424 procedure Insert_Space
1425 (Container : in out Vector;
1426 Before : Extended_Index;
1427 Count : Count_Type := 1)
1429 N : constant Int := Int (Count);
1431 New_Last_As_Int : Int'Base;
1432 New_Last : Index_Type;
1434 Dst : Elements_Access;
1437 if Before < Index_Type'First then
1438 raise Constraint_Error;
1441 if Before > Container.Last
1442 and then Before > Container.Last + 1
1444 raise Constraint_Error;
1452 Old_Last_As_Int : constant Int := Int (Container.Last);
1455 New_Last_As_Int := Old_Last_As_Int + N;
1457 if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1458 raise Constraint_Error;
1461 New_Last := Index_Type (New_Last_As_Int);
1464 if Container.Busy > 0 then
1465 raise Program_Error;
1468 if Container.Elements = null then
1469 Container.Elements :=
1470 new Elements_Type (Index_Type'First .. New_Last);
1472 Container.Last := New_Last;
1476 if New_Last <= Container.Elements'Last then
1478 E : Elements_Type renames Container.Elements.all;
1481 if Before <= Container.Last then
1483 Index_As_Int : constant Int'Base :=
1484 Index_Type'Pos (Before) + N;
1486 Index : constant Index_Type := Index_Type (Index_As_Int);
1489 E (Index .. New_Last) := E (Before .. Container.Last);
1490 E (Before .. Index - 1) := (others => null);
1495 Container.Last := New_Last;
1500 First : constant Int := Int (Index_Type'First);
1501 New_Size : constant Int'Base := New_Last_As_Int - First + 1;
1502 Size : Int'Base := Int'Max (1, Container.Elements'Length);
1505 while Size < New_Size loop
1506 if Size > Int'Last / 2 then
1514 -- TODO: The following calculations aren't quite right, since
1515 -- there will be overflow if Index_Type'Range is very large
1516 -- (e.g. this package is instantiated with a 64-bit integer).
1520 Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
1522 if Size > Max_Size then
1528 Dst_Last : constant Index_Type := Index_Type (First + Size - 1);
1530 Dst := new Elements_Type (Index_Type'First .. Dst_Last);
1535 Src : Elements_Access := Container.Elements;
1538 if Before <= Container.Last then
1540 Index_As_Int : constant Int'Base :=
1541 Index_Type'Pos (Before) + N;
1543 Index : constant Index_Type := Index_Type (Index_As_Int);
1546 Dst (Index_Type'First .. Before - 1) :=
1547 Src (Index_Type'First .. Before - 1);
1549 Dst (Index .. New_Last) := Src (Before .. Container.Last);
1553 Dst (Index_Type'First .. Container.Last) :=
1554 Src (Index_Type'First .. Container.Last);
1557 Container.Elements := Dst;
1558 Container.Last := New_Last;
1563 procedure Insert_Space
1564 (Container : in out Vector;
1566 Position : out Cursor;
1567 Count : Count_Type := 1)
1569 Index : Index_Type'Base;
1572 if Before.Container /= null
1573 and then Before.Container /= Vector_Access'(Container
'Unchecked_Access)
1575 raise Program_Error
;
1579 if Before
.Container
= null
1580 or else Before
.Index
> Container
.Last
1582 Position
:= No_Element
;
1584 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1590 if Before
.Container
= null
1591 or else Before
.Index
> Container
.Last
1593 if Container
.Last
= Index_Type
'Last then
1594 raise Constraint_Error
;
1597 Index
:= Container
.Last
+ 1;
1600 Index
:= Before
.Index
;
1603 Insert_Space
(Container
, Index
, Count
);
1605 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1612 function Is_Empty (Container : Vector) return Boolean is
1614 return Container.Last < Index_Type'First;
1622 (Container : Vector;
1623 Process : not null access procedure (Position : in Cursor))
1625 V : Vector renames Container'Unrestricted_Access.all;
1626 B : Natural renames V.Busy;
1632 for Indx in Index_Type'First .. Container.Last loop
1633 Process (Cursor'(Container
'Unchecked_Access, Indx
));
1648 function Last
(Container
: Vector
) return Cursor
is
1650 if Is_Empty
(Container
) then
1654 return (Container
'Unchecked_Access, Container
.Last
);
1661 function Last_Element
(Container
: Vector
) return Element_Type
is
1663 return Element
(Container
, Container
.Last
);
1670 function Last_Index
(Container
: Vector
) return Extended_Index
is
1672 return Container
.Last
;
1679 function Length
(Container
: Vector
) return Count_Type
is
1680 L
: constant Int
:= Int
(Container
.Last
);
1681 F
: constant Int
:= Int
(Index_Type
'First);
1682 N
: constant Int
'Base := L
- F
+ 1;
1685 if N
> Count_Type
'Pos (Count_Type
'Last) then
1686 raise Constraint_Error
;
1689 return Count_Type
(N
);
1697 (Target
: in out Vector
;
1698 Source
: in out Vector
)
1701 if Target
'Address = Source
'Address then
1705 if Source
.Busy
> 0 then
1706 raise Program_Error
;
1712 Target_Elements
: constant Elements_Access
:= Target
.Elements
;
1714 Target
.Elements
:= Source
.Elements
;
1715 Source
.Elements
:= Target_Elements
;
1718 Target
.Last
:= Source
.Last
;
1719 Source
.Last
:= No_Index
;
1726 function Next
(Position
: Cursor
) return Cursor
is
1728 if Position
.Container
= null then
1732 if Position
.Index
< Position
.Container
.Last
then
1733 return (Position
.Container
, Position
.Index
+ 1);
1743 procedure Next
(Position
: in out Cursor
) is
1745 if Position
.Container
= null then
1749 if Position
.Index
< Position
.Container
.Last
then
1750 Position
.Index
:= Position
.Index
+ 1;
1752 Position
:= No_Element
;
1760 procedure Prepend
(Container
: in out Vector
; New_Item
: Vector
) is
1762 Insert
(Container
, Index_Type
'First, New_Item
);
1766 (Container
: in out Vector
;
1767 New_Item
: Element_Type
;
1768 Count
: Count_Type
:= 1)
1781 procedure Previous
(Position
: in out Cursor
) is
1783 if Position
.Container
= null then
1787 if Position
.Index
> Index_Type
'First then
1788 Position
.Index
:= Position
.Index
- 1;
1790 Position
:= No_Element
;
1794 function Previous
(Position
: Cursor
) return Cursor
is
1796 if Position
.Container
= null then
1800 if Position
.Index
> Index_Type
'First then
1801 return (Position
.Container
, Position
.Index
- 1);
1811 procedure Query_Element
1812 (Container
: Vector
;
1814 Process
: not null access procedure (Element
: in Element_Type
))
1816 V
: Vector
renames Container
'Unrestricted_Access.all;
1817 B
: Natural renames V
.Busy
;
1818 L
: Natural renames V
.Lock
;
1821 if Index
> Container
.Last
then
1822 raise Constraint_Error
;
1825 if V
.Elements
(Index
) = null then
1826 raise Constraint_Error
;
1833 Process
(V
.Elements
(Index
).all);
1845 procedure Query_Element
1847 Process
: not null access procedure (Element
: in Element_Type
))
1850 if Position
.Container
= null then
1851 raise Constraint_Error
;
1854 Query_Element
(Position
.Container
.all, Position
.Index
, Process
);
1862 (Stream
: access Root_Stream_Type
'Class;
1863 Container
: out Vector
)
1865 Length
: Count_Type
'Base;
1866 Last
: Index_Type
'Base := Index_Type
'Pred (Index_Type
'First);
1873 Count_Type
'Base'Read (Stream, Length);
1875 if Length > Capacity (Container) then
1876 Reserve_Capacity (Container, Capacity => Length);
1879 for J in Count_Type range 1 .. Length loop
1882 Boolean'Read (Stream, B);
1885 Container.Elements (Last) :=
1886 new Element_Type'(Element_Type
'Input (Stream
));
1889 Container
.Last
:= Last
;
1894 (Stream
: access Root_Stream_Type
'Class;
1895 Position
: out Cursor
)
1898 raise Program_Error
;
1901 ---------------------
1902 -- Replace_Element --
1903 ---------------------
1905 procedure Replace_Element
1906 (Container
: in out Vector
;
1908 New_Item
: Element_Type
)
1911 if Index
> Container
.Last
then
1912 raise Constraint_Error
;
1915 if Container
.Lock
> 0 then
1916 raise Program_Error
;
1920 X
: Element_Access
:= Container
.Elements
(Index
);
1922 Container
.Elements
(Index
) := new Element_Type
'(New_Item);
1925 end Replace_Element;
1927 procedure Replace_Element
1928 (Container : in out Vector;
1930 New_Item : Element_Type)
1933 if Position.Container = null then
1934 raise Constraint_Error;
1937 if Position.Container /= Container'Unrestricted_Access then
1938 raise Program_Error;
1941 Replace_Element (Container, Position.Index, New_Item);
1942 end Replace_Element;
1944 ----------------------
1945 -- Reserve_Capacity --
1946 ----------------------
1948 procedure Reserve_Capacity
1949 (Container : in out Vector;
1950 Capacity : Count_Type)
1952 N : constant Count_Type := Length (Container);
1955 if Capacity = 0 then
1958 X : Elements_Access := Container.Elements;
1960 Container.Elements := null;
1964 elsif N < Container.Elements'Length then
1965 if Container.Busy > 0 then
1966 raise Program_Error;
1970 subtype Array_Index_Subtype is Index_Type'Base range
1971 Index_Type'First .. Container.Last;
1973 Src : Elements_Type renames
1974 Container.Elements (Array_Index_Subtype);
1976 subtype Array_Subtype is
1977 Elements_Type (Array_Index_Subtype);
1979 X : Elements_Access := Container.Elements;
1982 Container.Elements := new Array_Subtype'(Src
);
1990 if Container
.Elements
= null then
1992 Last_As_Int
: constant Int
'Base :=
1993 Int
(Index_Type
'First) + Int
(Capacity
) - 1;
1996 if Last_As_Int
> Index_Type
'Pos (Index_Type
'Last) then
1997 raise Constraint_Error
;
2001 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
2003 subtype Array_Subtype
is
2004 Elements_Type
(Index_Type
'First .. Last
);
2007 Container
.Elements
:= new Array_Subtype
;
2014 if Capacity
<= N
then
2015 if N
< Container
.Elements
'Length then
2016 if Container
.Busy
> 0 then
2017 raise Program_Error
;
2021 subtype Array_Index_Subtype
is Index_Type
'Base range
2022 Index_Type
'First .. Container
.Last
;
2024 Src
: Elements_Type
renames
2025 Container
.Elements
(Array_Index_Subtype
);
2027 subtype Array_Subtype
is
2028 Elements_Type
(Array_Index_Subtype
);
2030 X
: Elements_Access
:= Container
.Elements
;
2033 Container
.Elements
:= new Array_Subtype
'(Src);
2041 if Capacity = Container.Elements'Length then
2045 if Container.Busy > 0 then
2046 raise Program_Error;
2050 Last_As_Int : constant Int'Base :=
2051 Int (Index_Type'First) + Int (Capacity) - 1;
2054 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2055 raise Constraint_Error;
2059 Last : constant Index_Type := Index_Type (Last_As_Int);
2061 subtype Array_Subtype is
2062 Elements_Type (Index_Type'First .. Last);
2064 X : Elements_Access := Container.Elements;
2067 Container.Elements := new Array_Subtype;
2070 Src : Elements_Type renames
2071 X (Index_Type'First .. Container.Last);
2073 Tgt : Elements_Type renames
2074 Container.Elements (Index_Type'First .. Container.Last);
2083 end Reserve_Capacity;
2085 ----------------------
2086 -- Reverse_Elements --
2087 ----------------------
2089 procedure Reverse_Elements (Container : in out Vector) is
2091 if Container.Length <= 1 then
2095 if Container.Lock > 0 then
2096 raise Program_Error;
2100 I : Index_Type := Index_Type'First;
2101 J : Index_Type := Container.Last;
2102 E : Elements_Type renames Container.Elements.all;
2107 EI : constant Element_Access := E (I);
2118 end Reverse_Elements;
2124 function Reverse_Find
2125 (Container : Vector;
2126 Item : Element_Type;
2127 Position : Cursor := No_Element) return Cursor
2129 Last : Index_Type'Base;
2132 if Position.Container /= null
2133 and then Position.Container /= Container'Unchecked_Access
2135 raise Program_Error;
2138 if Position.Container = null
2139 or else Position.Index > Container.Last
2141 Last := Container.Last;
2143 Last := Position.Index;
2146 for Indx in reverse Index_Type'First .. Last loop
2147 if Container.Elements (Indx) /= null
2148 and then Container.Elements (Indx).all = Item
2150 return (Container'Unchecked_Access, Indx);
2157 ------------------------
2158 -- Reverse_Find_Index --
2159 ------------------------
2161 function Reverse_Find_Index
2162 (Container : Vector;
2163 Item : Element_Type;
2164 Index : Index_Type := Index_Type'Last) return Extended_Index
2166 Last : Index_Type'Base;
2169 if Index > Container.Last then
2170 Last := Container.Last;
2175 for Indx in reverse Index_Type'First .. Last loop
2176 if Container.Elements (Indx) /= null
2177 and then Container.Elements (Indx).all = Item
2184 end Reverse_Find_Index;
2186 ---------------------
2187 -- Reverse_Iterate --
2188 ---------------------
2190 procedure Reverse_Iterate
2191 (Container : Vector;
2192 Process : not null access procedure (Position : in Cursor))
2194 V : Vector renames Container'Unrestricted_Access.all;
2195 B : Natural renames V.Busy;
2201 for Indx in reverse Index_Type'First .. Container.Last loop
2202 Process (Cursor'(Container
'Unchecked_Access, Indx
));
2211 end Reverse_Iterate
;
2217 procedure Set_Length
2218 (Container
: in out Vector
;
2219 Length
: Count_Type
)
2221 N
: constant Count_Type
:= Indefinite_Vectors
.Length
(Container
);
2228 if Container
.Busy
> 0 then
2229 raise Program_Error
;
2233 for Index
in 1 .. N
- Length
loop
2235 J
: constant Index_Type
:= Container
.Last
;
2236 X
: Element_Access
:= Container
.Elements
(J
);
2239 Container
.Elements
(J
) := null;
2240 Container
.Last
:= J
- 1;
2248 if Length
> Capacity
(Container
) then
2249 Reserve_Capacity
(Container
, Capacity
=> Length
);
2253 Last_As_Int
: constant Int
'Base :=
2254 Int
(Index_Type
'First) + Int
(Length
) - 1;
2257 Container
.Last
:= Index_Type
(Last_As_Int
);
2266 (Container
: in out Vector
;
2270 if I
> Container
.Last
2271 or else J
> Container
.Last
2273 raise Constraint_Error
;
2280 if Container
.Lock
> 0 then
2281 raise Program_Error
;
2285 EI
: Element_Access
renames Container
.Elements
(I
);
2286 EJ
: Element_Access
renames Container
.Elements
(J
);
2288 EI_Copy
: constant Element_Access
:= EI
;
2297 (Container
: in out Vector
;
2301 if I
.Container
= null
2302 or else J
.Container
= null
2304 raise Constraint_Error
;
2307 if I
.Container
/= Container
'Unrestricted_Access
2308 or else J
.Container
/= Container
'Unrestricted_Access
2310 raise Program_Error
;
2313 Swap
(Container
, I
.Index
, J
.Index
);
2321 (Container
: Vector
;
2322 Index
: Extended_Index
) return Cursor
2325 if Index
not in Index_Type
'First .. Container
.Last
then
2329 return Cursor
'(Container'Unchecked_Access, Index);
2336 function To_Index (Position : Cursor) return Extended_Index is
2338 if Position.Container = null then
2342 if Position.Index <= Position.Container.Last then
2343 return Position.Index;
2353 function To_Vector (Length : Count_Type) return Vector is
2356 return Empty_Vector;
2360 First : constant Int := Int (Index_Type'First);
2361 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2363 Elements : Elements_Access;
2366 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2367 raise Constraint_Error;
2370 Last := Index_Type (Last_As_Int);
2371 Elements := new Elements_Type (Index_Type'First .. Last);
2373 return (Controlled with Elements, Last, 0, 0);
2378 (New_Item : Element_Type;
2379 Length : Count_Type) return Vector
2383 return Empty_Vector;
2387 First : constant Int := Int (Index_Type'First);
2388 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2389 Last : Index_Type'Base;
2390 Elements : Elements_Access;
2393 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2394 raise Constraint_Error;
2397 Last := Index_Type (Last_As_Int);
2398 Elements := new Elements_Type (Index_Type'First .. Last);
2400 Last := Index_Type'First;
2404 Elements (Last) := new Element_Type'(New_Item
);
2405 exit when Last
= Elements
'Last;
2410 for J
in Index_Type
'First .. Last
- 1 loop
2411 Free
(Elements
(J
));
2418 return (Controlled
with Elements
, Last
, 0, 0);
2422 --------------------
2423 -- Update_Element --
2424 --------------------
2426 procedure Update_Element
2427 (Container
: in out Vector
;
2429 Process
: not null access procedure (Element
: in out Element_Type
))
2431 B
: Natural renames Container
.Busy
;
2432 L
: Natural renames Container
.Lock
;
2435 if Index
> Container
.Last
then
2436 raise Constraint_Error
;
2439 if Container
.Elements
(Index
) = null then
2440 raise Constraint_Error
;
2447 Process
(Container
.Elements
(Index
).all);
2459 procedure Update_Element
2460 (Container
: in out Vector
;
2462 Process
: not null access procedure (Element
: in out Element_Type
))
2465 if Position
.Container
= null then
2466 raise Constraint_Error
;
2469 if Position
.Container
/= Container
'Unrestricted_Access then
2470 raise Program_Error
;
2473 Update_Element
(Container
, Position
.Index
, Process
);
2481 (Stream
: access Root_Stream_Type
'Class;
2484 N
: constant Count_Type
:= Length
(Container
);
2487 Count_Type
'Base'Write (Stream, N);
2494 E : Elements_Type renames Container.Elements.all;
2497 for Indx in Index_Type'First .. Container.Last loop
2499 -- There's another way to do this. Instead a separate
2500 -- Boolean for each element, you could write a Boolean
2501 -- followed by a count of how many nulls or non-nulls
2502 -- follow in the array.
2504 if E (Indx) = null then
2505 Boolean'Write (Stream, False);
2507 Boolean'Write (Stream, True);
2508 Element_Type'Output (Stream, E (Indx).all);
2515 (Stream : access Root_Stream_Type'Class;
2519 raise Program_Error;
2522 end Ada.Containers.Indefinite_Vectors;