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-2006, Free Software Foundation, Inc. --
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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- This unit has originally being developed by Matthew J Heaney. --
30 ------------------------------------------------------------------------------
32 with Ada
.Containers
.Generic_Array_Sort
;
33 with Ada
.Unchecked_Deallocation
;
34 with System
; use type System
.Address
;
36 package body Ada
.Containers
.Indefinite_Vectors
is
38 type Int
is range System
.Min_Int
.. System
.Max_Int
;
39 type UInt
is mod System
.Max_Binary_Modulus
;
42 new Ada
.Unchecked_Deallocation
(Elements_Type
, Elements_Access
);
45 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
51 function "&" (Left
, Right
: Vector
) return Vector
is
52 LN
: constant Count_Type
:= Length
(Left
);
53 RN
: constant Count_Type
:= Length
(Right
);
62 RE
: Elements_Type
renames
63 Right
.Elements
(Index_Type
'First .. Right
.Last
);
65 Elements
: Elements_Access
:=
66 new Elements_Type
(RE
'Range);
69 for I
in Elements
'Range loop
71 if RE
(I
) /= null then
72 Elements
(I
) := new Element_Type
'(RE (I).all);
76 for J in Index_Type'First .. I - 1 loop
85 return (Controlled with Elements, Right.Last, 0, 0);
92 LE : Elements_Type renames
93 Left.Elements (Index_Type'First .. Left.Last);
95 Elements : Elements_Access :=
96 new Elements_Type (LE'Range);
99 for I in Elements'Range loop
101 if LE (I) /= null then
102 Elements (I) := new Element_Type'(LE
(I
).all);
106 for J
in Index_Type
'First .. I
- 1 loop
115 return (Controlled
with Elements
, Left
.Last
, 0, 0);
120 N
: constant Int
'Base := Int
(LN
) + Int
(RN
);
121 Last_As_Int
: Int
'Base;
124 if Int
(No_Index
) > Int
'Last - N
then
125 raise Constraint_Error
with "new length is out of range";
128 Last_As_Int
:= Int
(No_Index
) + N
;
130 if Last_As_Int
> Int
(Index_Type
'Last) then
131 raise Constraint_Error
with "new length is out of range";
135 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
137 LE
: Elements_Type
renames
138 Left
.Elements
(Index_Type
'First .. Left
.Last
);
140 RE
: Elements_Type
renames
141 Right
.Elements
(Index_Type
'First .. Right
.Last
);
143 Elements
: Elements_Access
:=
144 new Elements_Type
(Index_Type
'First .. Last
);
146 I
: Index_Type
'Base := No_Index
;
149 for LI
in LE
'Range loop
153 if LE
(LI
) /= null then
154 Elements
(I
) := new Element_Type
'(LE (LI).all);
158 for J in Index_Type'First .. I - 1 loop
167 for RI in RE'Range loop
171 if RE (RI) /= null then
172 Elements (I) := new Element_Type'(RE
(RI
).all);
176 for J
in Index_Type
'First .. I
- 1 loop
185 return (Controlled
with Elements
, Last
, 0, 0);
190 function "&" (Left
: Vector
; Right
: Element_Type
) return Vector
is
191 LN
: constant Count_Type
:= Length
(Left
);
196 subtype Elements_Subtype
is
197 Elements_Type
(Index_Type
'First .. Index_Type
'First);
199 Elements
: Elements_Access
:= new Elements_Subtype
;
203 Elements
(Elements
'First) := new Element_Type
'(Right);
210 return (Controlled with Elements, Index_Type'First, 0, 0);
215 Last_As_Int : Int'Base;
218 if Int (Index_Type'First) > Int'Last - Int (LN) then
219 raise Constraint_Error with "new length is out of range";
222 Last_As_Int := Int (Index_Type'First) + Int (LN);
224 if Last_As_Int > Int (Index_Type'Last) then
225 raise Constraint_Error with "new length is out of range";
229 Last : constant Index_Type := Index_Type (Last_As_Int);
231 LE : Elements_Type renames
232 Left.Elements (Index_Type'First .. Left.Last);
234 Elements : Elements_Access :=
235 new Elements_Type (Index_Type'First .. Last);
238 for I in LE'Range loop
240 if LE (I) /= null then
241 Elements (I) := new Element_Type'(LE
(I
).all);
245 for J
in Index_Type
'First .. I
- 1 loop
255 Elements
(Elements
'Last) := new Element_Type
'(Right);
258 for J in Index_Type'First .. Elements'Last - 1 loop
266 return (Controlled with Elements, Last, 0, 0);
271 function "&" (Left : Element_Type; Right : Vector) return Vector is
272 RN : constant Count_Type := Length (Right);
277 subtype Elements_Subtype is
278 Elements_Type (Index_Type'First .. Index_Type'First);
280 Elements : Elements_Access := new Elements_Subtype;
284 Elements (Elements'First) := new Element_Type'(Left
);
291 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
296 Last_As_Int
: Int
'Base;
299 if Int
(Index_Type
'First) > Int
'Last - Int
(RN
) then
300 raise Constraint_Error
with "new length is out of range";
303 Last_As_Int
:= Int
(Index_Type
'First) + Int
(RN
);
305 if Last_As_Int
> Int
(Index_Type
'Last) then
306 raise Constraint_Error
with "new length is out of range";
310 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
312 RE
: Elements_Type
renames
313 Right
.Elements
(Index_Type
'First .. Right
.Last
);
315 Elements
: Elements_Access
:=
316 new Elements_Type
(Index_Type
'First .. Last
);
318 I
: Index_Type
'Base := Index_Type
'First;
322 Elements
(I
) := new Element_Type
'(Left);
329 for RI in RE'Range loop
333 if RE (RI) /= null then
334 Elements (I) := new Element_Type'(RE
(RI
).all);
338 for J
in Index_Type
'First .. I
- 1 loop
347 return (Controlled
with Elements
, Last
, 0, 0);
352 function "&" (Left
, Right
: Element_Type
) return Vector
is
354 if Index_Type
'First >= Index_Type
'Last then
355 raise Constraint_Error
with "new length is out of range";
359 Last
: constant Index_Type
:= Index_Type
'First + 1;
361 subtype ET
is Elements_Type
(Index_Type
'First .. Last
);
363 Elements
: Elements_Access
:= new ET
;
367 Elements
(Elements
'First) := new Element_Type
'(Left);
375 Elements (Elements'Last) := new Element_Type'(Right
);
378 Free
(Elements
(Elements
'First));
383 return (Controlled
with Elements
, Elements
'Last, 0, 0);
391 function "=" (Left
, Right
: Vector
) return Boolean is
393 if Left
'Address = Right
'Address then
397 if Left
.Last
/= Right
.Last
then
401 for J
in Index_Type
'First .. Left
.Last
loop
402 if Left
.Elements
(J
) = null then
403 if Right
.Elements
(J
) /= null then
407 elsif Right
.Elements
(J
) = null then
410 elsif Left
.Elements
(J
).all /= Right
.Elements
(J
).all then
422 procedure Adjust
(Container
: in out Vector
) is
424 if Container
.Last
= No_Index
then
425 Container
.Elements
:= null;
430 E
: Elements_Type
renames Container
.Elements
.all;
431 L
: constant Index_Type
:= Container
.Last
;
434 Container
.Elements
:= null;
435 Container
.Last
:= No_Index
;
439 Container
.Elements
:= new Elements_Type
(Index_Type
'First .. L
);
441 for I
in Container
.Elements
'Range loop
442 if E
(I
) /= null then
443 Container
.Elements
(I
) := new Element_Type
'(E (I).all);
455 procedure Append (Container : in out Vector; New_Item : Vector) is
457 if Is_Empty (New_Item) then
461 if Container.Last = Index_Type'Last then
462 raise Constraint_Error with "vector is already at its maximum length";
472 (Container : in out Vector;
473 New_Item : Element_Type;
474 Count : Count_Type := 1)
481 if Container.Last = Index_Type'Last then
482 raise Constraint_Error with "vector is already at its maximum length";
496 function Capacity (Container : Vector) return Count_Type is
498 if Container.Elements = null then
502 return Container.Elements'Length;
509 procedure Clear (Container : in out Vector) is
511 if Container.Busy > 0 then
512 raise Program_Error with
513 "attempt to tamper with elements (vector is busy)";
516 while Container.Last >= Index_Type'First loop
518 X : Element_Access := Container.Elements (Container.Last);
520 Container.Elements (Container.Last) := null;
521 Container.Last := Container.Last - 1;
533 Item : Element_Type) return Boolean
536 return Find_Index (Container, Item) /= No_Index;
544 (Container : in out Vector;
545 Index : Extended_Index;
546 Count : Count_Type := 1)
549 if Index < Index_Type'First then
550 raise Constraint_Error with "Index is out of range (too small)";
553 if Index > Container.Last then
554 if Index > Container.Last + 1 then
555 raise Constraint_Error with "Index is out of range (too large)";
565 if Container.Busy > 0 then
566 raise Program_Error with
567 "attempt to tamper with elements (vector is busy)";
571 Index_As_Int : constant Int := Int (Index);
572 Old_Last_As_Int : constant Int := Int (Container.Last);
574 Count1 : constant Int'Base := Int (Count);
575 Count2 : constant Int'Base := Old_Last_As_Int - Index_As_Int + 1;
576 N : constant Int'Base := Int'Min (Count1, Count2);
578 J_As_Int : constant Int'Base := Index_As_Int + N;
579 E : Elements_Type renames Container.Elements.all;
582 if J_As_Int > Old_Last_As_Int then
583 while Container.Last >= Index loop
585 K : constant Index_Type := Container.Last;
586 X : Element_Access := E (K);
590 Container.Last := K - 1;
597 J : constant Index_Type := Index_Type (J_As_Int);
599 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
600 New_Last : constant Index_Type :=
601 Index_Type (New_Last_As_Int);
604 for K in Index .. J - 1 loop
606 X : Element_Access := E (K);
613 E (Index .. New_Last) := E (J .. Container.Last);
614 Container.Last := New_Last;
621 (Container : in out Vector;
622 Position : in out Cursor;
623 Count : Count_Type := 1)
626 if Position.Container = null then
627 raise Constraint_Error with "Position cursor has no element";
630 if Position.Container /= Container'Unrestricted_Access then
631 raise Program_Error with "Position cursor denotes wrong container";
634 if Position.Index > Container.Last then
635 raise Program_Error with "Position index is out of range";
638 Delete (Container, Position.Index, Count);
640 Position := No_Element; -- See comment in a-convec.adb
647 procedure Delete_First
648 (Container : in out Vector;
649 Count : Count_Type := 1)
656 if Count >= Length (Container) then
661 Delete (Container, Index_Type'First, Count);
668 procedure Delete_Last
669 (Container : in out Vector;
670 Count : Count_Type := 1)
672 N : constant Count_Type := Length (Container);
681 if Container.Busy > 0 then
682 raise Program_Error with
683 "attempt to tamper with elements (vector is busy)";
687 E : Elements_Type renames Container.Elements.all;
690 for Indx in 1 .. Count_Type'Min (Count, N) loop
692 J : constant Index_Type := Container.Last;
693 X : Element_Access := E (J);
697 Container.Last := J - 1;
710 Index : Index_Type) return Element_Type
713 if Index > Container.Last then
714 raise Constraint_Error with "Index is out of range";
718 EA : constant Element_Access := Container.Elements (Index);
722 raise Constraint_Error with "element is empty";
729 function Element (Position : Cursor) return Element_Type is
731 if Position.Container = null then
732 raise Constraint_Error with "Position cursor has no element";
735 return Element (Position.Container.all, Position.Index);
742 procedure Finalize (Container : in out Vector) is
744 Clear (Container); -- Checks busy-bit
747 X : Elements_Access := Container.Elements;
749 Container.Elements := null;
761 Position : Cursor := No_Element) return Cursor
764 if Position.Container /= null then
765 if Position.Container /= Container'Unrestricted_Access then
766 raise Program_Error with "Position cursor denotes wrong container";
769 if Position.Index > Container.Last then
770 raise Program_Error with "Position index is out of range";
774 for J in Position.Index .. Container.Last loop
775 if Container.Elements (J) /= null
776 and then Container.Elements (J).all = Item
778 return (Container'Unchecked_Access, J);
792 Index : Index_Type := Index_Type'First) return Extended_Index
795 for Indx in Index .. Container.Last loop
796 if Container.Elements (Indx) /= null
797 and then Container.Elements (Indx).all = Item
810 function First (Container : Vector) return Cursor is
812 if Is_Empty (Container) then
816 return (Container'Unchecked_Access, Index_Type'First);
823 function First_Element (Container : Vector) return Element_Type is
825 return Element (Container, Index_Type'First);
832 function First_Index (Container : Vector) return Index_Type is
833 pragma Unreferenced (Container);
835 return Index_Type'First;
838 ---------------------
839 -- Generic_Sorting --
840 ---------------------
842 package body Generic_Sorting is
844 -----------------------
845 -- Local Subprograms --
846 -----------------------
848 function Is_Less (L, R : Element_Access) return Boolean;
849 pragma Inline (Is_Less);
855 function Is_Less (L, R : Element_Access) return Boolean is
862 return L.all < R.all;
870 function Is_Sorted (Container : Vector) return Boolean is
872 if Container.Last <= Index_Type'First then
877 E : Elements_Type renames Container.Elements.all;
879 for I in Index_Type'First .. Container.Last - 1 loop
880 if Is_Less (E (I + 1), E (I)) then
893 procedure Merge (Target, Source : in out Vector) is
894 I : Index_Type'Base := Target.Last;
898 if Target.Last < Index_Type'First then
899 Move (Target => Target, Source => Source);
903 if Target'Address = Source'Address then
907 if Source.Last < Index_Type'First then
911 if Source.Busy > 0 then
912 raise Program_Error with
913 "attempt to tamper with elements (vector is busy)";
916 Target.Set_Length (Length (Target) + Length (Source));
919 while Source.Last >= Index_Type'First loop
921 (Source.Last <= Index_Type'First
923 (Source.Elements (Source.Last),
924 Source.Elements (Source.Last - 1))));
926 if I < Index_Type'First then
928 Src : Elements_Type renames
929 Source.Elements (Index_Type'First .. Source.Last);
932 Target.Elements (Index_Type'First .. J) := Src;
933 Src := (others => null);
936 Source.Last := No_Index;
941 (I <= Index_Type'First
943 (Target.Elements (I),
944 Target.Elements (I - 1))));
947 Src : Element_Access renames Source.Elements (Source.Last);
948 Tgt : Element_Access renames Target.Elements (I);
951 if Is_Less (Src, Tgt) then
952 Target.Elements (J) := Tgt;
957 Target.Elements (J) := Src;
959 Source.Last := Source.Last - 1;
971 procedure Sort (Container : in out Vector)
974 new Generic_Array_Sort
975 (Index_Type => Index_Type,
976 Element_Type => Element_Access,
977 Array_Type => Elements_Type,
980 -- Start of processing for Sort
983 if Container.Last <= Index_Type'First then
987 if Container.Lock > 0 then
988 raise Program_Error with
989 "attempt to tamper with cursors (vector is locked)";
992 Sort (Container.Elements (Index_Type'First .. Container.Last));
1001 function Has_Element (Position : Cursor) return Boolean is
1003 if Position.Container = null then
1007 return Position.Index <= Position.Container.Last;
1015 (Container : in out Vector;
1016 Before : Extended_Index;
1017 New_Item : Element_Type;
1018 Count : Count_Type := 1)
1020 N : constant Int := Int (Count);
1022 First : constant Int := Int (Index_Type'First);
1023 New_Last_As_Int : Int'Base;
1024 New_Last : Index_Type;
1026 Max_Length : constant UInt := UInt (Count_Type'Last);
1028 Dst : Elements_Access;
1031 if Before < Index_Type'First then
1032 raise Constraint_Error with
1033 "Before index is out of range (too small)";
1036 if Before > Container.Last
1037 and then Before > Container.Last + 1
1039 raise Constraint_Error with
1040 "Before index is out of range (too large)";
1048 Old_Last_As_Int : constant Int := Int (Container.Last);
1051 if Old_Last_As_Int > Int'Last - N then
1052 raise Constraint_Error with "new length is out of range";
1055 New_Last_As_Int := Old_Last_As_Int + N;
1057 if New_Last_As_Int > Int (Index_Type'Last) then
1058 raise Constraint_Error with "new length is out of range";
1061 New_Length := UInt (New_Last_As_Int - First + 1);
1063 if New_Length > Max_Length then
1064 raise Constraint_Error with "new length is out of range";
1067 New_Last := Index_Type (New_Last_As_Int);
1070 if Container.Busy > 0 then
1071 raise Program_Error with
1072 "attempt to tamper with elements (vector is busy)";
1075 if Container.Elements = null then
1076 Container.Elements :=
1077 new Elements_Type (Index_Type'First .. New_Last);
1079 Container.Last := No_Index;
1081 for J in Container.Elements'Range loop
1082 Container.Elements (J) := new Element_Type'(New_Item
);
1083 Container
.Last
:= J
;
1089 if New_Last
<= Container
.Elements
'Last then
1091 E
: Elements_Type
renames Container
.Elements
.all;
1094 if Before
<= Container
.Last
then
1096 Index_As_Int
: constant Int
'Base :=
1097 Index_Type
'Pos (Before
) + N
;
1099 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1101 J
: Index_Type
'Base;
1104 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
1105 Container
.Last
:= New_Last
;
1108 while J
< Index
loop
1109 E
(J
) := new Element_Type
'(New_Item);
1115 E (J .. Index - 1) := (others => null);
1120 for J in Before .. New_Last loop
1121 E (J) := new Element_Type'(New_Item
);
1122 Container
.Last
:= J
;
1134 C
:= UInt
'Max (1, Container
.Elements
'Length);
1135 while C
< New_Length
loop
1136 if C
> UInt
'Last / 2 then
1144 if C
> Max_Length
then
1148 if Index_Type
'First <= 0
1149 and then Index_Type
'Last >= 0
1151 CC
:= UInt
(Index_Type
'Last) + UInt
(-Index_Type
'First) + 1;
1154 CC
:= UInt
(Int
(Index_Type
'Last) - First
+ 1);
1162 Dst_Last
: constant Index_Type
:=
1163 Index_Type
(First
+ UInt
'Pos (C
) - Int
'(1));
1166 Dst := new Elements_Type (Index_Type'First .. Dst_Last);
1170 if Before <= Container.Last then
1172 Index_As_Int : constant Int'Base :=
1173 Index_Type'Pos (Before) + N;
1175 Index : constant Index_Type := Index_Type (Index_As_Int);
1177 Src : Elements_Access := Container.Elements;
1180 Dst (Index_Type'First .. Before - 1) :=
1181 Src (Index_Type'First .. Before - 1);
1183 Dst (Index .. New_Last) := Src (Before .. Container.Last);
1185 Container.Elements := Dst;
1186 Container.Last := New_Last;
1189 for J in Before .. Index - 1 loop
1190 Dst (J) := new Element_Type'(New_Item
);
1196 Src
: Elements_Access
:= Container
.Elements
;
1199 Dst
(Index_Type
'First .. Container
.Last
) :=
1200 Src
(Index_Type
'First .. Container
.Last
);
1202 Container
.Elements
:= Dst
;
1205 for J
in Before
.. New_Last
loop
1206 Dst
(J
) := new Element_Type
'(New_Item);
1207 Container.Last := J;
1214 (Container : in out Vector;
1215 Before : Extended_Index;
1218 N : constant Count_Type := Length (New_Item);
1221 if Before < Index_Type'First then
1222 raise Constraint_Error with
1223 "Before index is out of range (too small)";
1226 if Before > Container.Last
1227 and then Before > Container.Last + 1
1229 raise Constraint_Error with
1230 "Before index is out of range (too large)";
1237 Insert_Space (Container, Before, Count => N);
1240 Dst_Last_As_Int : constant Int'Base :=
1241 Int'Base (Before) + Int'Base (N) - 1;
1243 Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
1245 Dst : Elements_Type renames
1246 Container.Elements (Before .. Dst_Last);
1248 Dst_Index : Index_Type'Base := Before - 1;
1251 if Container'Address /= New_Item'Address then
1253 Src : Elements_Type renames
1254 New_Item.Elements (Index_Type'First .. New_Item.Last);
1257 for Src_Index in Src'Range loop
1258 Dst_Index := Dst_Index + 1;
1260 if Src (Src_Index) /= null then
1261 Dst (Dst_Index) := new Element_Type'(Src
(Src_Index
).all);
1270 subtype Src_Index_Subtype
is Index_Type
'Base range
1271 Index_Type
'First .. Before
- 1;
1273 Src
: Elements_Type
renames
1274 Container
.Elements
(Src_Index_Subtype
);
1277 for Src_Index
in Src
'Range loop
1278 Dst_Index
:= Dst_Index
+ 1;
1280 if Src
(Src_Index
) /= null then
1281 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
1286 if Dst_Last = Container.Last then
1291 subtype Src_Index_Subtype is Index_Type'Base range
1292 Dst_Last + 1 .. Container.Last;
1294 Src : Elements_Type renames
1295 Container.Elements (Src_Index_Subtype);
1298 for Src_Index in Src'Range loop
1299 Dst_Index := Dst_Index + 1;
1301 if Src (Src_Index) /= null then
1302 Dst (Dst_Index) := new Element_Type'(Src
(Src_Index
).all);
1310 (Container
: in out Vector
;
1314 Index
: Index_Type
'Base;
1317 if Before
.Container
/= null
1318 and then Before
.Container
/= Container
'Unchecked_Access
1320 raise Program_Error
with "Before cursor denotes wrong container";
1323 if Is_Empty
(New_Item
) then
1327 if Before
.Container
= null
1328 or else Before
.Index
> Container
.Last
1330 if Container
.Last
= Index_Type
'Last then
1331 raise Constraint_Error
with
1332 "vector is already at its maximum length";
1335 Index
:= Container
.Last
+ 1;
1338 Index
:= Before
.Index
;
1341 Insert
(Container
, Index
, New_Item
);
1345 (Container
: in out Vector
;
1348 Position
: out Cursor
)
1350 Index
: Index_Type
'Base;
1353 if Before
.Container
/= null
1354 and then Before
.Container
/= Vector_Access
'(Container'Unchecked_Access)
1356 raise Program_Error with "Before cursor denotes wrong container";
1359 if Is_Empty (New_Item) then
1360 if Before.Container = null
1361 or else Before.Index > Container.Last
1363 Position := No_Element;
1365 Position := (Container'Unchecked_Access, Before.Index);
1371 if Before.Container = null
1372 or else Before.Index > Container.Last
1374 if Container.Last = Index_Type'Last then
1375 raise Constraint_Error with
1376 "vector is already at its maximum length";
1379 Index := Container.Last + 1;
1382 Index := Before.Index;
1385 Insert (Container, Index, New_Item);
1387 Position := Cursor'(Container
'Unchecked_Access, Index
);
1391 (Container
: in out Vector
;
1393 New_Item
: Element_Type
;
1394 Count
: Count_Type
:= 1)
1396 Index
: Index_Type
'Base;
1399 if Before
.Container
/= null
1400 and then Before
.Container
/= Container
'Unchecked_Access
1402 raise Program_Error
with "Before cursor denotes wrong container";
1409 if Before
.Container
= null
1410 or else Before
.Index
> Container
.Last
1412 if Container
.Last
= Index_Type
'Last then
1413 raise Constraint_Error
with
1414 "vector is already at its maximum length";
1417 Index
:= Container
.Last
+ 1;
1420 Index
:= Before
.Index
;
1423 Insert
(Container
, Index
, New_Item
, Count
);
1427 (Container
: in out Vector
;
1429 New_Item
: Element_Type
;
1430 Position
: out Cursor
;
1431 Count
: Count_Type
:= 1)
1433 Index
: Index_Type
'Base;
1436 if Before
.Container
/= null
1437 and then Before
.Container
/= Container
'Unchecked_Access
1439 raise Program_Error
with "Before cursor denotes wrong container";
1443 if Before
.Container
= null
1444 or else Before
.Index
> Container
.Last
1446 Position
:= No_Element
;
1448 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1454 if Before
.Container
= null
1455 or else Before
.Index
> Container
.Last
1457 if Container
.Last
= Index_Type
'Last then
1458 raise Constraint_Error
with
1459 "vector is already at its maximum length";
1462 Index
:= Container
.Last
+ 1;
1465 Index
:= Before
.Index
;
1468 Insert
(Container
, Index
, New_Item
, Count
);
1470 Position
:= (Container
'Unchecked_Access, Index
);
1477 procedure Insert_Space
1478 (Container
: in out Vector
;
1479 Before
: Extended_Index
;
1480 Count
: Count_Type
:= 1)
1482 N
: constant Int
:= Int
(Count
);
1484 First
: constant Int
:= Int
(Index_Type
'First);
1485 New_Last_As_Int
: Int
'Base;
1486 New_Last
: Index_Type
;
1488 Max_Length
: constant UInt
:= UInt
(Count_Type
'Last);
1490 Dst
: Elements_Access
;
1493 if Before
< Index_Type
'First then
1494 raise Constraint_Error
with
1495 "Before index is out of range (too small)";
1498 if Before
> Container
.Last
1499 and then Before
> Container
.Last
+ 1
1501 raise Constraint_Error
with
1502 "Before index is out of range (too large)";
1510 Old_Last_As_Int
: constant Int
:= Int
(Container
.Last
);
1513 if Old_Last_As_Int
> Int
'Last - N
then
1514 raise Constraint_Error
with "new length is out of range";
1517 New_Last_As_Int
:= Old_Last_As_Int
+ N
;
1519 if New_Last_As_Int
> Int
(Index_Type
'Last) then
1520 raise Constraint_Error
with "new length is out of range";
1523 New_Length
:= UInt
(New_Last_As_Int
- First
+ 1);
1525 if New_Length
> Max_Length
then
1526 raise Constraint_Error
with "new length is out of range";
1529 New_Last
:= Index_Type
(New_Last_As_Int
);
1532 if Container
.Busy
> 0 then
1533 raise Program_Error
with
1534 "attempt to tamper with elements (vector is busy)";
1537 if Container
.Elements
= null then
1538 Container
.Elements
:=
1539 new Elements_Type
(Index_Type
'First .. New_Last
);
1541 Container
.Last
:= New_Last
;
1545 if New_Last
<= Container
.Elements
'Last then
1547 E
: Elements_Type
renames Container
.Elements
.all;
1550 if Before
<= Container
.Last
then
1552 Index_As_Int
: constant Int
'Base :=
1553 Index_Type
'Pos (Before
) + N
;
1555 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1558 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
1559 E
(Before
.. Index
- 1) := (others => null);
1564 Container
.Last
:= New_Last
;
1572 C
:= UInt
'Max (1, Container
.Elements
'Length);
1573 while C
< New_Length
loop
1574 if C
> UInt
'Last / 2 then
1582 if C
> Max_Length
then
1586 if Index_Type
'First <= 0
1587 and then Index_Type
'Last >= 0
1589 CC
:= UInt
(Index_Type
'Last) + UInt
(-Index_Type
'First) + 1;
1592 CC
:= UInt
(Int
(Index_Type
'Last) - First
+ 1);
1600 Dst_Last
: constant Index_Type
:=
1601 Index_Type
(First
+ UInt
'Pos (C
) - 1);
1604 Dst
:= new Elements_Type
(Index_Type
'First .. Dst_Last
);
1609 Src
: Elements_Access
:= Container
.Elements
;
1612 if Before
<= Container
.Last
then
1614 Index_As_Int
: constant Int
'Base :=
1615 Index_Type
'Pos (Before
) + N
;
1617 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1620 Dst
(Index_Type
'First .. Before
- 1) :=
1621 Src
(Index_Type
'First .. Before
- 1);
1623 Dst
(Index
.. New_Last
) := Src
(Before
.. Container
.Last
);
1627 Dst
(Index_Type
'First .. Container
.Last
) :=
1628 Src
(Index_Type
'First .. Container
.Last
);
1631 Container
.Elements
:= Dst
;
1632 Container
.Last
:= New_Last
;
1637 procedure Insert_Space
1638 (Container
: in out Vector
;
1640 Position
: out Cursor
;
1641 Count
: Count_Type
:= 1)
1643 Index
: Index_Type
'Base;
1646 if Before
.Container
/= null
1647 and then Before
.Container
/= Container
'Unchecked_Access
1649 raise Program_Error
with "Before cursor denotes wrong container";
1653 if Before
.Container
= null
1654 or else Before
.Index
> Container
.Last
1656 Position
:= No_Element
;
1658 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1664 if Before
.Container
= null
1665 or else Before
.Index
> Container
.Last
1667 if Container
.Last
= Index_Type
'Last then
1668 raise Constraint_Error
with
1669 "vector is already at its maximum length";
1672 Index
:= Container
.Last
+ 1;
1675 Index
:= Before
.Index
;
1678 Insert_Space
(Container
, Index
, Count
);
1680 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1687 function Is_Empty (Container : Vector) return Boolean is
1689 return Container.Last < Index_Type'First;
1697 (Container : Vector;
1698 Process : not null access procedure (Position : Cursor))
1700 V : Vector renames Container'Unrestricted_Access.all;
1701 B : Natural renames V.Busy;
1707 for Indx in Index_Type'First .. Container.Last loop
1708 Process (Cursor'(Container
'Unchecked_Access, Indx
));
1723 function Last
(Container
: Vector
) return Cursor
is
1725 if Is_Empty
(Container
) then
1729 return (Container
'Unchecked_Access, Container
.Last
);
1736 function Last_Element
(Container
: Vector
) return Element_Type
is
1738 return Element
(Container
, Container
.Last
);
1745 function Last_Index
(Container
: Vector
) return Extended_Index
is
1747 return Container
.Last
;
1754 function Length
(Container
: Vector
) return Count_Type
is
1755 L
: constant Int
:= Int
(Container
.Last
);
1756 F
: constant Int
:= Int
(Index_Type
'First);
1757 N
: constant Int
'Base := L
- F
+ 1;
1760 return Count_Type
(N
);
1768 (Target
: in out Vector
;
1769 Source
: in out Vector
)
1772 if Target
'Address = Source
'Address then
1776 if Source
.Busy
> 0 then
1777 raise Program_Error
with
1778 "attempt to tamper with elements (Source is busy)";
1781 Clear
(Target
); -- Checks busy-bit
1784 Target_Elements
: constant Elements_Access
:= Target
.Elements
;
1786 Target
.Elements
:= Source
.Elements
;
1787 Source
.Elements
:= Target_Elements
;
1790 Target
.Last
:= Source
.Last
;
1791 Source
.Last
:= No_Index
;
1798 function Next
(Position
: Cursor
) return Cursor
is
1800 if Position
.Container
= null then
1804 if Position
.Index
< Position
.Container
.Last
then
1805 return (Position
.Container
, Position
.Index
+ 1);
1815 procedure Next
(Position
: in out Cursor
) is
1817 if Position
.Container
= null then
1821 if Position
.Index
< Position
.Container
.Last
then
1822 Position
.Index
:= Position
.Index
+ 1;
1824 Position
:= No_Element
;
1832 procedure Prepend
(Container
: in out Vector
; New_Item
: Vector
) is
1834 Insert
(Container
, Index_Type
'First, New_Item
);
1838 (Container
: in out Vector
;
1839 New_Item
: Element_Type
;
1840 Count
: Count_Type
:= 1)
1853 procedure Previous
(Position
: in out Cursor
) is
1855 if Position
.Container
= null then
1859 if Position
.Index
> Index_Type
'First then
1860 Position
.Index
:= Position
.Index
- 1;
1862 Position
:= No_Element
;
1866 function Previous
(Position
: Cursor
) return Cursor
is
1868 if Position
.Container
= null then
1872 if Position
.Index
> Index_Type
'First then
1873 return (Position
.Container
, Position
.Index
- 1);
1883 procedure Query_Element
1884 (Container
: Vector
;
1886 Process
: not null access procedure (Element
: Element_Type
))
1888 V
: Vector
renames Container
'Unrestricted_Access.all;
1889 B
: Natural renames V
.Busy
;
1890 L
: Natural renames V
.Lock
;
1893 if Index
> Container
.Last
then
1894 raise Constraint_Error
with "Index is out of range";
1897 if V
.Elements
(Index
) = null then
1898 raise Constraint_Error
with "element is null";
1905 Process
(V
.Elements
(Index
).all);
1917 procedure Query_Element
1919 Process
: not null access procedure (Element
: Element_Type
))
1922 if Position
.Container
= null then
1923 raise Constraint_Error
with "Position cursor has no element";
1926 Query_Element
(Position
.Container
.all, Position
.Index
, Process
);
1934 (Stream
: not null access Root_Stream_Type
'Class;
1935 Container
: out Vector
)
1937 Length
: Count_Type
'Base;
1938 Last
: Index_Type
'Base := Index_Type
'Pred (Index_Type
'First);
1945 Count_Type
'Base'Read (Stream, Length);
1947 if Length > Capacity (Container) then
1948 Reserve_Capacity (Container, Capacity => Length);
1951 for J in Count_Type range 1 .. Length loop
1954 Boolean'Read (Stream, B);
1957 Container.Elements (Last) :=
1958 new Element_Type'(Element_Type
'Input (Stream
));
1961 Container
.Last
:= Last
;
1966 (Stream
: not null access Root_Stream_Type
'Class;
1967 Position
: out Cursor
)
1970 raise Program_Error
with "attempt to stream vector cursor";
1973 ---------------------
1974 -- Replace_Element --
1975 ---------------------
1977 procedure Replace_Element
1978 (Container
: in out Vector
;
1980 New_Item
: Element_Type
)
1983 if Index
> Container
.Last
then
1984 raise Constraint_Error
with "Index is out of range";
1987 if Container
.Lock
> 0 then
1988 raise Program_Error
with
1989 "attempt to tamper with cursors (vector is locked)";
1993 X
: Element_Access
:= Container
.Elements
(Index
);
1995 Container
.Elements
(Index
) := new Element_Type
'(New_Item);
1998 end Replace_Element;
2000 procedure Replace_Element
2001 (Container : in out Vector;
2003 New_Item : Element_Type)
2006 if Position.Container = null then
2007 raise Constraint_Error with "Position cursor has no element";
2010 if Position.Container /= Container'Unrestricted_Access then
2011 raise Program_Error with "Position cursor denotes wrong container";
2014 Replace_Element (Container, Position.Index, New_Item);
2015 end Replace_Element;
2017 ----------------------
2018 -- Reserve_Capacity --
2019 ----------------------
2021 procedure Reserve_Capacity
2022 (Container : in out Vector;
2023 Capacity : Count_Type)
2025 N : constant Count_Type := Length (Container);
2028 if Capacity = 0 then
2031 X : Elements_Access := Container.Elements;
2033 Container.Elements := null;
2037 elsif N < Container.Elements'Length then
2038 if Container.Busy > 0 then
2039 raise Program_Error with
2040 "attempt to tamper with elements (vector is busy)";
2044 subtype Array_Index_Subtype is Index_Type'Base range
2045 Index_Type'First .. Container.Last;
2047 Src : Elements_Type renames
2048 Container.Elements (Array_Index_Subtype);
2050 subtype Array_Subtype is
2051 Elements_Type (Array_Index_Subtype);
2053 X : Elements_Access := Container.Elements;
2056 Container.Elements := new Array_Subtype'(Src
);
2064 if Container
.Elements
= null then
2066 Last_As_Int
: constant Int
'Base :=
2067 Int
(Index_Type
'First) + Int
(Capacity
) - 1;
2070 if Last_As_Int
> Index_Type
'Pos (Index_Type
'Last) then
2071 raise Constraint_Error
with "new length is out of range";
2075 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
2077 subtype Array_Subtype
is
2078 Elements_Type
(Index_Type
'First .. Last
);
2081 Container
.Elements
:= new Array_Subtype
;
2088 if Capacity
<= N
then
2089 if N
< Container
.Elements
'Length then
2090 if Container
.Busy
> 0 then
2091 raise Program_Error
with
2092 "attempt to tamper with elements (vector is busy)";
2096 subtype Array_Index_Subtype
is Index_Type
'Base range
2097 Index_Type
'First .. Container
.Last
;
2099 Src
: Elements_Type
renames
2100 Container
.Elements
(Array_Index_Subtype
);
2102 subtype Array_Subtype
is
2103 Elements_Type
(Array_Index_Subtype
);
2105 X
: Elements_Access
:= Container
.Elements
;
2108 Container
.Elements
:= new Array_Subtype
'(Src);
2116 if Capacity = Container.Elements'Length then
2120 if Container.Busy > 0 then
2121 raise Program_Error with
2122 "attempt to tamper with elements (vector is busy)";
2126 Last_As_Int : constant Int'Base :=
2127 Int (Index_Type'First) + Int (Capacity) - 1;
2130 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2131 raise Constraint_Error with "new length is out of range";
2135 Last : constant Index_Type := Index_Type (Last_As_Int);
2137 subtype Array_Subtype is
2138 Elements_Type (Index_Type'First .. Last);
2140 X : Elements_Access := Container.Elements;
2143 Container.Elements := new Array_Subtype;
2146 Src : Elements_Type renames
2147 X (Index_Type'First .. Container.Last);
2149 Tgt : Elements_Type renames
2150 Container.Elements (Index_Type'First .. Container.Last);
2159 end Reserve_Capacity;
2161 ----------------------
2162 -- Reverse_Elements --
2163 ----------------------
2165 procedure Reverse_Elements (Container : in out Vector) is
2167 if Container.Length <= 1 then
2171 if Container.Lock > 0 then
2172 raise Program_Error with
2173 "attempt to tamper with cursors (vector is locked)";
2179 E : Elements_Type renames Container.Elements.all;
2182 I := Index_Type'First;
2183 J := Container.Last;
2186 EI : constant Element_Access := E (I);
2197 end Reverse_Elements;
2203 function Reverse_Find
2204 (Container : Vector;
2205 Item : Element_Type;
2206 Position : Cursor := No_Element) return Cursor
2208 Last : Index_Type'Base;
2211 if Position.Container /= null
2212 and then Position.Container /= Container'Unchecked_Access
2214 raise Program_Error with "Position cursor denotes wrong container";
2217 if Position.Container = null
2218 or else Position.Index > Container.Last
2220 Last := Container.Last;
2222 Last := Position.Index;
2225 for Indx in reverse Index_Type'First .. Last loop
2226 if Container.Elements (Indx) /= null
2227 and then Container.Elements (Indx).all = Item
2229 return (Container'Unchecked_Access, Indx);
2236 ------------------------
2237 -- Reverse_Find_Index --
2238 ------------------------
2240 function Reverse_Find_Index
2241 (Container : Vector;
2242 Item : Element_Type;
2243 Index : Index_Type := Index_Type'Last) return Extended_Index
2245 Last : Index_Type'Base;
2248 if Index > Container.Last then
2249 Last := Container.Last;
2254 for Indx in reverse Index_Type'First .. Last loop
2255 if Container.Elements (Indx) /= null
2256 and then Container.Elements (Indx).all = Item
2263 end Reverse_Find_Index;
2265 ---------------------
2266 -- Reverse_Iterate --
2267 ---------------------
2269 procedure Reverse_Iterate
2270 (Container : Vector;
2271 Process : not null access procedure (Position : Cursor))
2273 V : Vector renames Container'Unrestricted_Access.all;
2274 B : Natural renames V.Busy;
2280 for Indx in reverse Index_Type'First .. Container.Last loop
2281 Process (Cursor'(Container
'Unchecked_Access, Indx
));
2290 end Reverse_Iterate
;
2296 procedure Set_Length
2297 (Container
: in out Vector
;
2298 Length
: Count_Type
)
2300 N
: constant Count_Type
:= Indefinite_Vectors
.Length
(Container
);
2307 if Container
.Busy
> 0 then
2308 raise Program_Error
with
2309 "attempt to tamper with elements (vector is busy)";
2313 for Index
in 1 .. N
- Length
loop
2315 J
: constant Index_Type
:= Container
.Last
;
2316 X
: Element_Access
:= Container
.Elements
(J
);
2319 Container
.Elements
(J
) := null;
2320 Container
.Last
:= J
- 1;
2328 if Length
> Capacity
(Container
) then
2329 Reserve_Capacity
(Container
, Capacity
=> Length
);
2333 Last_As_Int
: constant Int
'Base :=
2334 Int
(Index_Type
'First) + Int
(Length
) - 1;
2337 Container
.Last
:= Index_Type
(Last_As_Int
);
2346 (Container
: in out Vector
;
2350 if I
> Container
.Last
then
2351 raise Constraint_Error
with "I index is out of range";
2354 if J
> Container
.Last
then
2355 raise Constraint_Error
with "J index is out of range";
2362 if Container
.Lock
> 0 then
2363 raise Program_Error
with
2364 "attempt to tamper with cursors (vector is locked)";
2368 EI
: Element_Access
renames Container
.Elements
(I
);
2369 EJ
: Element_Access
renames Container
.Elements
(J
);
2371 EI_Copy
: constant Element_Access
:= EI
;
2380 (Container
: in out Vector
;
2384 if I
.Container
= null then
2385 raise Constraint_Error
with "I cursor has no element";
2388 if J
.Container
= null then
2389 raise Constraint_Error
with "J cursor has no element";
2392 if I
.Container
/= Container
'Unrestricted_Access then
2393 raise Program_Error
with "I cursor denotes wrong container";
2396 if J
.Container
/= Container
'Unrestricted_Access then
2397 raise Program_Error
with "J cursor denotes wrong container";
2400 Swap
(Container
, I
.Index
, J
.Index
);
2408 (Container
: Vector
;
2409 Index
: Extended_Index
) return Cursor
2412 if Index
not in Index_Type
'First .. Container
.Last
then
2416 return Cursor
'(Container'Unchecked_Access, Index);
2423 function To_Index (Position : Cursor) return Extended_Index is
2425 if Position.Container = null then
2429 if Position.Index <= Position.Container.Last then
2430 return Position.Index;
2440 function To_Vector (Length : Count_Type) return Vector is
2443 return Empty_Vector;
2447 First : constant Int := Int (Index_Type'First);
2448 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2450 Elements : Elements_Access;
2453 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2454 raise Constraint_Error with "Length is out of range";
2457 Last := Index_Type (Last_As_Int);
2458 Elements := new Elements_Type (Index_Type'First .. Last);
2460 return (Controlled with Elements, Last, 0, 0);
2465 (New_Item : Element_Type;
2466 Length : Count_Type) return Vector
2470 return Empty_Vector;
2474 First : constant Int := Int (Index_Type'First);
2475 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2476 Last : Index_Type'Base;
2477 Elements : Elements_Access;
2480 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2481 raise Constraint_Error with "Length is out of range";
2484 Last := Index_Type (Last_As_Int);
2485 Elements := new Elements_Type (Index_Type'First .. Last);
2487 Last := Index_Type'First;
2491 Elements (Last) := new Element_Type'(New_Item
);
2492 exit when Last
= Elements
'Last;
2497 for J
in Index_Type
'First .. Last
- 1 loop
2498 Free
(Elements
(J
));
2505 return (Controlled
with Elements
, Last
, 0, 0);
2509 --------------------
2510 -- Update_Element --
2511 --------------------
2513 procedure Update_Element
2514 (Container
: in out Vector
;
2516 Process
: not null access procedure (Element
: in out Element_Type
))
2518 B
: Natural renames Container
.Busy
;
2519 L
: Natural renames Container
.Lock
;
2522 if Index
> Container
.Last
then
2523 raise Constraint_Error
with "Index is out of range";
2526 if Container
.Elements
(Index
) = null then
2527 raise Constraint_Error
with "element is null";
2534 Process
(Container
.Elements
(Index
).all);
2546 procedure Update_Element
2547 (Container
: in out Vector
;
2549 Process
: not null access procedure (Element
: in out Element_Type
))
2552 if Position
.Container
= null then
2553 raise Constraint_Error
with "Position cursor has no element";
2556 if Position
.Container
/= Container
'Unrestricted_Access then
2557 raise Program_Error
with "Position cursor denotes wrong container";
2560 Update_Element
(Container
, Position
.Index
, Process
);
2568 (Stream
: not null access Root_Stream_Type
'Class;
2571 N
: constant Count_Type
:= Length
(Container
);
2574 Count_Type
'Base'Write (Stream, N);
2581 E : Elements_Type renames Container.Elements.all;
2584 for Indx in Index_Type'First .. Container.Last loop
2585 if E (Indx) = null then
2586 Boolean'Write (Stream, False);
2588 Boolean'Write (Stream, True);
2589 Element_Type'Output (Stream, E (Indx).all);
2596 (Stream : not null access Root_Stream_Type'Class;
2600 raise Program_Error with "attempt to stream vector cursor";
2603 end Ada.Containers.Indefinite_Vectors;