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-2005 Free Software Foundation, Inc. --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the contents of the part following the private keyword. --
15 -- GNAT is free software; you can redistribute it and/or modify it under --
16 -- terms of the GNU General Public License as published by the Free Soft- --
17 -- ware Foundation; either version 2, or (at your option) any later ver- --
18 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
21 -- for more details. You should have received a copy of the GNU General --
22 -- Public License distributed with GNAT; see file COPYING. If not, write --
23 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
24 -- Boston, MA 02110-1301, USA. --
26 -- As a special exception, if other files instantiate generics from this --
27 -- unit, or you link this unit with other files to produce an executable, --
28 -- this unit does not by itself cause the resulting executable to be --
29 -- covered by the GNU General Public License. This exception does not --
30 -- however invalidate any other reasons why the executable file might be --
31 -- covered by the GNU Public License. --
33 -- This unit was originally developed by Matthew J Heaney. --
34 ------------------------------------------------------------------------------
36 with Ada.Containers.Generic_Array_Sort;
37 with Ada.Unchecked_Deallocation;
39 with System; use type System.Address;
41 package body Ada.Containers.Vectors is
43 type Int is range System.Min_Int .. System.Max_Int;
46 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
52 function "&" (Left, Right : Vector) return Vector is
53 LN : constant Count_Type := Length (Left);
54 RN : constant Count_Type := Length (Right);
63 RE : Elements_Type renames
64 Right.Elements (Index_Type'First .. Right.Last);
66 Elements : constant Elements_Access :=
67 new Elements_Type'(RE);
70 return (Controlled with Elements, Right.Last, 0, 0);
76 LE : Elements_Type renames
77 Left.Elements (Index_Type'First .. Left.Last);
79 Elements : constant Elements_Access :=
80 new Elements_Type'(LE);
83 return (Controlled with Elements, Left.Last, 0, 0);
89 Last_As_Int : constant Int'Base := -- TODO: handle overflow
90 Int (Index_Type'First) + Int (LN) + Int (RN) - 1;
93 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
94 raise Constraint_Error;
98 Last : constant Index_Type := Index_Type (Last_As_Int);
100 LE : Elements_Type renames
101 Left.Elements (Index_Type'First .. Left.Last);
103 RE : Elements_Type renames
104 Right.Elements (Index_Type'First .. Right.Last);
106 Elements : constant Elements_Access :=
107 new Elements_Type'(LE & RE);
110 return (Controlled with Elements, Last, 0, 0);
115 function "&" (Left : Vector; Right : Element_Type) return Vector is
116 LN : constant Count_Type := Length (Left);
121 subtype Elements_Subtype is
122 Elements_Type (Index_Type'First .. Index_Type'First);
124 Elements : constant Elements_Access :=
125 new Elements_Subtype'(others => Right);
128 return (Controlled with Elements, Index_Type'First, 0, 0);
133 Last_As_Int : constant Int'Base := -- TODO: handle overflow
134 Int (Index_Type'First) + Int (LN);
137 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
138 raise Constraint_Error;
142 Last : constant Index_Type := Index_Type (Last_As_Int);
144 LE : Elements_Type renames
145 Left.Elements (Index_Type'First .. Left.Last);
147 subtype ET is Elements_Type (Index_Type'First .. Last);
149 Elements : constant Elements_Access := new ET'(LE & Right);
152 return (Controlled with Elements, Last, 0, 0);
157 function "&" (Left : Element_Type; Right : Vector) return Vector is
158 RN : constant Count_Type := Length (Right);
163 subtype Elements_Subtype is
164 Elements_Type (Index_Type'First .. Index_Type'First);
166 Elements : constant Elements_Access :=
167 new Elements_Subtype'(others => Left);
170 return (Controlled with Elements, Index_Type'First, 0, 0);
175 Last_As_Int : constant Int'Base := -- TODO: handle overflow
176 Int (Index_Type'First) + Int (RN);
179 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
180 raise Constraint_Error;
184 Last : constant Index_Type := Index_Type (Last_As_Int);
186 RE : Elements_Type renames
187 Right.Elements (Index_Type'First .. Right.Last);
189 subtype ET is Elements_Type (Index_Type'First .. Last);
191 Elements : constant Elements_Access := new ET'(Left & RE);
194 return (Controlled with Elements, Last, 0, 0);
199 function "&" (Left, Right : Element_Type) return Vector is
201 if Index_Type'First >= Index_Type'Last then
202 raise Constraint_Error;
206 Last : constant Index_Type := Index_Type'First + 1;
208 subtype ET is Elements_Type (Index_Type'First .. Last);
210 Elements : constant Elements_Access := new ET'(Left, Right);
213 return (Controlled with Elements, Last, 0, 0);
221 function "=" (Left, Right : Vector) return Boolean is
223 if Left'Address = Right'Address then
227 if Left.Last /= Right.Last then
231 for J in Index_Type range Index_Type'First .. Left.Last loop
232 if Left.Elements (J) /= Right.Elements (J) then
244 procedure Adjust (Container : in out Vector) is
246 if Container.Last = No_Index then
247 Container.Elements := null;
252 E : constant Elements_Access := Container.Elements;
253 L : constant Index_Type := Container.Last;
256 Container.Elements := null;
257 Container.Last := No_Index;
260 Container.Elements := new Elements_Type'(E (Index_Type'First .. L));
269 procedure Append (Container : in out Vector; New_Item : Vector) is
271 if Is_Empty (New_Item) then
275 if Container.Last = Index_Type'Last then
276 raise Constraint_Error;
286 (Container : in out Vector;
287 New_Item : Element_Type;
288 Count : Count_Type := 1)
295 if Container.Last = Index_Type'Last then
296 raise Constraint_Error;
311 (Target : in out Vector;
314 N : constant Count_Type := Length (Source);
317 if Target'Address = Source'Address then
327 if N > Capacity (Target) then
328 Reserve_Capacity (Target, Capacity => N);
331 Target.Elements (Index_Type'First .. Source.Last) :=
332 Source.Elements (Index_Type'First .. Source.Last);
334 Target.Last := Source.Last;
341 function Capacity (Container : Vector) return Count_Type is
343 if Container.Elements = null then
347 return Container.Elements'Length;
354 procedure Clear (Container : in out Vector) is
356 if Container.Busy > 0 then
360 Container.Last := No_Index;
369 Item : Element_Type) return Boolean
372 return Find_Index (Container, Item) /= No_Index;
380 (Container : in out Vector;
381 Index : Extended_Index;
382 Count : Count_Type := 1)
385 if Index < Index_Type'First then
386 raise Constraint_Error;
389 if Index > Container.Last then
390 if Index > Container.Last + 1 then
391 raise Constraint_Error;
401 if Container.Busy > 0 then
406 I_As_Int : constant Int := Int (Index);
407 Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
409 Count1 : constant Int'Base := Count_Type'Pos (Count);
410 Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
411 N : constant Int'Base := Int'Min (Count1, Count2);
413 J_As_Int : constant Int'Base := I_As_Int + N;
416 if J_As_Int > Old_Last_As_Int then
417 Container.Last := Index - 1;
421 J : constant Index_Type := Index_Type (J_As_Int);
422 E : Elements_Type renames Container.Elements.all;
424 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
425 New_Last : constant Index_Type :=
426 Index_Type (New_Last_As_Int);
429 E (Index .. New_Last) := E (J .. Container.Last);
430 Container.Last := New_Last;
437 (Container : in out Vector;
438 Position : in out Cursor;
439 Count : Count_Type := 1)
442 if Position.Container = null then
443 raise Constraint_Error;
446 if Position.Container /=
447 Vector_Access'(Container'Unchecked_Access)
448 or else Position.Index > Container.Last
453 Delete (Container, Position.Index, Count);
455 if Position.Index <= Container.Last then
456 Position := (Container'Unchecked_Access, Position.Index);
458 Position := No_Element;
466 procedure Delete_First
467 (Container : in out Vector;
468 Count : Count_Type := 1)
475 if Count >= Length (Container) then
480 Delete (Container, Index_Type'First, Count);
487 procedure Delete_Last
488 (Container : in out Vector;
489 Count : Count_Type := 1)
498 if Container.Busy > 0 then
502 Index := Int'Base (Container.Last) - Int'Base (Count);
504 if Index < Index_Type'Pos (Index_Type'First) then
505 Container.Last := No_Index;
507 Container.Last := Index_Type (Index);
517 Index : Index_Type) return Element_Type
520 if Index > Container.Last then
521 raise Constraint_Error;
524 return Container.Elements (Index);
527 function Element (Position : Cursor) return Element_Type is
529 if Position.Container = null then
530 raise Constraint_Error;
533 return Element (Position.Container.all, Position.Index);
540 procedure Finalize (Container : in out Vector) is
541 X : Elements_Access := Container.Elements;
543 if Container.Busy > 0 then
547 Container.Elements := null;
548 Container.Last := No_Index;
559 Position : Cursor := No_Element) return Cursor is
562 if Position.Container /= null
563 and then (Position.Container /=
564 Vector_Access'(Container'Unchecked_Access)
565 or else Position.Index > Container.Last)
570 for J in Position.Index .. Container.Last loop
571 if Container.Elements (J) = Item then
572 return (Container'Unchecked_Access, J);
586 Index : Index_Type := Index_Type'First) return Extended_Index is
588 for Indx in Index .. Container.Last loop
589 if Container.Elements (Indx) = Item then
601 function First (Container : Vector) return Cursor is
603 if Is_Empty (Container) then
607 return (Container'Unchecked_Access, Index_Type'First);
614 function First_Element (Container : Vector) return Element_Type is
616 return Element (Container, Index_Type'First);
623 function First_Index (Container : Vector) return Index_Type is
624 pragma Unreferenced (Container);
626 return Index_Type'First;
629 ---------------------
630 -- Generic_Sorting --
631 ---------------------
633 package body Generic_Sorting is
639 function Is_Sorted (Container : Vector) return Boolean is
641 if Container.Last <= Index_Type'First then
646 E : Elements_Type renames Container.Elements.all;
648 for I in Index_Type'First .. Container.Last - 1 loop
649 if E (I + 1) < E (I) then
662 procedure Merge (Target, Source : in out Vector) is
663 I : Index_Type'Base := Target.Last;
667 if Target.Last < Index_Type'First then
668 Move (Target => Target, Source => Source);
672 if Target'Address = Source'Address then
676 if Source.Last < Index_Type'First then
680 if Source.Busy > 0 then
684 Target.Set_Length (Length (Target) + Length (Source));
687 while Source.Last >= Index_Type'First loop
688 if I < Index_Type'First then
689 Target.Elements (Index_Type'First .. J) :=
690 Source.Elements (Index_Type'First .. Source.Last);
692 Source.Last := No_Index;
696 if Source.Elements (Source.Last) < Target.Elements (I) then
697 Target.Elements (J) := Target.Elements (I);
701 Target.Elements (J) := Source.Elements (Source.Last);
702 Source.Last := Source.Last - 1;
713 procedure Sort (Container : in out Vector)
716 new Generic_Array_Sort
717 (Index_Type => Index_Type,
718 Element_Type => Element_Type,
719 Array_Type => Elements_Type,
723 if Container.Last <= Index_Type'First then
727 if Container.Lock > 0 then
731 Sort (Container.Elements (Index_Type'First .. Container.Last));
740 function Has_Element (Position : Cursor) return Boolean is
742 if Position.Container = null then
746 return Position.Index <= Position.Container.Last;
754 (Container : in out Vector;
755 Before : Extended_Index;
756 New_Item : Element_Type;
757 Count : Count_Type := 1)
759 N : constant Int := Count_Type'Pos (Count);
761 New_Last_As_Int : Int'Base;
762 New_Last : Index_Type;
764 Dst : Elements_Access;
767 if Before < Index_Type'First then
768 raise Constraint_Error;
771 if Before > Container.Last
772 and then Before > Container.Last + 1
774 raise Constraint_Error;
782 Old_Last : constant Extended_Index := Container.Last;
784 Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);
787 New_Last_As_Int := Old_Last_As_Int + N;
789 if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then
790 raise Constraint_Error;
793 New_Last := Index_Type (New_Last_As_Int);
796 if Container.Busy > 0 then
800 if Container.Elements = null then
802 subtype Elements_Subtype is
803 Elements_Type (Index_Type'First .. New_Last);
805 Container.Elements := new Elements_Subtype'(others => New_Item);
808 Container.Last := New_Last;
812 if New_Last <= Container.Elements'Last then
814 E : Elements_Type renames Container.Elements.all;
816 if Before <= Container.Last then
818 Index_As_Int : constant Int'Base :=
819 Index_Type'Pos (Before) + N;
821 Index : constant Index_Type := Index_Type (Index_As_Int);
824 E (Index .. New_Last) := E (Before .. Container.Last);
826 E (Before .. Index_Type'Pred (Index)) :=
827 (others => New_Item);
831 E (Before .. New_Last) := (others => New_Item);
835 Container.Last := New_Last;
840 First : constant Int := Int (Index_Type'First);
841 New_Size : constant Int'Base := New_Last_As_Int - First + 1;
842 Size : Int'Base := Int'Max (1, Container.Elements'Length);
845 while Size < New_Size loop
846 if Size > Int'Last / 2 then
854 -- TODO: The following calculations aren't quite right, since
855 -- there will be overflow if Index_Type'Range is very large
856 -- (e.g. this package is instantiated with a 64-bit integer).
860 Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
862 if Size > Max_Size then
868 Dst_Last : constant Index_Type := Index_Type (First + Size - 1);
870 Dst := new Elements_Type (Index_Type'First .. Dst_Last);
875 Src : Elements_Type renames Container.Elements.all;
878 Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
879 Src (Index_Type'First .. Index_Type'Pred (Before));
881 if Before <= Container.Last then
883 Index_As_Int : constant Int'Base :=
884 Index_Type'Pos (Before) + N;
886 Index : constant Index_Type := Index_Type (Index_As_Int);
889 Dst (Before .. Index_Type'Pred (Index)) := (others => New_Item);
890 Dst (Index .. New_Last) := Src (Before .. Container.Last);
894 Dst (Before .. New_Last) := (others => New_Item);
903 X : Elements_Access := Container.Elements;
905 Container.Elements := Dst;
906 Container.Last := New_Last;
912 (Container : in out Vector;
913 Before : Extended_Index;
916 N : constant Count_Type := Length (New_Item);
919 if Before < Index_Type'First then
920 raise Constraint_Error;
923 if Before > Container.Last
924 and then Before > Container.Last + 1
926 raise Constraint_Error;
933 Insert_Space (Container, Before, Count => N);
936 Dst_Last_As_Int : constant Int'Base :=
937 Int'Base (Before) + Int'Base (N) - 1;
939 Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
942 if Container'Address /= New_Item'Address then
943 Container.Elements (Before .. Dst_Last) :=
944 New_Item.Elements (Index_Type'First .. New_Item.Last);
950 subtype Src_Index_Subtype is Index_Type'Base range
951 Index_Type'First .. Before - 1;
953 Src : Elements_Type renames
954 Container.Elements (Src_Index_Subtype);
956 Index_As_Int : constant Int'Base :=
957 Int (Before) + Src'Length - 1;
959 Index : constant Index_Type'Base :=
960 Index_Type'Base (Index_As_Int);
962 Dst : Elements_Type renames
963 Container.Elements (Before .. Index);
969 if Dst_Last = Container.Last then
974 subtype Src_Index_Subtype is Index_Type'Base range
975 Dst_Last + 1 .. Container.Last;
977 Src : Elements_Type renames
978 Container.Elements (Src_Index_Subtype);
980 Index_As_Int : constant Int'Base :=
981 Dst_Last_As_Int - Src'Length + 1;
983 Index : constant Index_Type :=
984 Index_Type (Index_As_Int);
986 Dst : Elements_Type renames
987 Container.Elements (Index .. Dst_Last);
996 (Container : in out Vector;
1000 Index : Index_Type'Base;
1003 if Before.Container /= null
1004 and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1006 raise Program_Error;
1009 if Is_Empty (New_Item) then
1013 if Before.Container = null
1014 or else Before.Index > Container.Last
1016 if Container.Last = Index_Type'Last then
1017 raise Constraint_Error;
1020 Index := Container.Last + 1;
1023 Index := Before.Index;
1026 Insert (Container, Index, New_Item);
1030 (Container : in out Vector;
1033 Position : out Cursor)
1035 Index : Index_Type'Base;
1038 if Before.Container /= null
1039 and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1041 raise Program_Error;
1044 if Is_Empty (New_Item) then
1045 if Before.Container = null
1046 or else Before.Index > Container.Last
1048 Position := No_Element;
1050 Position := (Container'Unchecked_Access, Before.Index);
1056 if Before.Container = null
1057 or else Before.Index > Container.Last
1059 if Container.Last = Index_Type'Last then
1060 raise Constraint_Error;
1063 Index := Container.Last + 1;
1066 Index := Before.Index;
1069 Insert (Container, Index, New_Item);
1071 Position := Cursor'(Container'Unchecked_Access, Index);
1075 (Container : in out Vector;
1077 New_Item : Element_Type;
1078 Count : Count_Type := 1)
1080 Index : Index_Type'Base;
1083 if Before.Container /= null
1084 and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1086 raise Program_Error;
1093 if Before.Container = null
1094 or else Before.Index > Container.Last
1096 if Container.Last = Index_Type'Last then
1097 raise Constraint_Error;
1100 Index := Container.Last + 1;
1103 Index := Before.Index;
1106 Insert (Container, Index, New_Item, Count);
1110 (Container : in out Vector;
1112 New_Item : Element_Type;
1113 Position : out Cursor;
1114 Count : Count_Type := 1)
1116 Index : Index_Type'Base;
1119 if Before.Container /= null
1120 and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1122 raise Program_Error;
1126 if Before.Container = null
1127 or else Before.Index > Container.Last
1129 Position := No_Element;
1131 Position := (Container'Unchecked_Access, Before.Index);
1137 if Before.Container = null
1138 or else Before.Index > Container.Last
1140 if Container.Last = Index_Type'Last then
1141 raise Constraint_Error;
1144 Index := Container.Last + 1;
1147 Index := Before.Index;
1150 Insert (Container, Index, New_Item, Count);
1152 Position := Cursor'(Container'Unchecked_Access, Index);
1159 procedure Insert_Space
1160 (Container : in out Vector;
1161 Before : Extended_Index;
1162 Count : Count_Type := 1)
1164 N : constant Int := Count_Type'Pos (Count);
1166 New_Last_As_Int : Int'Base;
1167 New_Last : Index_Type;
1169 Dst : Elements_Access;
1172 if Before < Index_Type'First then
1173 raise Constraint_Error;
1176 if Before > Container.Last
1177 and then Before > Container.Last + 1
1179 raise Constraint_Error;
1187 Old_Last : constant Extended_Index := Container.Last;
1189 Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);
1192 New_Last_As_Int := Old_Last_As_Int + N;
1194 if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1195 raise Constraint_Error;
1198 New_Last := Index_Type (New_Last_As_Int);
1201 if Container.Busy > 0 then
1202 raise Program_Error;
1205 if Container.Elements = null then
1206 Container.Elements :=
1207 new Elements_Type (Index_Type'First .. New_Last);
1209 Container.Last := New_Last;
1213 if New_Last <= Container.Elements'Last then
1215 E : Elements_Type renames Container.Elements.all;
1217 if Before <= Container.Last then
1219 Index_As_Int : constant Int'Base :=
1220 Index_Type'Pos (Before) + N;
1222 Index : constant Index_Type := Index_Type (Index_As_Int);
1225 E (Index .. New_Last) := E (Before .. Container.Last);
1230 Container.Last := New_Last;
1235 First : constant Int := Int (Index_Type'First);
1236 New_Size : constant Int'Base := New_Last_As_Int - First + 1;
1237 Size : Int'Base := Int'Max (1, Container.Elements'Length);
1240 while Size < New_Size loop
1241 if Size > Int'Last / 2 then
1249 -- TODO: The following calculations aren't quite right, since
1250 -- there will be overflow if Index_Type'Range is very large
1251 -- (e.g. this package is instantiated with a 64-bit integer).
1255 Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1;
1257 if Size > Max_Size then
1263 Dst_Last : constant Index_Type := Index_Type (First + Size - 1);
1265 Dst := new Elements_Type (Index_Type'First .. Dst_Last);
1270 Src : Elements_Type renames Container.Elements.all;
1273 Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
1274 Src (Index_Type'First .. Index_Type'Pred (Before));
1276 if Before <= Container.Last then
1278 Index_As_Int : constant Int'Base :=
1279 Index_Type'Pos (Before) + N;
1281 Index : constant Index_Type := Index_Type (Index_As_Int);
1284 Dst (Index .. New_Last) := Src (Before .. Container.Last);
1294 X : Elements_Access := Container.Elements;
1296 Container.Elements := Dst;
1297 Container.Last := New_Last;
1302 procedure Insert_Space
1303 (Container : in out Vector;
1305 Position : out Cursor;
1306 Count : Count_Type := 1)
1308 Index : Index_Type'Base;
1311 if Before.Container /= null
1312 and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1314 raise Program_Error;
1318 if Before.Container = null
1319 or else Before.Index > Container.Last
1321 Position := No_Element;
1323 Position := (Container'Unchecked_Access, Before.Index);
1329 if Before.Container = null
1330 or else Before.Index > Container.Last
1332 if Container.Last = Index_Type'Last then
1333 raise Constraint_Error;
1336 Index := Container.Last + 1;
1339 Index := Before.Index;
1342 Insert_Space (Container, Index, Count);
1344 Position := Cursor'(Container'Unchecked_Access, Index);
1351 function Is_Empty (Container : Vector) return Boolean is
1353 return Container.Last < Index_Type'First;
1361 (Container : Vector;
1362 Process : not null access procedure (Position : Cursor))
1364 V : Vector renames Container'Unrestricted_Access.all;
1365 B : Natural renames V.Busy;
1372 for Indx in Index_Type'First .. Container.Last loop
1373 Process (Cursor'(Container'Unchecked_Access, Indx));
1389 function Last (Container : Vector) return Cursor is
1391 if Is_Empty (Container) then
1395 return (Container'Unchecked_Access, Container.Last);
1402 function Last_Element (Container : Vector) return Element_Type is
1404 return Element (Container, Container.Last);
1411 function Last_Index (Container : Vector) return Extended_Index is
1413 return Container.Last;
1420 function Length (Container : Vector) return Count_Type is
1421 L : constant Int := Int (Container.Last);
1422 F : constant Int := Int (Index_Type'First);
1423 N : constant Int'Base := L - F + 1;
1426 if N > Count_Type'Pos (Count_Type'Last) then
1427 raise Constraint_Error;
1430 return Count_Type (N);
1438 (Target : in out Vector;
1439 Source : in out Vector)
1442 if Target'Address = Source'Address then
1446 if Target.Busy > 0 then
1447 raise Program_Error;
1450 if Source.Busy > 0 then
1451 raise Program_Error;
1455 Target_Elements : constant Elements_Access := Target.Elements;
1457 Target.Elements := Source.Elements;
1458 Source.Elements := Target_Elements;
1461 Target.Last := Source.Last;
1462 Source.Last := No_Index;
1469 function Next (Position : Cursor) return Cursor is
1471 if Position.Container = null then
1475 if Position.Index < Position.Container.Last then
1476 return (Position.Container, Position.Index + 1);
1486 procedure Next (Position : in out Cursor) is
1488 if Position.Container = null then
1492 if Position.Index < Position.Container.Last then
1493 Position.Index := Position.Index + 1;
1495 Position := No_Element;
1503 procedure Prepend (Container : in out Vector; New_Item : Vector) is
1505 Insert (Container, Index_Type'First, New_Item);
1509 (Container : in out Vector;
1510 New_Item : Element_Type;
1511 Count : Count_Type := 1)
1524 procedure Previous (Position : in out Cursor) is
1526 if Position.Container = null then
1530 if Position.Index > Index_Type'First then
1531 Position.Index := Position.Index - 1;
1533 Position := No_Element;
1537 function Previous (Position : Cursor) return Cursor is
1539 if Position.Container = null then
1543 if Position.Index > Index_Type'First then
1544 return (Position.Container, Position.Index - 1);
1554 procedure Query_Element
1555 (Container : Vector;
1557 Process : not null access procedure (Element : Element_Type))
1559 V : Vector renames Container'Unrestricted_Access.all;
1560 B : Natural renames V.Busy;
1561 L : Natural renames V.Lock;
1564 if Index > Container.Last then
1565 raise Constraint_Error;
1572 Process (V.Elements (Index));
1584 procedure Query_Element
1586 Process : not null access procedure (Element : Element_Type))
1589 if Position.Container = null then
1590 raise Constraint_Error;
1593 Query_Element (Position.Container.all, Position.Index, Process);
1601 (Stream : access Root_Stream_Type'Class;
1602 Container : out Vector)
1604 Length : Count_Type'Base;
1605 Last : Index_Type'Base := No_Index;
1610 Count_Type'Base'Read (Stream, Length);
1612 if Length > Capacity (Container) then
1613 Reserve_Capacity (Container, Capacity => Length);
1616 for J in Count_Type range 1 .. Length loop
1618 Element_Type'Read (Stream, Container.Elements (Last));
1619 Container.Last := Last;
1623 ---------------------
1624 -- Replace_Element --
1625 ---------------------
1627 procedure Replace_Element
1628 (Container : Vector;
1633 if Index > Container.Last then
1634 raise Constraint_Error;
1637 if Container.Lock > 0 then
1638 raise Program_Error;
1641 Container.Elements (Index) := By;
1642 end Replace_Element;
1644 procedure Replace_Element (Position : Cursor; By : Element_Type) is
1646 if Position.Container = null then
1647 raise Constraint_Error;
1650 Replace_Element (Position.Container.all, Position.Index, By);
1651 end Replace_Element;
1653 ----------------------
1654 -- Reserve_Capacity --
1655 ----------------------
1657 procedure Reserve_Capacity
1658 (Container : in out Vector;
1659 Capacity : Count_Type)
1661 N : constant Count_Type := Length (Container);
1664 if Capacity = 0 then
1667 X : Elements_Access := Container.Elements;
1669 Container.Elements := null;
1673 elsif N < Container.Elements'Length then
1674 if Container.Busy > 0 then
1675 raise Program_Error;
1679 subtype Array_Index_Subtype is Index_Type'Base range
1680 Index_Type'First .. Container.Last;
1682 Src : Elements_Type renames
1683 Container.Elements (Array_Index_Subtype);
1685 subtype Array_Subtype is
1686 Elements_Type (Array_Index_Subtype);
1688 X : Elements_Access := Container.Elements;
1691 Container.Elements := new Array_Subtype'(Src);
1699 if Container.Elements = null then
1701 Last_As_Int : constant Int'Base :=
1702 Int (Index_Type'First) + Int (Capacity) - 1;
1705 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1706 raise Constraint_Error;
1710 Last : constant Index_Type := Index_Type (Last_As_Int);
1712 subtype Array_Subtype is
1713 Elements_Type (Index_Type'First .. Last);
1715 Container.Elements := new Array_Subtype;
1722 if Capacity <= N then
1723 if N < Container.Elements'Length then
1724 if Container.Busy > 0 then
1725 raise Program_Error;
1729 subtype Array_Index_Subtype is Index_Type'Base range
1730 Index_Type'First .. Container.Last;
1732 Src : Elements_Type renames
1733 Container.Elements (Array_Index_Subtype);
1735 subtype Array_Subtype is
1736 Elements_Type (Array_Index_Subtype);
1738 X : Elements_Access := Container.Elements;
1741 Container.Elements := new Array_Subtype'(Src);
1750 if Capacity = Container.Elements'Length then
1754 if Container.Busy > 0 then
1755 raise Program_Error;
1759 Last_As_Int : constant Int'Base :=
1760 Int (Index_Type'First) + Int (Capacity) - 1;
1763 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1764 raise Constraint_Error;
1768 Last : constant Index_Type := Index_Type (Last_As_Int);
1770 subtype Array_Subtype is
1771 Elements_Type (Index_Type'First .. Last);
1773 E : Elements_Access := new Array_Subtype;
1777 Src : Elements_Type renames
1778 Container.Elements (Index_Type'First .. Container.Last);
1780 Tgt : Elements_Type renames
1781 E (Index_Type'First .. Container.Last);
1793 X : Elements_Access := Container.Elements;
1795 Container.Elements := E;
1800 end Reserve_Capacity;
1806 function Reverse_Find
1807 (Container : Vector;
1808 Item : Element_Type;
1809 Position : Cursor := No_Element) return Cursor
1811 Last : Index_Type'Base;
1814 if Position.Container /= null
1815 and then Position.Container /=
1816 Vector_Access'(Container'Unchecked_Access)
1818 raise Program_Error;
1821 if Position.Container = null
1822 or else Position.Index > Container.Last
1824 Last := Container.Last;
1826 Last := Position.Index;
1829 for Indx in reverse Index_Type'First .. Last loop
1830 if Container.Elements (Indx) = Item then
1831 return (Container'Unchecked_Access, Indx);
1838 ------------------------
1839 -- Reverse_Find_Index --
1840 ------------------------
1842 function Reverse_Find_Index
1843 (Container : Vector;
1844 Item : Element_Type;
1845 Index : Index_Type := Index_Type'Last) return Extended_Index
1847 Last : Index_Type'Base;
1850 if Index > Container.Last then
1851 Last := Container.Last;
1856 for Indx in reverse Index_Type'First .. Last loop
1857 if Container.Elements (Indx) = Item then
1863 end Reverse_Find_Index;
1865 ---------------------
1866 -- Reverse_Iterate --
1867 ---------------------
1869 procedure Reverse_Iterate
1870 (Container : Vector;
1871 Process : not null access procedure (Position : Cursor))
1873 V : Vector renames Container'Unrestricted_Access.all;
1874 B : Natural renames V.Busy;
1881 for Indx in reverse Index_Type'First .. Container.Last loop
1882 Process (Cursor'(Container'Unchecked_Access, Indx));
1892 end Reverse_Iterate;
1898 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
1900 if Length = Vectors.Length (Container) then
1904 if Container.Busy > 0 then
1905 raise Program_Error;
1908 if Length > Capacity (Container) then
1909 Reserve_Capacity (Container, Capacity => Length);
1913 Last_As_Int : constant Int'Base :=
1914 Int (Index_Type'First) + Int (Length) - 1;
1916 Container.Last := Index_Type'Base (Last_As_Int);
1924 procedure Swap (Container : Vector; I, J : Index_Type) is
1926 if I > Container.Last
1927 or else J > Container.Last
1929 raise Constraint_Error;
1936 if Container.Lock > 0 then
1937 raise Program_Error;
1941 EI : Element_Type renames Container.Elements (I);
1942 EJ : Element_Type renames Container.Elements (J);
1944 EI_Copy : constant Element_Type := EI;
1952 procedure Swap (I, J : Cursor) is
1954 if I.Container = null
1955 or else J.Container = null
1957 raise Constraint_Error;
1960 if I.Container /= J.Container then
1961 raise Program_Error;
1964 Swap (I.Container.all, I.Index, J.Index);
1972 (Container : Vector;
1973 Index : Extended_Index) return Cursor
1976 if Index not in Index_Type'First .. Container.Last then
1980 return Cursor'(Container'Unchecked_Access, Index);
1987 function To_Index (Position : Cursor) return Extended_Index is
1989 if Position.Container = null then
1993 if Position.Index <= Position.Container.Last then
1994 return Position.Index;
2004 function To_Vector (Length : Count_Type) return Vector is
2007 return Empty_Vector;
2011 First : constant Int := Int (Index_Type'First);
2012 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2014 Elements : Elements_Access;
2017 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2018 raise Constraint_Error;
2021 Last := Index_Type (Last_As_Int);
2022 Elements := new Elements_Type (Index_Type'First .. Last);
2024 return (Controlled with Elements, Last, 0, 0);
2029 (New_Item : Element_Type;
2030 Length : Count_Type) return Vector
2034 return Empty_Vector;
2038 First : constant Int := Int (Index_Type'First);
2039 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2041 Elements : Elements_Access;
2044 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2045 raise Constraint_Error;
2048 Last := Index_Type (Last_As_Int);
2049 Elements := new Elements_Type'(Index_Type'First .. Last => New_Item);
2051 return (Controlled with Elements, Last, 0, 0);
2055 --------------------
2056 -- Update_Element --
2057 --------------------
2059 procedure Update_Element
2060 (Container : Vector;
2062 Process : not null access procedure (Element : in out Element_Type))
2064 V : Vector renames Container'Unrestricted_Access.all;
2065 B : Natural renames V.Busy;
2066 L : Natural renames V.Lock;
2069 if Index > Container.Last then
2070 raise Constraint_Error;
2077 Process (V.Elements (Index));
2089 procedure Update_Element
2091 Process : not null access procedure (Element : in out Element_Type))
2094 if Position.Container = null then
2095 raise Constraint_Error;
2098 Update_Element (Position.Container.all, Position.Index, Process);
2106 (Stream : access Root_Stream_Type'Class;
2110 Count_Type'Base'Write (Stream, Length (Container));
2112 for J in Index_Type'First .. Container.Last loop
2113 Element_Type'Write (Stream, Container.Elements (J));
2117 end Ada.Containers.Vectors;