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-2007, 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_Array
renames
63 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
65 Elements
: Elements_Access
:=
66 new Elements_Type
(Right
.Last
);
69 for I
in Elements
.EA
'Range loop
71 if RE
(I
) /= null then
72 Elements
.EA
(I
) := new Element_Type
'(RE (I).all);
77 for J in Index_Type'First .. I - 1 loop
78 Free (Elements.EA (J));
86 return (Controlled with Elements, Right.Last, 0, 0);
93 LE : Elements_Array renames
94 Left.Elements.EA (Index_Type'First .. Left.Last);
96 Elements : Elements_Access :=
97 new Elements_Type (Left.Last);
100 for I in Elements.EA'Range loop
102 if LE (I) /= null then
103 Elements.EA (I) := new Element_Type'(LE
(I
).all);
108 for J
in Index_Type
'First .. I
- 1 loop
109 Free
(Elements
.EA
(J
));
117 return (Controlled
with Elements
, Left
.Last
, 0, 0);
122 N
: constant Int
'Base := Int
(LN
) + Int
(RN
);
123 Last_As_Int
: Int
'Base;
126 if Int
(No_Index
) > Int
'Last - N
then
127 raise Constraint_Error
with "new length is out of range";
130 Last_As_Int
:= Int
(No_Index
) + N
;
132 if Last_As_Int
> Int
(Index_Type
'Last) then
133 raise Constraint_Error
with "new length is out of range";
137 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
139 LE
: Elements_Array
renames
140 Left
.Elements
.EA
(Index_Type
'First .. Left
.Last
);
142 RE
: Elements_Array
renames
143 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
145 Elements
: Elements_Access
:= new Elements_Type
(Last
);
147 I
: Index_Type
'Base := No_Index
;
150 for LI
in LE
'Range loop
154 if LE
(LI
) /= null then
155 Elements
.EA
(I
) := new Element_Type
'(LE (LI).all);
160 for J in Index_Type'First .. I - 1 loop
161 Free (Elements.EA (J));
169 for RI in RE'Range loop
173 if RE (RI) /= null then
174 Elements.EA (I) := new Element_Type'(RE
(RI
).all);
179 for J
in Index_Type
'First .. I
- 1 loop
180 Free
(Elements
.EA
(J
));
188 return (Controlled
with Elements
, Last
, 0, 0);
193 function "&" (Left
: Vector
; Right
: Element_Type
) return Vector
is
194 LN
: constant Count_Type
:= Length
(Left
);
199 Elements
: Elements_Access
:= new Elements_Type
(Index_Type
'First);
203 Elements
.EA
(Index_Type
'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_Array renames
232 Left.Elements.EA (Index_Type'First .. Left.Last);
234 Elements : Elements_Access :=
235 new Elements_Type (Last);
238 for I in LE'Range loop
240 if LE (I) /= null then
241 Elements.EA (I) := new Element_Type'(LE
(I
).all);
246 for J
in Index_Type
'First .. I
- 1 loop
247 Free
(Elements
.EA
(J
));
256 Elements
.EA
(Last
) := new Element_Type
'(Right);
260 for J in Index_Type'First .. Last - 1 loop
261 Free (Elements.EA (J));
268 return (Controlled with Elements, Last, 0, 0);
273 function "&" (Left : Element_Type; Right : Vector) return Vector is
274 RN : constant Count_Type := Length (Right);
279 Elements : Elements_Access := new Elements_Type (Index_Type'First);
283 Elements.EA (Index_Type'First) := new Element_Type'(Left
);
290 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
295 Last_As_Int
: Int
'Base;
298 if Int
(Index_Type
'First) > Int
'Last - Int
(RN
) then
299 raise Constraint_Error
with "new length is out of range";
302 Last_As_Int
:= Int
(Index_Type
'First) + Int
(RN
);
304 if Last_As_Int
> Int
(Index_Type
'Last) then
305 raise Constraint_Error
with "new length is out of range";
309 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
311 RE
: Elements_Array
renames
312 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
314 Elements
: Elements_Access
:=
315 new Elements_Type
(Last
);
317 I
: Index_Type
'Base := Index_Type
'First;
321 Elements
.EA
(I
) := new Element_Type
'(Left);
328 for RI in RE'Range loop
332 if RE (RI) /= null then
333 Elements.EA (I) := new Element_Type'(RE
(RI
).all);
338 for J
in Index_Type
'First .. I
- 1 loop
339 Free
(Elements
.EA
(J
));
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;
360 Elements
: Elements_Access
:= new Elements_Type
(Last
);
364 Elements
.EA
(Index_Type
'First) := new Element_Type
'(Left);
372 Elements.EA (Last) := new Element_Type'(Right
);
375 Free
(Elements
.EA
(Index_Type
'First));
380 return (Controlled
with Elements
, Last
, 0, 0);
388 function "=" (Left
, Right
: Vector
) return Boolean is
390 if Left
'Address = Right
'Address then
394 if Left
.Last
/= Right
.Last
then
398 for J
in Index_Type
'First .. Left
.Last
loop
399 if Left
.Elements
.EA
(J
) = null then
400 if Right
.Elements
.EA
(J
) /= null then
404 elsif Right
.Elements
.EA
(J
) = null then
407 elsif Left
.Elements
.EA
(J
).all /= Right
.Elements
.EA
(J
).all then
419 procedure Adjust
(Container
: in out Vector
) is
421 if Container
.Last
= No_Index
then
422 Container
.Elements
:= null;
427 L
: constant Index_Type
:= Container
.Last
;
428 E
: Elements_Array
renames
429 Container
.Elements
.EA
(Index_Type
'First .. L
);
432 Container
.Elements
:= null;
433 Container
.Last
:= No_Index
;
437 Container
.Elements
:= new Elements_Type
(L
);
439 for I
in E
'Range loop
440 if E
(I
) /= null then
441 Container
.Elements
.EA
(I
) := new Element_Type
'(E (I).all);
453 procedure Append (Container : in out Vector; New_Item : Vector) is
455 if Is_Empty (New_Item) then
459 if Container.Last = Index_Type'Last then
460 raise Constraint_Error with "vector is already at its maximum length";
470 (Container : in out Vector;
471 New_Item : Element_Type;
472 Count : Count_Type := 1)
479 if Container.Last = Index_Type'Last then
480 raise Constraint_Error with "vector is already at its maximum length";
494 function Capacity (Container : Vector) return Count_Type is
496 if Container.Elements = null then
500 return Container.Elements.EA'Length;
507 procedure Clear (Container : in out Vector) is
509 if Container.Busy > 0 then
510 raise Program_Error with
511 "attempt to tamper with elements (vector is busy)";
514 while Container.Last >= Index_Type'First loop
516 X : Element_Access := Container.Elements.EA (Container.Last);
518 Container.Elements.EA (Container.Last) := null;
519 Container.Last := Container.Last - 1;
531 Item : Element_Type) return Boolean
534 return Find_Index (Container, Item) /= No_Index;
542 (Container : in out Vector;
543 Index : Extended_Index;
544 Count : Count_Type := 1)
547 if Index < Index_Type'First then
548 raise Constraint_Error with "Index is out of range (too small)";
551 if Index > Container.Last then
552 if Index > Container.Last + 1 then
553 raise Constraint_Error with "Index is out of range (too large)";
563 if Container.Busy > 0 then
564 raise Program_Error with
565 "attempt to tamper with elements (vector is busy)";
569 Index_As_Int : constant Int := Int (Index);
570 Old_Last_As_Int : constant Int := Int (Container.Last);
572 Count1 : constant Int'Base := Int (Count);
573 Count2 : constant Int'Base := Old_Last_As_Int - Index_As_Int + 1;
574 N : constant Int'Base := Int'Min (Count1, Count2);
576 J_As_Int : constant Int'Base := Index_As_Int + N;
577 E : Elements_Array renames Container.Elements.EA;
580 if J_As_Int > Old_Last_As_Int then
581 while Container.Last >= Index loop
583 K : constant Index_Type := Container.Last;
584 X : Element_Access := E (K);
588 Container.Last := K - 1;
595 J : constant Index_Type := Index_Type (J_As_Int);
597 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
598 New_Last : constant Index_Type :=
599 Index_Type (New_Last_As_Int);
602 for K in Index .. J - 1 loop
604 X : Element_Access := E (K);
611 E (Index .. New_Last) := E (J .. Container.Last);
612 Container.Last := New_Last;
619 (Container : in out Vector;
620 Position : in out Cursor;
621 Count : Count_Type := 1)
623 pragma Warnings (Off, Position);
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;
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_Array renames Container.Elements.EA;
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.EA (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 if Position.Index > Position.Container.Last then
736 raise Constraint_Error with "Position cursor is out of range";
740 EA : constant Element_Access :=
741 Position.Container.Elements.EA (Position.Index);
745 raise Constraint_Error with "element is empty";
756 procedure Finalize (Container : in out Vector) is
758 Clear (Container); -- Checks busy-bit
761 X : Elements_Access := Container.Elements;
763 Container.Elements := null;
775 Position : Cursor := No_Element) return Cursor
778 if Position.Container /= null then
779 if Position.Container /= Container'Unrestricted_Access then
780 raise Program_Error with "Position cursor denotes wrong container";
783 if Position.Index > Container.Last then
784 raise Program_Error with "Position index is out of range";
788 for J in Position.Index .. Container.Last loop
789 if Container.Elements.EA (J) /= null
790 and then Container.Elements.EA (J).all = Item
792 return (Container'Unchecked_Access, J);
806 Index : Index_Type := Index_Type'First) return Extended_Index
809 for Indx in Index .. Container.Last loop
810 if Container.Elements.EA (Indx) /= null
811 and then Container.Elements.EA (Indx).all = Item
824 function First (Container : Vector) return Cursor is
826 if Is_Empty (Container) then
830 return (Container'Unchecked_Access, Index_Type'First);
837 function First_Element (Container : Vector) return Element_Type is
839 if Container.Last = No_Index then
840 raise Constraint_Error with "Container is empty";
844 EA : constant Element_Access :=
845 Container.Elements.EA (Index_Type'First);
849 raise Constraint_Error with "first element is empty";
860 function First_Index (Container : Vector) return Index_Type is
861 pragma Unreferenced (Container);
863 return Index_Type'First;
866 ---------------------
867 -- Generic_Sorting --
868 ---------------------
870 package body Generic_Sorting is
872 -----------------------
873 -- Local Subprograms --
874 -----------------------
876 function Is_Less (L, R : Element_Access) return Boolean;
877 pragma Inline (Is_Less);
883 function Is_Less (L, R : Element_Access) return Boolean is
890 return L.all < R.all;
898 function Is_Sorted (Container : Vector) return Boolean is
900 if Container.Last <= Index_Type'First then
905 E : Elements_Array renames Container.Elements.EA;
907 for I in Index_Type'First .. Container.Last - 1 loop
908 if Is_Less (E (I + 1), E (I)) then
921 procedure Merge (Target, Source : in out Vector) is
922 I, J : Index_Type'Base;
925 if Target.Last < Index_Type'First then
926 Move (Target => Target, Source => Source);
930 if Target'Address = Source'Address then
934 if Source.Last < Index_Type'First then
938 if Source.Busy > 0 then
939 raise Program_Error with
940 "attempt to tamper with elements (vector is busy)";
943 I := Target.Last; -- original value (before Set_Length)
944 Target.Set_Length (Length (Target) + Length (Source));
946 J := Target.Last; -- new value (after Set_Length)
947 while Source.Last >= Index_Type'First loop
949 (Source.Last <= Index_Type'First
951 (Source.Elements.EA (Source.Last),
952 Source.Elements.EA (Source.Last - 1))));
954 if I < Index_Type'First then
956 Src : Elements_Array renames
957 Source.Elements.EA (Index_Type'First .. Source.Last);
960 Target.Elements.EA (Index_Type'First .. J) := Src;
961 Src := (others => null);
964 Source.Last := No_Index;
969 (I <= Index_Type'First
971 (Target.Elements.EA (I),
972 Target.Elements.EA (I - 1))));
975 Src : Element_Access renames Source.Elements.EA (Source.Last);
976 Tgt : Element_Access renames Target.Elements.EA (I);
979 if Is_Less (Src, Tgt) then
980 Target.Elements.EA (J) := Tgt;
985 Target.Elements.EA (J) := Src;
987 Source.Last := Source.Last - 1;
999 procedure Sort (Container : in out Vector)
1002 new Generic_Array_Sort
1003 (Index_Type => Index_Type,
1004 Element_Type => Element_Access,
1005 Array_Type => Elements_Array,
1008 -- Start of processing for Sort
1011 if Container.Last <= Index_Type'First then
1015 if Container.Lock > 0 then
1016 raise Program_Error with
1017 "attempt to tamper with cursors (vector is locked)";
1020 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1023 end Generic_Sorting;
1029 function Has_Element (Position : Cursor) return Boolean is
1031 if Position.Container = null then
1035 return Position.Index <= Position.Container.Last;
1043 (Container : in out Vector;
1044 Before : Extended_Index;
1045 New_Item : Element_Type;
1046 Count : Count_Type := 1)
1048 N : constant Int := Int (Count);
1050 First : constant Int := Int (Index_Type'First);
1051 New_Last_As_Int : Int'Base;
1052 New_Last : Index_Type;
1054 Max_Length : constant UInt := UInt (Count_Type'Last);
1056 Dst : Elements_Access;
1059 if Before < Index_Type'First then
1060 raise Constraint_Error with
1061 "Before index is out of range (too small)";
1064 if Before > Container.Last
1065 and then Before > Container.Last + 1
1067 raise Constraint_Error with
1068 "Before index is out of range (too large)";
1076 Old_Last_As_Int : constant Int := Int (Container.Last);
1079 if Old_Last_As_Int > Int'Last - N then
1080 raise Constraint_Error with "new length is out of range";
1083 New_Last_As_Int := Old_Last_As_Int + N;
1085 if New_Last_As_Int > Int (Index_Type'Last) then
1086 raise Constraint_Error with "new length is out of range";
1089 New_Length := UInt (New_Last_As_Int - First + 1);
1091 if New_Length > Max_Length then
1092 raise Constraint_Error with "new length is out of range";
1095 New_Last := Index_Type (New_Last_As_Int);
1098 if Container.Busy > 0 then
1099 raise Program_Error with
1100 "attempt to tamper with elements (vector is busy)";
1103 if Container.Elements = null then
1104 Container.Elements := new Elements_Type (New_Last);
1105 Container.Last := No_Index;
1107 for J in Container.Elements.EA'Range loop
1108 Container.Elements.EA (J) := new Element_Type'(New_Item
);
1109 Container
.Last
:= J
;
1115 if New_Last
<= Container
.Elements
.Last
then
1117 E
: Elements_Array
renames Container
.Elements
.EA
;
1120 if Before
<= Container
.Last
then
1122 Index_As_Int
: constant Int
'Base :=
1123 Index_Type
'Pos (Before
) + N
;
1125 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1127 J
: Index_Type
'Base;
1130 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
1131 Container
.Last
:= New_Last
;
1134 while J
< Index
loop
1135 E
(J
) := new Element_Type
'(New_Item);
1141 E (J .. Index - 1) := (others => null);
1146 for J in Before .. New_Last loop
1147 E (J) := new Element_Type'(New_Item
);
1148 Container
.Last
:= J
;
1160 C
:= UInt
'Max (1, Container
.Elements
.EA
'Length); -- ???
1161 while C
< New_Length
loop
1162 if C
> UInt
'Last / 2 then
1170 if C
> Max_Length
then
1174 if Index_Type
'First <= 0
1175 and then Index_Type
'Last >= 0
1177 CC
:= UInt
(Index_Type
'Last) + UInt
(-Index_Type
'First) + 1;
1180 CC
:= UInt
(Int
(Index_Type
'Last) - First
+ 1);
1188 Dst_Last
: constant Index_Type
:=
1189 Index_Type
(First
+ UInt
'Pos (C
) - Int
'(1));
1192 Dst := new Elements_Type (Dst_Last);
1196 if Before <= Container.Last then
1198 Index_As_Int : constant Int'Base :=
1199 Index_Type'Pos (Before) + N;
1201 Index : constant Index_Type := Index_Type (Index_As_Int);
1203 Src : Elements_Access := Container.Elements;
1206 Dst.EA (Index_Type'First .. Before - 1) :=
1207 Src.EA (Index_Type'First .. Before - 1);
1209 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1211 Container.Elements := Dst;
1212 Container.Last := New_Last;
1215 for J in Before .. Index - 1 loop
1216 Dst.EA (J) := new Element_Type'(New_Item
);
1222 Src
: Elements_Access
:= Container
.Elements
;
1225 Dst
.EA
(Index_Type
'First .. Container
.Last
) :=
1226 Src
.EA
(Index_Type
'First .. Container
.Last
);
1228 Container
.Elements
:= Dst
;
1231 for J
in Before
.. New_Last
loop
1232 Dst
.EA
(J
) := new Element_Type
'(New_Item);
1233 Container.Last := J;
1240 (Container : in out Vector;
1241 Before : Extended_Index;
1244 N : constant Count_Type := Length (New_Item);
1247 if Before < Index_Type'First then
1248 raise Constraint_Error with
1249 "Before index is out of range (too small)";
1252 if Before > Container.Last
1253 and then Before > Container.Last + 1
1255 raise Constraint_Error with
1256 "Before index is out of range (too large)";
1263 Insert_Space (Container, Before, Count => N);
1266 Dst_Last_As_Int : constant Int'Base :=
1267 Int'Base (Before) + Int'Base (N) - 1;
1269 Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
1271 Dst : Elements_Array renames
1272 Container.Elements.EA (Before .. Dst_Last);
1274 Dst_Index : Index_Type'Base := Before - 1;
1277 if Container'Address /= New_Item'Address then
1279 subtype Src_Index_Subtype is Index_Type'Base range
1280 Index_Type'First .. New_Item.Last;
1282 Src : Elements_Array renames
1283 New_Item.Elements.EA (Src_Index_Subtype);
1286 for Src_Index in Src'Range loop
1287 Dst_Index := Dst_Index + 1;
1289 if Src (Src_Index) /= null then
1290 Dst (Dst_Index) := new Element_Type'(Src
(Src_Index
).all);
1299 subtype Src_Index_Subtype
is Index_Type
'Base range
1300 Index_Type
'First .. Before
- 1;
1302 Src
: Elements_Array
renames
1303 Container
.Elements
.EA
(Src_Index_Subtype
);
1306 for Src_Index
in Src
'Range loop
1307 Dst_Index
:= Dst_Index
+ 1;
1309 if Src
(Src_Index
) /= null then
1310 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
1315 if Dst_Last = Container.Last then
1320 subtype Src_Index_Subtype is Index_Type'Base range
1321 Dst_Last + 1 .. Container.Last;
1323 Src : Elements_Array renames
1324 Container.Elements.EA (Src_Index_Subtype);
1327 for Src_Index in Src'Range loop
1328 Dst_Index := Dst_Index + 1;
1330 if Src (Src_Index) /= null then
1331 Dst (Dst_Index) := new Element_Type'(Src
(Src_Index
).all);
1339 (Container
: in out Vector
;
1343 Index
: Index_Type
'Base;
1346 if Before
.Container
/= null
1347 and then Before
.Container
/= Container
'Unchecked_Access
1349 raise Program_Error
with "Before cursor denotes wrong container";
1352 if Is_Empty
(New_Item
) then
1356 if Before
.Container
= null
1357 or else Before
.Index
> Container
.Last
1359 if Container
.Last
= Index_Type
'Last then
1360 raise Constraint_Error
with
1361 "vector is already at its maximum length";
1364 Index
:= Container
.Last
+ 1;
1367 Index
:= Before
.Index
;
1370 Insert
(Container
, Index
, New_Item
);
1374 (Container
: in out Vector
;
1377 Position
: out Cursor
)
1379 Index
: Index_Type
'Base;
1382 if Before
.Container
/= null
1383 and then Before
.Container
/= Vector_Access
'(Container'Unchecked_Access)
1385 raise Program_Error with "Before cursor denotes wrong container";
1388 if Is_Empty (New_Item) then
1389 if Before.Container = null
1390 or else Before.Index > Container.Last
1392 Position := No_Element;
1394 Position := (Container'Unchecked_Access, Before.Index);
1400 if Before.Container = null
1401 or else Before.Index > Container.Last
1403 if Container.Last = Index_Type'Last then
1404 raise Constraint_Error with
1405 "vector is already at its maximum length";
1408 Index := Container.Last + 1;
1411 Index := Before.Index;
1414 Insert (Container, Index, New_Item);
1416 Position := Cursor'(Container
'Unchecked_Access, Index
);
1420 (Container
: in out Vector
;
1422 New_Item
: Element_Type
;
1423 Count
: Count_Type
:= 1)
1425 Index
: Index_Type
'Base;
1428 if Before
.Container
/= null
1429 and then Before
.Container
/= Container
'Unchecked_Access
1431 raise Program_Error
with "Before cursor denotes wrong container";
1438 if Before
.Container
= null
1439 or else Before
.Index
> Container
.Last
1441 if Container
.Last
= Index_Type
'Last then
1442 raise Constraint_Error
with
1443 "vector is already at its maximum length";
1446 Index
:= Container
.Last
+ 1;
1449 Index
:= Before
.Index
;
1452 Insert
(Container
, Index
, New_Item
, Count
);
1456 (Container
: in out Vector
;
1458 New_Item
: Element_Type
;
1459 Position
: out Cursor
;
1460 Count
: Count_Type
:= 1)
1462 Index
: Index_Type
'Base;
1465 if Before
.Container
/= null
1466 and then Before
.Container
/= Container
'Unchecked_Access
1468 raise Program_Error
with "Before cursor denotes wrong container";
1472 if Before
.Container
= null
1473 or else Before
.Index
> Container
.Last
1475 Position
:= No_Element
;
1477 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1483 if Before
.Container
= null
1484 or else Before
.Index
> Container
.Last
1486 if Container
.Last
= Index_Type
'Last then
1487 raise Constraint_Error
with
1488 "vector is already at its maximum length";
1491 Index
:= Container
.Last
+ 1;
1494 Index
:= Before
.Index
;
1497 Insert
(Container
, Index
, New_Item
, Count
);
1499 Position
:= (Container
'Unchecked_Access, Index
);
1506 procedure Insert_Space
1507 (Container
: in out Vector
;
1508 Before
: Extended_Index
;
1509 Count
: Count_Type
:= 1)
1511 N
: constant Int
:= Int
(Count
);
1513 First
: constant Int
:= Int
(Index_Type
'First);
1514 New_Last_As_Int
: Int
'Base;
1515 New_Last
: Index_Type
;
1517 Max_Length
: constant UInt
:= UInt
(Count_Type
'Last);
1519 Dst
: Elements_Access
;
1522 if Before
< Index_Type
'First then
1523 raise Constraint_Error
with
1524 "Before index is out of range (too small)";
1527 if Before
> Container
.Last
1528 and then Before
> Container
.Last
+ 1
1530 raise Constraint_Error
with
1531 "Before index is out of range (too large)";
1539 Old_Last_As_Int
: constant Int
:= Int
(Container
.Last
);
1542 if Old_Last_As_Int
> Int
'Last - N
then
1543 raise Constraint_Error
with "new length is out of range";
1546 New_Last_As_Int
:= Old_Last_As_Int
+ N
;
1548 if New_Last_As_Int
> Int
(Index_Type
'Last) then
1549 raise Constraint_Error
with "new length is out of range";
1552 New_Length
:= UInt
(New_Last_As_Int
- First
+ 1);
1554 if New_Length
> Max_Length
then
1555 raise Constraint_Error
with "new length is out of range";
1558 New_Last
:= Index_Type
(New_Last_As_Int
);
1561 if Container
.Busy
> 0 then
1562 raise Program_Error
with
1563 "attempt to tamper with elements (vector is busy)";
1566 if Container
.Elements
= null then
1567 Container
.Elements
:= new Elements_Type
(New_Last
);
1568 Container
.Last
:= New_Last
;
1572 if New_Last
<= Container
.Elements
.Last
then
1574 E
: Elements_Array
renames Container
.Elements
.EA
;
1577 if Before
<= Container
.Last
then
1579 Index_As_Int
: constant Int
'Base :=
1580 Index_Type
'Pos (Before
) + N
;
1582 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1585 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
1586 E
(Before
.. Index
- 1) := (others => null);
1591 Container
.Last
:= New_Last
;
1599 C
:= UInt
'Max (1, Container
.Elements
.EA
'Length); -- ???
1600 while C
< New_Length
loop
1601 if C
> UInt
'Last / 2 then
1609 if C
> Max_Length
then
1613 if Index_Type
'First <= 0
1614 and then Index_Type
'Last >= 0
1616 CC
:= UInt
(Index_Type
'Last) + UInt
(-Index_Type
'First) + 1;
1619 CC
:= UInt
(Int
(Index_Type
'Last) - First
+ 1);
1627 Dst_Last
: constant Index_Type
:=
1628 Index_Type
(First
+ UInt
'Pos (C
) - 1);
1631 Dst
:= new Elements_Type
(Dst_Last
);
1636 Src
: Elements_Access
:= Container
.Elements
;
1639 if Before
<= Container
.Last
then
1641 Index_As_Int
: constant Int
'Base :=
1642 Index_Type
'Pos (Before
) + N
;
1644 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1647 Dst
.EA
(Index_Type
'First .. Before
- 1) :=
1648 Src
.EA
(Index_Type
'First .. Before
- 1);
1650 Dst
.EA
(Index
.. New_Last
) := Src
.EA
(Before
.. Container
.Last
);
1654 Dst
.EA
(Index_Type
'First .. Container
.Last
) :=
1655 Src
.EA
(Index_Type
'First .. Container
.Last
);
1658 Container
.Elements
:= Dst
;
1659 Container
.Last
:= New_Last
;
1664 procedure Insert_Space
1665 (Container
: in out Vector
;
1667 Position
: out Cursor
;
1668 Count
: Count_Type
:= 1)
1670 Index
: Index_Type
'Base;
1673 if Before
.Container
/= null
1674 and then Before
.Container
/= Container
'Unchecked_Access
1676 raise Program_Error
with "Before cursor denotes wrong container";
1680 if Before
.Container
= null
1681 or else Before
.Index
> Container
.Last
1683 Position
:= No_Element
;
1685 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1691 if Before
.Container
= null
1692 or else Before
.Index
> Container
.Last
1694 if Container
.Last
= Index_Type
'Last then
1695 raise Constraint_Error
with
1696 "vector is already at its maximum length";
1699 Index
:= Container
.Last
+ 1;
1702 Index
:= Before
.Index
;
1705 Insert_Space
(Container
, Index
, Count
);
1707 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1714 function Is_Empty (Container : Vector) return Boolean is
1716 return Container.Last < Index_Type'First;
1724 (Container : Vector;
1725 Process : not null access procedure (Position : Cursor))
1727 V : Vector renames Container'Unrestricted_Access.all;
1728 B : Natural renames V.Busy;
1734 for Indx in Index_Type'First .. Container.Last loop
1735 Process (Cursor'(Container
'Unchecked_Access, Indx
));
1750 function Last
(Container
: Vector
) return Cursor
is
1752 if Is_Empty
(Container
) then
1756 return (Container
'Unchecked_Access, Container
.Last
);
1763 function Last_Element
(Container
: Vector
) return Element_Type
is
1765 if Container
.Last
= No_Index
then
1766 raise Constraint_Error
with "Container is empty";
1770 EA
: constant Element_Access
:=
1771 Container
.Elements
.EA
(Container
.Last
);
1775 raise Constraint_Error
with "last element is empty";
1786 function Last_Index
(Container
: Vector
) return Extended_Index
is
1788 return Container
.Last
;
1795 function Length
(Container
: Vector
) return Count_Type
is
1796 L
: constant Int
:= Int
(Container
.Last
);
1797 F
: constant Int
:= Int
(Index_Type
'First);
1798 N
: constant Int
'Base := L
- F
+ 1;
1801 return Count_Type
(N
);
1809 (Target
: in out Vector
;
1810 Source
: in out Vector
)
1813 if Target
'Address = Source
'Address then
1817 if Source
.Busy
> 0 then
1818 raise Program_Error
with
1819 "attempt to tamper with elements (Source is busy)";
1822 Clear
(Target
); -- Checks busy-bit
1825 Target_Elements
: constant Elements_Access
:= Target
.Elements
;
1827 Target
.Elements
:= Source
.Elements
;
1828 Source
.Elements
:= Target_Elements
;
1831 Target
.Last
:= Source
.Last
;
1832 Source
.Last
:= No_Index
;
1839 function Next
(Position
: Cursor
) return Cursor
is
1841 if Position
.Container
= null then
1845 if Position
.Index
< Position
.Container
.Last
then
1846 return (Position
.Container
, Position
.Index
+ 1);
1856 procedure Next
(Position
: in out Cursor
) is
1858 if Position
.Container
= null then
1862 if Position
.Index
< Position
.Container
.Last
then
1863 Position
.Index
:= Position
.Index
+ 1;
1865 Position
:= No_Element
;
1873 procedure Prepend
(Container
: in out Vector
; New_Item
: Vector
) is
1875 Insert
(Container
, Index_Type
'First, New_Item
);
1879 (Container
: in out Vector
;
1880 New_Item
: Element_Type
;
1881 Count
: Count_Type
:= 1)
1894 procedure Previous
(Position
: in out Cursor
) is
1896 if Position
.Container
= null then
1900 if Position
.Index
> Index_Type
'First then
1901 Position
.Index
:= Position
.Index
- 1;
1903 Position
:= No_Element
;
1907 function Previous
(Position
: Cursor
) return Cursor
is
1909 if Position
.Container
= null then
1913 if Position
.Index
> Index_Type
'First then
1914 return (Position
.Container
, Position
.Index
- 1);
1924 procedure Query_Element
1925 (Container
: Vector
;
1927 Process
: not null access procedure (Element
: Element_Type
))
1929 V
: Vector
renames Container
'Unrestricted_Access.all;
1930 B
: Natural renames V
.Busy
;
1931 L
: Natural renames V
.Lock
;
1934 if Index
> Container
.Last
then
1935 raise Constraint_Error
with "Index is out of range";
1938 if V
.Elements
.EA
(Index
) = null then
1939 raise Constraint_Error
with "element is null";
1946 Process
(V
.Elements
.EA
(Index
).all);
1958 procedure Query_Element
1960 Process
: not null access procedure (Element
: Element_Type
))
1963 if Position
.Container
= null then
1964 raise Constraint_Error
with "Position cursor has no element";
1967 Query_Element
(Position
.Container
.all, Position
.Index
, Process
);
1975 (Stream
: not null access Root_Stream_Type
'Class;
1976 Container
: out Vector
)
1978 Length
: Count_Type
'Base;
1979 Last
: Index_Type
'Base := Index_Type
'Pred (Index_Type
'First);
1986 Count_Type
'Base'Read (Stream, Length);
1988 if Length > Capacity (Container) then
1989 Reserve_Capacity (Container, Capacity => Length);
1992 for J in Count_Type range 1 .. Length loop
1995 Boolean'Read (Stream, B);
1998 Container.Elements.EA (Last) :=
1999 new Element_Type'(Element_Type
'Input (Stream
));
2002 Container
.Last
:= Last
;
2007 (Stream
: not null access Root_Stream_Type
'Class;
2008 Position
: out Cursor
)
2011 raise Program_Error
with "attempt to stream vector cursor";
2014 ---------------------
2015 -- Replace_Element --
2016 ---------------------
2018 procedure Replace_Element
2019 (Container
: in out Vector
;
2021 New_Item
: Element_Type
)
2024 if Index
> Container
.Last
then
2025 raise Constraint_Error
with "Index is out of range";
2028 if Container
.Lock
> 0 then
2029 raise Program_Error
with
2030 "attempt to tamper with cursors (vector is locked)";
2034 X
: Element_Access
:= Container
.Elements
.EA
(Index
);
2036 Container
.Elements
.EA
(Index
) := new Element_Type
'(New_Item);
2039 end Replace_Element;
2041 procedure Replace_Element
2042 (Container : in out Vector;
2044 New_Item : Element_Type)
2047 if Position.Container = null then
2048 raise Constraint_Error with "Position cursor has no element";
2051 if Position.Container /= Container'Unrestricted_Access then
2052 raise Program_Error with "Position cursor denotes wrong container";
2055 if Position.Index > Container.Last then
2056 raise Constraint_Error with "Position cursor is out of range";
2059 if Container.Lock > 0 then
2060 raise Program_Error with
2061 "attempt to tamper with cursors (vector is locked)";
2065 X : Element_Access := Container.Elements.EA (Position.Index);
2067 Container.Elements.EA (Position.Index) := new Element_Type'(New_Item
);
2070 end Replace_Element
;
2072 ----------------------
2073 -- Reserve_Capacity --
2074 ----------------------
2076 procedure Reserve_Capacity
2077 (Container
: in out Vector
;
2078 Capacity
: Count_Type
)
2080 N
: constant Count_Type
:= Length
(Container
);
2083 if Capacity
= 0 then
2086 X
: Elements_Access
:= Container
.Elements
;
2088 Container
.Elements
:= null;
2092 elsif N
< Container
.Elements
.EA
'Length then
2093 if Container
.Busy
> 0 then
2094 raise Program_Error
with
2095 "attempt to tamper with elements (vector is busy)";
2099 subtype Array_Index_Subtype
is Index_Type
'Base range
2100 Index_Type
'First .. Container
.Last
;
2102 Src
: Elements_Array
renames
2103 Container
.Elements
.EA
(Array_Index_Subtype
);
2105 X
: Elements_Access
:= Container
.Elements
;
2108 Container
.Elements
:= new Elements_Type
'(Container.Last, Src);
2116 if Container.Elements = null then
2118 Last_As_Int : constant Int'Base :=
2119 Int (Index_Type'First) + Int (Capacity) - 1;
2122 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2123 raise Constraint_Error with "new length is out of range";
2127 Last : constant Index_Type := Index_Type (Last_As_Int);
2130 Container.Elements := new Elements_Type (Last);
2137 if Capacity <= N then
2138 if N < Container.Elements.EA'Length then
2139 if Container.Busy > 0 then
2140 raise Program_Error with
2141 "attempt to tamper with elements (vector is busy)";
2145 subtype Array_Index_Subtype is Index_Type'Base range
2146 Index_Type'First .. Container.Last;
2148 Src : Elements_Array renames
2149 Container.Elements.EA (Array_Index_Subtype);
2151 X : Elements_Access := Container.Elements;
2154 Container.Elements := new Elements_Type'(Container
.Last
, Src
);
2162 if Capacity
= Container
.Elements
.EA
'Length then
2166 if Container
.Busy
> 0 then
2167 raise Program_Error
with
2168 "attempt to tamper with elements (vector is busy)";
2172 Last_As_Int
: constant Int
'Base :=
2173 Int
(Index_Type
'First) + Int
(Capacity
) - 1;
2176 if Last_As_Int
> Index_Type
'Pos (Index_Type
'Last) then
2177 raise Constraint_Error
with "new length is out of range";
2181 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
2182 X
: Elements_Access
:= Container
.Elements
;
2184 subtype Index_Subtype
is Index_Type
'Base range
2185 Index_Type
'First .. Container
.Last
;
2188 Container
.Elements
:= new Elements_Type
(Last
);
2191 Src
: Elements_Array
renames
2192 X
.EA
(Index_Subtype
);
2194 Tgt
: Elements_Array
renames
2195 Container
.Elements
.EA
(Index_Subtype
);
2204 end Reserve_Capacity
;
2206 ----------------------
2207 -- Reverse_Elements --
2208 ----------------------
2210 procedure Reverse_Elements
(Container
: in out Vector
) is
2212 if Container
.Length
<= 1 then
2216 if Container
.Lock
> 0 then
2217 raise Program_Error
with
2218 "attempt to tamper with cursors (vector is locked)";
2224 E
: Elements_Array
renames Container
.Elements
.EA
;
2227 I
:= Index_Type
'First;
2228 J
:= Container
.Last
;
2231 EI
: constant Element_Access
:= E
(I
);
2242 end Reverse_Elements
;
2248 function Reverse_Find
2249 (Container
: Vector
;
2250 Item
: Element_Type
;
2251 Position
: Cursor
:= No_Element
) return Cursor
2253 Last
: Index_Type
'Base;
2256 if Position
.Container
/= null
2257 and then Position
.Container
/= Container
'Unchecked_Access
2259 raise Program_Error
with "Position cursor denotes wrong container";
2262 if Position
.Container
= null
2263 or else Position
.Index
> Container
.Last
2265 Last
:= Container
.Last
;
2267 Last
:= Position
.Index
;
2270 for Indx
in reverse Index_Type
'First .. Last
loop
2271 if Container
.Elements
.EA
(Indx
) /= null
2272 and then Container
.Elements
.EA
(Indx
).all = Item
2274 return (Container
'Unchecked_Access, Indx
);
2281 ------------------------
2282 -- Reverse_Find_Index --
2283 ------------------------
2285 function Reverse_Find_Index
2286 (Container
: Vector
;
2287 Item
: Element_Type
;
2288 Index
: Index_Type
:= Index_Type
'Last) return Extended_Index
2290 Last
: Index_Type
'Base;
2293 if Index
> Container
.Last
then
2294 Last
:= Container
.Last
;
2299 for Indx
in reverse Index_Type
'First .. Last
loop
2300 if Container
.Elements
.EA
(Indx
) /= null
2301 and then Container
.Elements
.EA
(Indx
).all = Item
2308 end Reverse_Find_Index
;
2310 ---------------------
2311 -- Reverse_Iterate --
2312 ---------------------
2314 procedure Reverse_Iterate
2315 (Container
: Vector
;
2316 Process
: not null access procedure (Position
: Cursor
))
2318 V
: Vector
renames Container
'Unrestricted_Access.all;
2319 B
: Natural renames V
.Busy
;
2325 for Indx
in reverse Index_Type
'First .. Container
.Last
loop
2326 Process
(Cursor
'(Container'Unchecked_Access, Indx));
2335 end Reverse_Iterate;
2341 procedure Set_Length
2342 (Container : in out Vector;
2343 Length : Count_Type)
2345 N : constant Count_Type := Indefinite_Vectors.Length (Container);
2352 if Container.Busy > 0 then
2353 raise Program_Error with
2354 "attempt to tamper with elements (vector is busy)";
2358 for Index in 1 .. N - Length loop
2360 J : constant Index_Type := Container.Last;
2361 X : Element_Access := Container.Elements.EA (J);
2364 Container.Elements.EA (J) := null;
2365 Container.Last := J - 1;
2373 if Length > Capacity (Container) then
2374 Reserve_Capacity (Container, Capacity => Length);
2378 Last_As_Int : constant Int'Base :=
2379 Int (Index_Type'First) + Int (Length) - 1;
2382 Container.Last := Index_Type (Last_As_Int);
2391 (Container : in out Vector;
2395 if I > Container.Last then
2396 raise Constraint_Error with "I index is out of range";
2399 if J > Container.Last then
2400 raise Constraint_Error with "J index is out of range";
2407 if Container.Lock > 0 then
2408 raise Program_Error with
2409 "attempt to tamper with cursors (vector is locked)";
2413 EI : Element_Access renames Container.Elements.EA (I);
2414 EJ : Element_Access renames Container.Elements.EA (J);
2416 EI_Copy : constant Element_Access := EI;
2425 (Container : in out Vector;
2429 if I.Container = null then
2430 raise Constraint_Error with "I cursor has no element";
2433 if J.Container = null then
2434 raise Constraint_Error with "J cursor has no element";
2437 if I.Container /= Container'Unrestricted_Access then
2438 raise Program_Error with "I cursor denotes wrong container";
2441 if J.Container /= Container'Unrestricted_Access then
2442 raise Program_Error with "J cursor denotes wrong container";
2445 Swap (Container, I.Index, J.Index);
2453 (Container : Vector;
2454 Index : Extended_Index) return Cursor
2457 if Index not in Index_Type'First .. Container.Last then
2461 return Cursor'(Container
'Unchecked_Access, Index
);
2468 function To_Index
(Position
: Cursor
) return Extended_Index
is
2470 if Position
.Container
= null then
2474 if Position
.Index
<= Position
.Container
.Last
then
2475 return Position
.Index
;
2485 function To_Vector
(Length
: Count_Type
) return Vector
is
2488 return Empty_Vector
;
2492 First
: constant Int
:= Int
(Index_Type
'First);
2493 Last_As_Int
: constant Int
'Base := First
+ Int
(Length
) - 1;
2495 Elements
: Elements_Access
;
2498 if Last_As_Int
> Index_Type
'Pos (Index_Type
'Last) then
2499 raise Constraint_Error
with "Length is out of range";
2502 Last
:= Index_Type
(Last_As_Int
);
2503 Elements
:= new Elements_Type
(Last
);
2505 return (Controlled
with Elements
, Last
, 0, 0);
2510 (New_Item
: Element_Type
;
2511 Length
: Count_Type
) return Vector
2515 return Empty_Vector
;
2519 First
: constant Int
:= Int
(Index_Type
'First);
2520 Last_As_Int
: constant Int
'Base := First
+ Int
(Length
) - 1;
2521 Last
: Index_Type
'Base;
2522 Elements
: Elements_Access
;
2525 if Last_As_Int
> Index_Type
'Pos (Index_Type
'Last) then
2526 raise Constraint_Error
with "Length is out of range";
2529 Last
:= Index_Type
(Last_As_Int
);
2530 Elements
:= new Elements_Type
(Last
);
2532 Last
:= Index_Type
'First;
2536 Elements
.EA
(Last
) := new Element_Type
'(New_Item);
2537 exit when Last = Elements.Last;
2543 for J in Index_Type'First .. Last - 1 loop
2544 Free (Elements.EA (J));
2551 return (Controlled with Elements, Last, 0, 0);
2555 --------------------
2556 -- Update_Element --
2557 --------------------
2559 procedure Update_Element
2560 (Container : in out Vector;
2562 Process : not null access procedure (Element : in out Element_Type))
2564 B : Natural renames Container.Busy;
2565 L : Natural renames Container.Lock;
2568 if Index > Container.Last then
2569 raise Constraint_Error with "Index is out of range";
2572 if Container.Elements.EA (Index) = null then
2573 raise Constraint_Error with "element is null";
2580 Process (Container.Elements.EA (Index).all);
2592 procedure Update_Element
2593 (Container : in out Vector;
2595 Process : not null access procedure (Element : in out Element_Type))
2598 if Position.Container = null then
2599 raise Constraint_Error with "Position cursor has no element";
2602 if Position.Container /= Container'Unrestricted_Access then
2603 raise Program_Error with "Position cursor denotes wrong container";
2606 Update_Element (Container, Position.Index, Process);
2614 (Stream : not null access Root_Stream_Type'Class;
2617 N : constant Count_Type := Length (Container);
2620 Count_Type'Base'Write
(Stream
, N
);
2627 E
: Elements_Array
renames Container
.Elements
.EA
;
2630 for Indx
in Index_Type
'First .. Container
.Last
loop
2631 if E
(Indx
) = null then
2632 Boolean'Write (Stream
, False);
2634 Boolean'Write (Stream
, True);
2635 Element_Type
'Output (Stream
, E
(Indx
).all);
2642 (Stream
: not null access Root_Stream_Type
'Class;
2646 raise Program_Error
with "attempt to stream vector cursor";
2649 end Ada
.Containers
.Indefinite_Vectors
;