1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . V E C T O R S --
9 -- Copyright (C) 2004-2009, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Containers
.Generic_Array_Sort
;
31 with Ada
.Unchecked_Deallocation
;
33 with System
; use type System
.Address
;
35 package body Ada
.Containers
.Vectors
is
37 type Int
is range System
.Min_Int
.. System
.Max_Int
;
38 type UInt
is mod System
.Max_Binary_Modulus
;
41 new Ada
.Unchecked_Deallocation
(Elements_Type
, Elements_Access
);
47 function "&" (Left
, Right
: Vector
) return Vector
is
48 LN
: constant Count_Type
:= Length
(Left
);
49 RN
: constant Count_Type
:= Length
(Right
);
58 RE
: Elements_Array
renames
59 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
61 Elements
: constant Elements_Access
:=
62 new Elements_Type
'(Right.Last, RE);
65 return (Controlled with Elements, Right.Last, 0, 0);
71 LE : Elements_Array renames
72 Left.Elements.EA (Index_Type'First .. Left.Last);
74 Elements : constant Elements_Access :=
75 new Elements_Type'(Left
.Last
, LE
);
78 return (Controlled
with Elements
, Left
.Last
, 0, 0);
84 N
: constant Int
'Base := Int
(LN
) + Int
(RN
);
85 Last_As_Int
: Int
'Base;
88 if Int
(No_Index
) > Int
'Last - N
then
89 raise Constraint_Error
with "new length is out of range";
92 Last_As_Int
:= Int
(No_Index
) + N
;
94 if Last_As_Int
> Int
(Index_Type
'Last) then
95 raise Constraint_Error
with "new length is out of range";
99 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
101 LE
: Elements_Array
renames
102 Left
.Elements
.EA
(Index_Type
'First .. Left
.Last
);
104 RE
: Elements_Array
renames
105 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
107 Elements
: constant Elements_Access
:=
108 new Elements_Type
'(Last, LE & RE);
111 return (Controlled with Elements, Last, 0, 0);
116 function "&" (Left : Vector; Right : Element_Type) return Vector is
117 LN : constant Count_Type := Length (Left);
122 Elements : constant Elements_Access :=
124 (Last
=> Index_Type
'First,
125 EA
=> (others => Right
));
128 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
133 Last_As_Int
: Int
'Base;
136 if Int
(Index_Type
'First) > Int
'Last - Int
(LN
) then
137 raise Constraint_Error
with "new length is out of range";
140 Last_As_Int
:= Int
(Index_Type
'First) + Int
(LN
);
142 if Last_As_Int
> Int
(Index_Type
'Last) then
143 raise Constraint_Error
with "new length is out of range";
147 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
149 LE
: Elements_Array
renames
150 Left
.Elements
.EA
(Index_Type
'First .. Left
.Last
);
152 Elements
: constant Elements_Access
:=
158 return (Controlled with Elements, Last, 0, 0);
163 function "&" (Left : Element_Type; Right : Vector) return Vector is
164 RN : constant Count_Type := Length (Right);
169 Elements : constant Elements_Access :=
171 (Last
=> Index_Type
'First,
172 EA
=> (others => Left
));
175 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
180 Last_As_Int
: Int
'Base;
183 if Int
(Index_Type
'First) > Int
'Last - Int
(RN
) then
184 raise Constraint_Error
with "new length is out of range";
187 Last_As_Int
:= Int
(Index_Type
'First) + Int
(RN
);
189 if Last_As_Int
> Int
(Index_Type
'Last) then
190 raise Constraint_Error
with "new length is out of range";
194 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
196 RE
: Elements_Array
renames
197 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
199 Elements
: constant Elements_Access
:=
205 return (Controlled with Elements, Last, 0, 0);
210 function "&" (Left, Right : Element_Type) return Vector is
212 if Index_Type'First >= Index_Type'Last then
213 raise Constraint_Error with "new length is out of range";
217 Last : constant Index_Type := Index_Type'First + 1;
219 Elements : constant Elements_Access :=
222 EA
=> (Left
, Right
));
225 return (Controlled
with Elements
, Last
, 0, 0);
233 overriding
function "=" (Left
, Right
: Vector
) return Boolean is
235 if Left
'Address = Right
'Address then
239 if Left
.Last
/= Right
.Last
then
243 for J
in Index_Type
range Index_Type
'First .. Left
.Last
loop
244 if Left
.Elements
.EA
(J
) /= Right
.Elements
.EA
(J
) then
256 procedure Adjust
(Container
: in out Vector
) is
258 if Container
.Last
= No_Index
then
259 Container
.Elements
:= null;
264 L
: constant Index_Type
:= Container
.Last
;
265 EA
: Elements_Array
renames
266 Container
.Elements
.EA
(Index_Type
'First .. L
);
269 Container
.Elements
:= null;
273 -- Note: it may seem that the following assignment to Container.Last
274 -- is useless, since we assign it to L below. However this code is
275 -- used in case 'new Elements_Type' below raises an exception, to
276 -- keep Container in a consistent state.
278 Container
.Last
:= No_Index
;
279 Container
.Elements
:= new Elements_Type
'(L, EA);
288 procedure Append (Container : in out Vector; New_Item : Vector) is
290 if Is_Empty (New_Item) then
294 if Container.Last = Index_Type'Last then
295 raise Constraint_Error with "vector is already at its maximum length";
305 (Container : in out Vector;
306 New_Item : Element_Type;
307 Count : Count_Type := 1)
314 if Container.Last = Index_Type'Last then
315 raise Constraint_Error with "vector is already at its maximum length";
329 function Capacity (Container : Vector) return Count_Type is
331 if Container.Elements = null then
335 return Container.Elements.EA'Length;
342 procedure Clear (Container : in out Vector) is
344 if Container.Busy > 0 then
345 raise Program_Error with
346 "attempt to tamper with elements (vector is busy)";
349 Container.Last := No_Index;
358 Item : Element_Type) return Boolean
361 return Find_Index (Container, Item) /= No_Index;
369 (Container : in out Vector;
370 Index : Extended_Index;
371 Count : Count_Type := 1)
374 if Index < Index_Type'First then
375 raise Constraint_Error with "Index is out of range (too small)";
378 if Index > Container.Last then
379 if Index > Container.Last + 1 then
380 raise Constraint_Error with "Index is out of range (too large)";
390 if Container.Busy > 0 then
391 raise Program_Error with
392 "attempt to tamper with elements (vector is busy)";
396 I_As_Int : constant Int := Int (Index);
397 Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
399 Count1 : constant Int'Base := Count_Type'Pos (Count);
400 Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
401 N : constant Int'Base := Int'Min (Count1, Count2);
403 J_As_Int : constant Int'Base := I_As_Int + N;
406 if J_As_Int > Old_Last_As_Int then
407 Container.Last := Index - 1;
411 J : constant Index_Type := Index_Type (J_As_Int);
412 EA : Elements_Array renames Container.Elements.EA;
414 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
415 New_Last : constant Index_Type :=
416 Index_Type (New_Last_As_Int);
419 EA (Index .. New_Last) := EA (J .. Container.Last);
420 Container.Last := New_Last;
427 (Container : in out Vector;
428 Position : in out Cursor;
429 Count : Count_Type := 1)
431 pragma Warnings (Off, Position);
434 if Position.Container = null then
435 raise Constraint_Error with "Position cursor has no element";
438 if Position.Container /= Container'Unrestricted_Access then
439 raise Program_Error with "Position cursor denotes wrong container";
442 if Position.Index > Container.Last then
443 raise Program_Error with "Position index is out of range";
446 Delete (Container, Position.Index, Count);
447 Position := No_Element;
454 procedure Delete_First
455 (Container : in out Vector;
456 Count : Count_Type := 1)
463 if Count >= Length (Container) then
468 Delete (Container, Index_Type'First, Count);
475 procedure Delete_Last
476 (Container : in out Vector;
477 Count : Count_Type := 1)
486 if Container.Busy > 0 then
487 raise Program_Error with
488 "attempt to tamper with elements (vector is busy)";
491 Index := Int'Base (Container.Last) - Int'Base (Count);
494 (if Index < Index_Type'Pos (Index_Type'First)
496 else Index_Type (Index));
505 Index : Index_Type) return Element_Type
508 if Index > Container.Last then
509 raise Constraint_Error with "Index is out of range";
512 return Container.Elements.EA (Index);
515 function Element (Position : Cursor) return Element_Type is
517 if Position.Container = null then
518 raise Constraint_Error with "Position cursor has no element";
521 if Position.Index > Position.Container.Last then
522 raise Constraint_Error with "Position cursor is out of range";
525 return Position.Container.Elements.EA (Position.Index);
532 procedure Finalize (Container : in out Vector) is
533 X : Elements_Access := Container.Elements;
536 if Container.Busy > 0 then
537 raise Program_Error with
538 "attempt to tamper with elements (vector is busy)";
541 Container.Elements := null;
542 Container.Last := No_Index;
553 Position : Cursor := No_Element) return Cursor
556 if Position.Container /= null then
557 if Position.Container /= Container'Unrestricted_Access then
558 raise Program_Error with "Position cursor denotes wrong container";
561 if Position.Index > Container.Last then
562 raise Program_Error with "Position index is out of range";
566 for J in Position.Index .. Container.Last loop
567 if Container.Elements.EA (J) = Item then
568 return (Container'Unchecked_Access, J);
582 Index : Index_Type := Index_Type'First) return Extended_Index
585 for Indx in Index .. Container.Last loop
586 if Container.Elements.EA (Indx) = Item then
598 function First (Container : Vector) return Cursor is
600 if Is_Empty (Container) then
604 return (Container'Unchecked_Access, Index_Type'First);
611 function First_Element (Container : Vector) return Element_Type is
613 if Container.Last = No_Index then
614 raise Constraint_Error with "Container is empty";
617 return Container.Elements.EA (Index_Type'First);
624 function First_Index (Container : Vector) return Index_Type is
625 pragma Unreferenced (Container);
627 return Index_Type'First;
630 ---------------------
631 -- Generic_Sorting --
632 ---------------------
634 package body Generic_Sorting is
640 function Is_Sorted (Container : Vector) return Boolean is
642 if Container.Last <= Index_Type'First then
647 EA : Elements_Array renames Container.Elements.EA;
649 for I in Index_Type'First .. Container.Last - 1 loop
650 if EA (I + 1) < EA (I) then
663 procedure Merge (Target, Source : in out Vector) is
664 I : Index_Type'Base := Target.Last;
668 if Target.Last < Index_Type'First then
669 Move (Target => Target, Source => Source);
673 if Target'Address = Source'Address then
677 if Source.Last < Index_Type'First then
681 if Source.Busy > 0 then
682 raise Program_Error with
683 "attempt to tamper with elements (vector is busy)";
686 Target.Set_Length (Length (Target) + Length (Source));
689 TA : Elements_Array renames Target.Elements.EA;
690 SA : Elements_Array renames Source.Elements.EA;
694 while Source.Last >= Index_Type'First loop
695 pragma Assert (Source.Last <= Index_Type'First
696 or else not (SA (Source.Last) <
697 SA (Source.Last - 1)));
699 if I < Index_Type'First then
700 TA (Index_Type'First .. J) :=
701 SA (Index_Type'First .. Source.Last);
703 Source.Last := No_Index;
707 pragma Assert (I <= Index_Type'First
708 or else not (TA (I) < TA (I - 1)));
710 if SA (Source.Last) < TA (I) then
715 TA (J) := SA (Source.Last);
716 Source.Last := Source.Last - 1;
728 procedure Sort (Container : in out Vector)
731 new Generic_Array_Sort
732 (Index_Type => Index_Type,
733 Element_Type => Element_Type,
734 Array_Type => Elements_Array,
738 if Container.Last <= Index_Type'First then
742 if Container.Lock > 0 then
743 raise Program_Error with
744 "attempt to tamper with cursors (vector is locked)";
747 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
756 function Has_Element (Position : Cursor) return Boolean is
758 if Position.Container = null then
762 return Position.Index <= Position.Container.Last;
770 (Container : in out Vector;
771 Before : Extended_Index;
772 New_Item : Element_Type;
773 Count : Count_Type := 1)
775 N : constant Int := Count_Type'Pos (Count);
777 First : constant Int := Int (Index_Type'First);
778 New_Last_As_Int : Int'Base;
779 New_Last : Index_Type;
781 Max_Length : constant UInt := UInt (Count_Type'Last);
783 Dst : Elements_Access;
786 if Before < Index_Type'First then
787 raise Constraint_Error with
788 "Before index is out of range (too small)";
791 if Before > Container.Last
792 and then Before > Container.Last + 1
794 raise Constraint_Error with
795 "Before index is out of range (too large)";
803 Old_Last_As_Int : constant Int := Int (Container.Last);
806 if Old_Last_As_Int > Int'Last - N then
807 raise Constraint_Error with "new length is out of range";
810 New_Last_As_Int := Old_Last_As_Int + N;
812 if New_Last_As_Int > Int (Index_Type'Last) then
813 raise Constraint_Error with "new length is out of range";
816 New_Length := UInt (New_Last_As_Int - First + Int'(1));
818 if New_Length
> Max_Length
then
819 raise Constraint_Error
with "new length is out of range";
822 New_Last
:= Index_Type
(New_Last_As_Int
);
825 if Container
.Busy
> 0 then
826 raise Program_Error
with
827 "attempt to tamper with elements (vector is busy)";
830 if Container
.Elements
= null then
831 Container
.Elements
:= new Elements_Type
'
833 EA => (others => New_Item));
834 Container.Last := New_Last;
838 if New_Last <= Container.Elements.Last then
840 EA : Elements_Array renames Container.Elements.EA;
843 if Before <= Container.Last then
845 Index_As_Int : constant Int'Base :=
846 Index_Type'Pos (Before) + N;
848 Index : constant Index_Type := Index_Type (Index_As_Int);
851 EA (Index .. New_Last) := EA (Before .. Container.Last);
853 EA (Before .. Index_Type'Pred (Index)) :=
854 (others => New_Item);
858 EA (Before .. New_Last) := (others => New_Item);
862 Container.Last := New_Last;
870 C := UInt'Max (1, Container.Elements.EA'Length); -- ???
871 while C < New_Length loop
872 if C > UInt'Last / 2 then
880 if C > Max_Length then
884 if Index_Type'First <= 0
885 and then Index_Type'Last >= 0
887 CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
889 CC := UInt (Int (Index_Type'Last) - First + 1);
897 Dst_Last : constant Index_Type :=
898 Index_Type (First + UInt'Pos (C) - 1);
901 Dst := new Elements_Type (Dst_Last);
906 SA : Elements_Array renames Container.Elements.EA;
907 DA : Elements_Array renames Dst.EA;
910 DA (Index_Type'First .. Index_Type'Pred (Before)) :=
911 SA (Index_Type'First .. Index_Type'Pred (Before));
913 if Before <= Container.Last then
915 Index_As_Int : constant Int'Base :=
916 Index_Type'Pos (Before) + N;
918 Index : constant Index_Type := Index_Type (Index_As_Int);
921 DA (Before .. Index_Type'Pred (Index)) := (others => New_Item);
922 DA (Index .. New_Last) := SA (Before .. Container.Last);
926 DA (Before .. New_Last) := (others => New_Item);
935 X : Elements_Access := Container.Elements;
937 Container.Elements := Dst;
938 Container.Last := New_Last;
944 (Container : in out Vector;
945 Before : Extended_Index;
948 N : constant Count_Type := Length (New_Item);
951 if Before < Index_Type'First then
952 raise Constraint_Error with
953 "Before index is out of range (too small)";
956 if Before > Container.Last
957 and then Before > Container.Last + 1
959 raise Constraint_Error with
960 "Before index is out of range (too large)";
967 Insert_Space (Container, Before, Count => N);
970 Dst_Last_As_Int : constant Int'Base :=
971 Int'Base (Before) + Int'Base (N) - 1;
973 Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
976 if Container'Address /= New_Item'Address then
977 Container.Elements.EA (Before .. Dst_Last) :=
978 New_Item.Elements.EA (Index_Type'First .. New_Item.Last);
984 subtype Src_Index_Subtype is Index_Type'Base range
985 Index_Type'First .. Before - 1;
987 Src : Elements_Array renames
988 Container.Elements.EA (Src_Index_Subtype);
990 Index_As_Int : constant Int'Base :=
991 Int (Before) + Src'Length - 1;
993 Index : constant Index_Type'Base :=
994 Index_Type'Base (Index_As_Int);
996 Dst : Elements_Array renames
997 Container.Elements.EA (Before .. Index);
1003 if Dst_Last = Container.Last then
1008 subtype Src_Index_Subtype is Index_Type'Base range
1009 Dst_Last + 1 .. Container.Last;
1011 Src : Elements_Array renames
1012 Container.Elements.EA (Src_Index_Subtype);
1014 Index_As_Int : constant Int'Base :=
1015 Dst_Last_As_Int - Src'Length + 1;
1017 Index : constant Index_Type :=
1018 Index_Type (Index_As_Int);
1020 Dst : Elements_Array renames
1021 Container.Elements.EA (Index .. Dst_Last);
1030 (Container : in out Vector;
1034 Index : Index_Type'Base;
1037 if Before.Container /= null
1038 and then Before.Container /= Container'Unchecked_Access
1040 raise Program_Error with "Before cursor denotes wrong container";
1043 if Is_Empty (New_Item) then
1047 if Before.Container = null
1048 or else Before.Index > Container.Last
1050 if Container.Last = Index_Type'Last then
1051 raise Constraint_Error with
1052 "vector is already at its maximum length";
1055 Index := Container.Last + 1;
1058 Index := Before.Index;
1061 Insert (Container, Index, New_Item);
1065 (Container : in out Vector;
1068 Position : out Cursor)
1070 Index : Index_Type'Base;
1073 if Before.Container /= null
1074 and then Before.Container /= Container'Unchecked_Access
1076 raise Program_Error with "Before cursor denotes wrong container";
1079 if Is_Empty (New_Item) then
1080 if Before.Container = null
1081 or else Before.Index > Container.Last
1083 Position := No_Element;
1085 Position := (Container'Unchecked_Access, Before.Index);
1091 if Before.Container = null
1092 or else Before.Index > Container.Last
1094 if Container.Last = Index_Type'Last then
1095 raise Constraint_Error with
1096 "vector is already at its maximum length";
1099 Index := Container.Last + 1;
1102 Index := Before.Index;
1105 Insert (Container, Index, New_Item);
1107 Position := Cursor'(Container
'Unchecked_Access, Index
);
1111 (Container
: in out Vector
;
1113 New_Item
: Element_Type
;
1114 Count
: Count_Type
:= 1)
1116 Index
: Index_Type
'Base;
1119 if Before
.Container
/= null
1120 and then Before
.Container
/= Container
'Unchecked_Access
1122 raise Program_Error
with "Before cursor denotes wrong container";
1129 if Before
.Container
= null
1130 or else Before
.Index
> Container
.Last
1132 if Container
.Last
= Index_Type
'Last then
1133 raise Constraint_Error
with
1134 "vector is already at its maximum length";
1137 Index
:= Container
.Last
+ 1;
1140 Index
:= Before
.Index
;
1143 Insert
(Container
, Index
, New_Item
, Count
);
1147 (Container
: in out Vector
;
1149 New_Item
: Element_Type
;
1150 Position
: out Cursor
;
1151 Count
: Count_Type
:= 1)
1153 Index
: Index_Type
'Base;
1156 if Before
.Container
/= null
1157 and then Before
.Container
/= Container
'Unchecked_Access
1159 raise Program_Error
with "Before cursor denotes wrong container";
1163 if Before
.Container
= null
1164 or else Before
.Index
> Container
.Last
1166 Position
:= No_Element
;
1168 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1174 if Before
.Container
= null
1175 or else Before
.Index
> Container
.Last
1177 if Container
.Last
= Index_Type
'Last then
1178 raise Constraint_Error
with
1179 "vector is already at its maximum length";
1182 Index
:= Container
.Last
+ 1;
1185 Index
:= Before
.Index
;
1188 Insert
(Container
, Index
, New_Item
, Count
);
1190 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1194 (Container : in out Vector;
1195 Before : Extended_Index;
1196 Count : Count_Type := 1)
1198 New_Item : Element_Type; -- Default-initialized value
1199 pragma Warnings (Off, New_Item);
1202 Insert (Container, Before, New_Item, Count);
1206 (Container : in out Vector;
1208 Position : out Cursor;
1209 Count : Count_Type := 1)
1211 New_Item : Element_Type; -- Default-initialized value
1212 pragma Warnings (Off, New_Item);
1215 Insert (Container, Before, New_Item, Position, Count);
1222 procedure Insert_Space
1223 (Container : in out Vector;
1224 Before : Extended_Index;
1225 Count : Count_Type := 1)
1227 N : constant Int := Count_Type'Pos (Count);
1229 First : constant Int := Int (Index_Type'First);
1230 New_Last_As_Int : Int'Base;
1231 New_Last : Index_Type;
1233 Max_Length : constant UInt := UInt (Count_Type'Last);
1235 Dst : Elements_Access;
1238 if Before < Index_Type'First then
1239 raise Constraint_Error with
1240 "Before index is out of range (too small)";
1243 if Before > Container.Last
1244 and then Before > Container.Last + 1
1246 raise Constraint_Error with
1247 "Before index is out of range (too large)";
1255 Old_Last_As_Int : constant Int := Int (Container.Last);
1258 if Old_Last_As_Int > Int'Last - N then
1259 raise Constraint_Error with "new length is out of range";
1262 New_Last_As_Int := Old_Last_As_Int + N;
1264 if New_Last_As_Int > Int (Index_Type'Last) then
1265 raise Constraint_Error with "new length is out of range";
1268 New_Length := UInt (New_Last_As_Int - First + Int'(1));
1270 if New_Length
> Max_Length
then
1271 raise Constraint_Error
with "new length is out of range";
1274 New_Last
:= Index_Type
(New_Last_As_Int
);
1277 if Container
.Busy
> 0 then
1278 raise Program_Error
with
1279 "attempt to tamper with elements (vector is busy)";
1282 if Container
.Elements
= null then
1283 Container
.Elements
:= new Elements_Type
(New_Last
);
1284 Container
.Last
:= New_Last
;
1288 if New_Last
<= Container
.Elements
.Last
then
1290 EA
: Elements_Array
renames Container
.Elements
.EA
;
1292 if Before
<= Container
.Last
then
1294 Index_As_Int
: constant Int
'Base :=
1295 Index_Type
'Pos (Before
) + N
;
1297 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1300 EA
(Index
.. New_Last
) := EA
(Before
.. Container
.Last
);
1305 Container
.Last
:= New_Last
;
1313 C
:= UInt
'Max (1, Container
.Elements
.EA
'Length); -- ???
1314 while C
< New_Length
loop
1315 if C
> UInt
'Last / 2 then
1323 if C
> Max_Length
then
1327 if Index_Type
'First <= 0
1328 and then Index_Type
'Last >= 0
1330 CC
:= UInt
(Index_Type
'Last) + UInt
(-Index_Type
'First) + 1;
1332 CC
:= UInt
(Int
(Index_Type
'Last) - First
+ 1);
1340 Dst_Last
: constant Index_Type
:=
1341 Index_Type
(First
+ UInt
'Pos (C
) - 1);
1344 Dst
:= new Elements_Type
(Dst_Last
);
1349 SA
: Elements_Array
renames Container
.Elements
.EA
;
1350 DA
: Elements_Array
renames Dst
.EA
;
1353 DA
(Index_Type
'First .. Index_Type
'Pred (Before
)) :=
1354 SA
(Index_Type
'First .. Index_Type
'Pred (Before
));
1356 if Before
<= Container
.Last
then
1358 Index_As_Int
: constant Int
'Base :=
1359 Index_Type
'Pos (Before
) + N
;
1361 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1364 DA
(Index
.. New_Last
) := SA
(Before
.. Container
.Last
);
1374 X
: Elements_Access
:= Container
.Elements
;
1376 Container
.Elements
:= Dst
;
1377 Container
.Last
:= New_Last
;
1382 procedure Insert_Space
1383 (Container
: in out Vector
;
1385 Position
: out Cursor
;
1386 Count
: Count_Type
:= 1)
1388 Index
: Index_Type
'Base;
1391 if Before
.Container
/= null
1392 and then Before
.Container
/= Container
'Unchecked_Access
1394 raise Program_Error
with "Before cursor denotes wrong container";
1398 if Before
.Container
= null
1399 or else Before
.Index
> Container
.Last
1401 Position
:= No_Element
;
1403 Position
:= (Container
'Unchecked_Access, Before
.Index
);
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_Space
(Container
, Index
, Count
=> Count
);
1425 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1432 function Is_Empty (Container : Vector) return Boolean is
1434 return Container.Last < Index_Type'First;
1442 (Container : Vector;
1443 Process : not null access procedure (Position : Cursor))
1445 V : Vector renames Container'Unrestricted_Access.all;
1446 B : Natural renames V.Busy;
1452 for Indx in Index_Type'First .. Container.Last loop
1453 Process (Cursor'(Container
'Unchecked_Access, Indx
));
1468 function Last
(Container
: Vector
) return Cursor
is
1470 if Is_Empty
(Container
) then
1474 return (Container
'Unchecked_Access, Container
.Last
);
1481 function Last_Element
(Container
: Vector
) return Element_Type
is
1483 if Container
.Last
= No_Index
then
1484 raise Constraint_Error
with "Container is empty";
1487 return Container
.Elements
.EA
(Container
.Last
);
1494 function Last_Index
(Container
: Vector
) return Extended_Index
is
1496 return Container
.Last
;
1503 function Length
(Container
: Vector
) return Count_Type
is
1504 L
: constant Int
:= Int
(Container
.Last
);
1505 F
: constant Int
:= Int
(Index_Type
'First);
1506 N
: constant Int
'Base := L
- F
+ 1;
1509 return Count_Type
(N
);
1517 (Target
: in out Vector
;
1518 Source
: in out Vector
)
1521 if Target
'Address = Source
'Address then
1525 if Target
.Busy
> 0 then
1526 raise Program_Error
with
1527 "attempt to tamper with elements (Target is busy)";
1530 if Source
.Busy
> 0 then
1531 raise Program_Error
with
1532 "attempt to tamper with elements (Source is busy)";
1536 Target_Elements
: constant Elements_Access
:= Target
.Elements
;
1538 Target
.Elements
:= Source
.Elements
;
1539 Source
.Elements
:= Target_Elements
;
1542 Target
.Last
:= Source
.Last
;
1543 Source
.Last
:= No_Index
;
1550 function Next
(Position
: Cursor
) return Cursor
is
1552 if Position
.Container
= null then
1556 if Position
.Index
< Position
.Container
.Last
then
1557 return (Position
.Container
, Position
.Index
+ 1);
1567 procedure Next
(Position
: in out Cursor
) is
1569 if Position
.Container
= null then
1573 if Position
.Index
< Position
.Container
.Last
then
1574 Position
.Index
:= Position
.Index
+ 1;
1576 Position
:= No_Element
;
1584 procedure Prepend
(Container
: in out Vector
; New_Item
: Vector
) is
1586 Insert
(Container
, Index_Type
'First, New_Item
);
1590 (Container
: in out Vector
;
1591 New_Item
: Element_Type
;
1592 Count
: Count_Type
:= 1)
1605 procedure Previous
(Position
: in out Cursor
) is
1607 if Position
.Container
= null then
1611 if Position
.Index
> Index_Type
'First then
1612 Position
.Index
:= Position
.Index
- 1;
1614 Position
:= No_Element
;
1618 function Previous
(Position
: Cursor
) return Cursor
is
1620 if Position
.Container
= null then
1624 if Position
.Index
> Index_Type
'First then
1625 return (Position
.Container
, Position
.Index
- 1);
1635 procedure Query_Element
1636 (Container
: Vector
;
1638 Process
: not null access procedure (Element
: Element_Type
))
1640 V
: Vector
renames Container
'Unrestricted_Access.all;
1641 B
: Natural renames V
.Busy
;
1642 L
: Natural renames V
.Lock
;
1645 if Index
> Container
.Last
then
1646 raise Constraint_Error
with "Index is out of range";
1653 Process
(V
.Elements
.EA
(Index
));
1665 procedure Query_Element
1667 Process
: not null access procedure (Element
: Element_Type
))
1670 if Position
.Container
= null then
1671 raise Constraint_Error
with "Position cursor has no element";
1674 Query_Element
(Position
.Container
.all, Position
.Index
, Process
);
1682 (Stream
: not null access Root_Stream_Type
'Class;
1683 Container
: out Vector
)
1685 Length
: Count_Type
'Base;
1686 Last
: Index_Type
'Base := No_Index
;
1691 Count_Type
'Base'Read (Stream, Length);
1693 if Length > Capacity (Container) then
1694 Reserve_Capacity (Container, Capacity => Length);
1697 for J in Count_Type range 1 .. Length loop
1699 Element_Type'Read (Stream, Container.Elements.EA (Last));
1700 Container.Last := Last;
1705 (Stream : not null access Root_Stream_Type'Class;
1706 Position : out Cursor)
1709 raise Program_Error with "attempt to stream vector cursor";
1712 ---------------------
1713 -- Replace_Element --
1714 ---------------------
1716 procedure Replace_Element
1717 (Container : in out Vector;
1719 New_Item : Element_Type)
1722 if Index > Container.Last then
1723 raise Constraint_Error with "Index is out of range";
1726 if Container.Lock > 0 then
1727 raise Program_Error with
1728 "attempt to tamper with cursors (vector is locked)";
1731 Container.Elements.EA (Index) := New_Item;
1732 end Replace_Element;
1734 procedure Replace_Element
1735 (Container : in out Vector;
1737 New_Item : Element_Type)
1740 if Position.Container = null then
1741 raise Constraint_Error with "Position cursor has no element";
1744 if Position.Container /= Container'Unrestricted_Access then
1745 raise Program_Error with "Position cursor denotes wrong container";
1748 if Position.Index > Container.Last then
1749 raise Constraint_Error with "Position cursor is out of range";
1752 if Container.Lock > 0 then
1753 raise Program_Error with
1754 "attempt to tamper with cursors (vector is locked)";
1757 Container.Elements.EA (Position.Index) := New_Item;
1758 end Replace_Element;
1760 ----------------------
1761 -- Reserve_Capacity --
1762 ----------------------
1764 procedure Reserve_Capacity
1765 (Container : in out Vector;
1766 Capacity : Count_Type)
1768 N : constant Count_Type := Length (Container);
1771 if Capacity = 0 then
1774 X : Elements_Access := Container.Elements;
1776 Container.Elements := null;
1780 elsif N < Container.Elements.EA'Length then
1781 if Container.Busy > 0 then
1782 raise Program_Error with
1783 "attempt to tamper with elements (vector is busy)";
1787 subtype Src_Index_Subtype is Index_Type'Base range
1788 Index_Type'First .. Container.Last;
1790 Src : Elements_Array renames
1791 Container.Elements.EA (Src_Index_Subtype);
1793 X : Elements_Access := Container.Elements;
1796 Container.Elements := new Elements_Type'(Container
.Last
, Src
);
1804 if Container
.Elements
= null then
1806 Last_As_Int
: constant Int
'Base :=
1807 Int
(Index_Type
'First) + Int
(Capacity
) - 1;
1810 if Last_As_Int
> Index_Type
'Pos (Index_Type
'Last) then
1811 raise Constraint_Error
with "new length is out of range";
1815 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
1818 Container
.Elements
:= new Elements_Type
(Last
);
1825 if Capacity
<= N
then
1826 if N
< Container
.Elements
.EA
'Length then
1827 if Container
.Busy
> 0 then
1828 raise Program_Error
with
1829 "attempt to tamper with elements (vector is busy)";
1833 subtype Src_Index_Subtype
is Index_Type
'Base range
1834 Index_Type
'First .. Container
.Last
;
1836 Src
: Elements_Array
renames
1837 Container
.Elements
.EA
(Src_Index_Subtype
);
1839 X
: Elements_Access
:= Container
.Elements
;
1842 Container
.Elements
:= new Elements_Type
'(Container.Last, Src);
1851 if Capacity = Container.Elements.EA'Length then
1855 if Container.Busy > 0 then
1856 raise Program_Error with
1857 "attempt to tamper with elements (vector is busy)";
1861 Last_As_Int : constant Int'Base :=
1862 Int (Index_Type'First) + Int (Capacity) - 1;
1865 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1866 raise Constraint_Error with "new length is out of range";
1870 Last : constant Index_Type := Index_Type (Last_As_Int);
1872 E : Elements_Access := new Elements_Type (Last);
1876 subtype Index_Subtype is Index_Type'Base range
1877 Index_Type'First .. Container.Last;
1879 Src : Elements_Array renames
1880 Container.Elements.EA (Index_Subtype);
1882 Tgt : Elements_Array renames E.EA (Index_Subtype);
1894 X : Elements_Access := Container.Elements;
1896 Container.Elements := E;
1901 end Reserve_Capacity;
1903 ----------------------
1904 -- Reverse_Elements --
1905 ----------------------
1907 procedure Reverse_Elements (Container : in out Vector) is
1909 if Container.Length <= 1 then
1913 if Container.Lock > 0 then
1914 raise Program_Error with
1915 "attempt to tamper with cursors (vector is locked)";
1920 E : Elements_Type renames Container.Elements.all;
1923 I := Index_Type'First;
1924 J := Container.Last;
1927 EI : constant Element_Type := E.EA (I);
1930 E.EA (I) := E.EA (J);
1938 end Reverse_Elements;
1944 function Reverse_Find
1945 (Container : Vector;
1946 Item : Element_Type;
1947 Position : Cursor := No_Element) return Cursor
1949 Last : Index_Type'Base;
1952 if Position.Container /= null
1953 and then Position.Container /= Container'Unchecked_Access
1955 raise Program_Error with "Position cursor denotes wrong container";
1959 (if Position.Container = null or else Position.Index > Container.Last
1961 else Position.Index);
1963 for Indx in reverse Index_Type'First .. Last loop
1964 if Container.Elements.EA (Indx) = Item then
1965 return (Container'Unchecked_Access, Indx);
1972 ------------------------
1973 -- Reverse_Find_Index --
1974 ------------------------
1976 function Reverse_Find_Index
1977 (Container : Vector;
1978 Item : Element_Type;
1979 Index : Index_Type := Index_Type'Last) return Extended_Index
1981 Last : constant Index_Type'Base :=
1982 Index_Type'Min (Container.Last, Index);
1985 for Indx in reverse Index_Type'First .. Last loop
1986 if Container.Elements.EA (Indx) = Item then
1992 end Reverse_Find_Index;
1994 ---------------------
1995 -- Reverse_Iterate --
1996 ---------------------
1998 procedure Reverse_Iterate
1999 (Container : Vector;
2000 Process : not null access procedure (Position : Cursor))
2002 V : Vector renames Container'Unrestricted_Access.all;
2003 B : Natural renames V.Busy;
2009 for Indx in reverse Index_Type'First .. Container.Last loop
2010 Process (Cursor'(Container
'Unchecked_Access, Indx
));
2019 end Reverse_Iterate
;
2025 procedure Set_Length
(Container
: in out Vector
; Length
: Count_Type
) is
2027 if Length
= Vectors
.Length
(Container
) then
2031 if Container
.Busy
> 0 then
2032 raise Program_Error
with
2033 "attempt to tamper with elements (vector is busy)";
2036 if Length
> Capacity
(Container
) then
2037 Reserve_Capacity
(Container
, Capacity
=> Length
);
2041 Last_As_Int
: constant Int
'Base :=
2042 Int
(Index_Type
'First) + Int
(Length
) - 1;
2044 Container
.Last
:= Index_Type
'Base (Last_As_Int
);
2052 procedure Swap
(Container
: in out Vector
; I
, J
: Index_Type
) is
2054 if I
> Container
.Last
then
2055 raise Constraint_Error
with "I index is out of range";
2058 if J
> Container
.Last
then
2059 raise Constraint_Error
with "J index is out of range";
2066 if Container
.Lock
> 0 then
2067 raise Program_Error
with
2068 "attempt to tamper with cursors (vector is locked)";
2072 EI_Copy
: constant Element_Type
:= Container
.Elements
.EA
(I
);
2074 Container
.Elements
.EA
(I
) := Container
.Elements
.EA
(J
);
2075 Container
.Elements
.EA
(J
) := EI_Copy
;
2079 procedure Swap
(Container
: in out Vector
; I
, J
: Cursor
) is
2081 if I
.Container
= null then
2082 raise Constraint_Error
with "I cursor has no element";
2085 if J
.Container
= null then
2086 raise Constraint_Error
with "J cursor has no element";
2089 if I
.Container
/= Container
'Unrestricted_Access then
2090 raise Program_Error
with "I cursor denotes wrong container";
2093 if J
.Container
/= Container
'Unrestricted_Access then
2094 raise Program_Error
with "J cursor denotes wrong container";
2097 Swap
(Container
, I
.Index
, J
.Index
);
2105 (Container
: Vector
;
2106 Index
: Extended_Index
) return Cursor
2109 if Index
not in Index_Type
'First .. Container
.Last
then
2113 return Cursor
'(Container'Unchecked_Access, Index);
2120 function To_Index (Position : Cursor) return Extended_Index is
2122 if Position.Container = null then
2126 if Position.Index <= Position.Container.Last then
2127 return Position.Index;
2137 function To_Vector (Length : Count_Type) return Vector is
2140 return Empty_Vector;
2144 First : constant Int := Int (Index_Type'First);
2145 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2147 Elements : Elements_Access;
2150 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2151 raise Constraint_Error with "Length is out of range";
2154 Last := Index_Type (Last_As_Int);
2155 Elements := new Elements_Type (Last);
2157 return Vector'(Controlled
with Elements
, Last
, 0, 0);
2162 (New_Item
: Element_Type
;
2163 Length
: Count_Type
) return Vector
2167 return Empty_Vector
;
2171 First
: constant Int
:= Int
(Index_Type
'First);
2172 Last_As_Int
: constant Int
'Base := First
+ Int
(Length
) - 1;
2174 Elements
: Elements_Access
;
2177 if Last_As_Int
> Index_Type
'Pos (Index_Type
'Last) then
2178 raise Constraint_Error
with "Length is out of range";
2181 Last
:= Index_Type
(Last_As_Int
);
2182 Elements
:= new Elements_Type
'(Last, EA => (others => New_Item));
2184 return Vector'(Controlled
with Elements
, Last
, 0, 0);
2188 --------------------
2189 -- Update_Element --
2190 --------------------
2192 procedure Update_Element
2193 (Container
: in out Vector
;
2195 Process
: not null access procedure (Element
: in out Element_Type
))
2197 B
: Natural renames Container
.Busy
;
2198 L
: Natural renames Container
.Lock
;
2201 if Index
> Container
.Last
then
2202 raise Constraint_Error
with "Index is out of range";
2209 Process
(Container
.Elements
.EA
(Index
));
2221 procedure Update_Element
2222 (Container
: in out Vector
;
2224 Process
: not null access procedure (Element
: in out Element_Type
))
2227 if Position
.Container
= null then
2228 raise Constraint_Error
with "Position cursor has no element";
2231 if Position
.Container
/= Container
'Unrestricted_Access then
2232 raise Program_Error
with "Position cursor denotes wrong container";
2235 Update_Element
(Container
, Position
.Index
, Process
);
2243 (Stream
: not null access Root_Stream_Type
'Class;
2247 Count_Type
'Base'Write (Stream, Length (Container));
2249 for J in Index_Type'First .. Container.Last loop
2250 Element_Type'Write (Stream, Container.Elements.EA (J));
2255 (Stream : not null access Root_Stream_Type'Class;
2259 raise Program_Error with "attempt to stream vector cursor";
2262 end Ada.Containers.Vectors;