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-2006 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- This unit was originally developed by Matthew J Heaney. --
30 ------------------------------------------------------------------------------
32 with Ada.Containers.Generic_Array_Sort;
33 with Ada.Unchecked_Deallocation;
35 with System; use type System.Address;
37 package body Ada.Containers.Vectors is
39 type Int is range System.Min_Int .. System.Max_Int;
40 type UInt is mod System.Max_Binary_Modulus;
43 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
49 function "&" (Left, Right : Vector) return Vector is
50 LN : constant Count_Type := Length (Left);
51 RN : constant Count_Type := Length (Right);
60 RE : Elements_Type renames
61 Right.Elements (Index_Type'First .. Right.Last);
63 Elements : constant Elements_Access :=
64 new Elements_Type'(RE);
67 return (Controlled with Elements, Right.Last, 0, 0);
73 LE : Elements_Type renames
74 Left.Elements (Index_Type'First .. Left.Last);
76 Elements : constant Elements_Access :=
77 new Elements_Type'(LE);
80 return (Controlled with Elements, Left.Last, 0, 0);
86 N : constant Int'Base := Int (LN) + Int (RN);
87 Last_As_Int : Int'Base;
90 if Int (No_Index) > Int'Last - N then
91 raise Constraint_Error with "new length is out of range";
94 Last_As_Int := Int (No_Index) + N;
96 if Last_As_Int > Int (Index_Type'Last) then
97 raise Constraint_Error with "new length is out of range";
101 Last : constant Index_Type := Index_Type (Last_As_Int);
103 LE : Elements_Type renames
104 Left.Elements (Index_Type'First .. Left.Last);
106 RE : Elements_Type renames
107 Right.Elements (Index_Type'First .. Right.Last);
109 Elements : constant Elements_Access :=
110 new Elements_Type'(LE & RE);
113 return (Controlled with Elements, Last, 0, 0);
118 function "&" (Left : Vector; Right : Element_Type) return Vector is
119 LN : constant Count_Type := Length (Left);
124 subtype Elements_Subtype is
125 Elements_Type (Index_Type'First .. Index_Type'First);
127 Elements : constant Elements_Access :=
128 new Elements_Subtype'(others => Right);
131 return (Controlled with Elements, Index_Type'First, 0, 0);
136 Last_As_Int : Int'Base;
139 if Int (Index_Type'First) > Int'Last - Int (LN) then
140 raise Constraint_Error with "new length is out of range";
143 Last_As_Int := Int (Index_Type'First) + Int (LN);
145 if Last_As_Int > Int (Index_Type'Last) then
146 raise Constraint_Error with "new length is out of range";
150 Last : constant Index_Type := Index_Type (Last_As_Int);
152 LE : Elements_Type renames
153 Left.Elements (Index_Type'First .. Left.Last);
155 subtype ET is Elements_Type (Index_Type'First .. Last);
157 Elements : constant Elements_Access := new ET'(LE & Right);
160 return (Controlled with Elements, Last, 0, 0);
165 function "&" (Left : Element_Type; Right : Vector) return Vector is
166 RN : constant Count_Type := Length (Right);
171 subtype Elements_Subtype is
172 Elements_Type (Index_Type'First .. Index_Type'First);
174 Elements : constant Elements_Access :=
175 new Elements_Subtype'(others => Left);
178 return (Controlled with Elements, Index_Type'First, 0, 0);
183 Last_As_Int : Int'Base;
186 if Int (Index_Type'First) > Int'Last - Int (RN) then
187 raise Constraint_Error with "new length is out of range";
190 Last_As_Int := Int (Index_Type'First) + Int (RN);
192 if Last_As_Int > Int (Index_Type'Last) then
193 raise Constraint_Error with "new length is out of range";
197 Last : constant Index_Type := Index_Type (Last_As_Int);
199 RE : Elements_Type renames
200 Right.Elements (Index_Type'First .. Right.Last);
202 subtype ET is Elements_Type (Index_Type'First .. Last);
204 Elements : constant Elements_Access := new ET'(Left & RE);
207 return (Controlled with Elements, Last, 0, 0);
212 function "&" (Left, Right : Element_Type) return Vector is
214 if Index_Type'First >= Index_Type'Last then
215 raise Constraint_Error with "new length is out of range";
219 Last : constant Index_Type := Index_Type'First + 1;
221 subtype ET is Elements_Type (Index_Type'First .. Last);
223 Elements : constant Elements_Access := new ET'(Left, Right);
226 return (Controlled with Elements, Last, 0, 0);
234 function "=" (Left, Right : Vector) return Boolean is
236 if Left'Address = Right'Address then
240 if Left.Last /= Right.Last then
244 for J in Index_Type range Index_Type'First .. Left.Last loop
245 if Left.Elements (J) /= Right.Elements (J) then
257 procedure Adjust (Container : in out Vector) is
259 if Container.Last = No_Index then
260 Container.Elements := null;
265 E : constant Elements_Access := Container.Elements;
266 L : constant Index_Type := Container.Last;
269 Container.Elements := null;
270 Container.Last := No_Index;
273 Container.Elements := new Elements_Type'(E (Index_Type'First .. L));
282 procedure Append (Container : in out Vector; New_Item : Vector) is
284 if Is_Empty (New_Item) then
288 if Container.Last = Index_Type'Last then
289 raise Constraint_Error with "vector is already at its maximum length";
299 (Container : in out Vector;
300 New_Item : Element_Type;
301 Count : Count_Type := 1)
308 if Container.Last = Index_Type'Last then
309 raise Constraint_Error with "vector is already at its maximum length";
323 function Capacity (Container : Vector) return Count_Type is
325 if Container.Elements = null then
329 return Container.Elements'Length;
336 procedure Clear (Container : in out Vector) is
338 if Container.Busy > 0 then
339 raise Program_Error with
340 "attempt to tamper with elements (vector is busy)";
343 Container.Last := No_Index;
352 Item : Element_Type) return Boolean
355 return Find_Index (Container, Item) /= No_Index;
363 (Container : in out Vector;
364 Index : Extended_Index;
365 Count : Count_Type := 1)
368 if Index < Index_Type'First then
369 raise Constraint_Error with "Index is out of range (too small)";
372 if Index > Container.Last then
373 if Index > Container.Last + 1 then
374 raise Constraint_Error with "Index is out of range (too large)";
384 if Container.Busy > 0 then
385 raise Program_Error with
386 "attempt to tamper with elements (vector is busy)";
390 I_As_Int : constant Int := Int (Index);
391 Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
393 Count1 : constant Int'Base := Count_Type'Pos (Count);
394 Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
395 N : constant Int'Base := Int'Min (Count1, Count2);
397 J_As_Int : constant Int'Base := I_As_Int + N;
400 if J_As_Int > Old_Last_As_Int then
401 Container.Last := Index - 1;
405 J : constant Index_Type := Index_Type (J_As_Int);
406 E : Elements_Type renames Container.Elements.all;
408 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
409 New_Last : constant Index_Type :=
410 Index_Type (New_Last_As_Int);
413 E (Index .. New_Last) := E (J .. Container.Last);
414 Container.Last := New_Last;
421 (Container : in out Vector;
422 Position : in out Cursor;
423 Count : Count_Type := 1)
426 if Position.Container = null then
427 raise Constraint_Error with "Position cursor has no element";
430 if Position.Container /= Container'Unrestricted_Access then
431 raise Program_Error with "Position cursor denotes wrong container";
434 if Position.Index > Container.Last then
435 raise Program_Error with "Position index is out of range";
438 Delete (Container, Position.Index, Count);
440 -- This is the old behavior, prior to the York API (2005/06):
442 -- if Position.Index <= Container.Last then
443 -- Position := (Container'Unchecked_Access, Position.Index);
445 -- Position := No_Element;
448 -- This is the behavior specified by the York API:
450 Position := No_Element;
457 procedure Delete_First
458 (Container : in out Vector;
459 Count : Count_Type := 1)
466 if Count >= Length (Container) then
471 Delete (Container, Index_Type'First, Count);
478 procedure Delete_Last
479 (Container : in out Vector;
480 Count : Count_Type := 1)
489 if Container.Busy > 0 then
490 raise Program_Error with
491 "attempt to tamper with elements (vector is busy)";
494 Index := Int'Base (Container.Last) - Int'Base (Count);
496 if Index < Index_Type'Pos (Index_Type'First) then
497 Container.Last := No_Index;
499 Container.Last := Index_Type (Index);
509 Index : Index_Type) return Element_Type
512 if Index > Container.Last then
513 raise Constraint_Error with "Index is out of range";
516 return Container.Elements (Index);
519 function Element (Position : Cursor) return Element_Type is
521 if Position.Container = null then
522 raise Constraint_Error with "Position cursor has no element";
525 return Element (Position.Container.all, 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 (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 (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 return Element (Container, Index_Type'First);
620 function First_Index (Container : Vector) return Index_Type is
621 pragma Unreferenced (Container);
623 return Index_Type'First;
626 ---------------------
627 -- Generic_Sorting --
628 ---------------------
630 package body Generic_Sorting is
636 function Is_Sorted (Container : Vector) return Boolean is
638 if Container.Last <= Index_Type'First then
643 E : Elements_Type renames Container.Elements.all;
645 for I in Index_Type'First .. Container.Last - 1 loop
646 if E (I + 1) < E (I) then
659 procedure Merge (Target, Source : in out Vector) is
660 I : Index_Type'Base := Target.Last;
664 if Target.Last < Index_Type'First then
665 Move (Target => Target, Source => Source);
669 if Target'Address = Source'Address then
673 if Source.Last < Index_Type'First then
677 if Source.Busy > 0 then
678 raise Program_Error with
679 "attempt to tamper with elements (vector is busy)";
682 Target.Set_Length (Length (Target) + Length (Source));
685 while Source.Last >= Index_Type'First loop
686 pragma Assert (Source.Last <= Index_Type'First
687 or else not (Source.Elements (Source.Last) <
688 Source.Elements (Source.Last - 1)));
690 if I < Index_Type'First then
691 Target.Elements (Index_Type'First .. J) :=
692 Source.Elements (Index_Type'First .. Source.Last);
694 Source.Last := No_Index;
698 pragma Assert (I <= Index_Type'First
699 or else not (Target.Elements (I) <
700 Target.Elements (I - 1)));
702 if Source.Elements (Source.Last) < Target.Elements (I) then
703 Target.Elements (J) := Target.Elements (I);
707 Target.Elements (J) := Source.Elements (Source.Last);
708 Source.Last := Source.Last - 1;
719 procedure Sort (Container : in out Vector)
722 new Generic_Array_Sort
723 (Index_Type => Index_Type,
724 Element_Type => Element_Type,
725 Array_Type => Elements_Type,
729 if Container.Last <= Index_Type'First then
733 if Container.Lock > 0 then
734 raise Program_Error with
735 "attempt to tamper with cursors (vector is locked)";
738 Sort (Container.Elements (Index_Type'First .. Container.Last));
747 function Has_Element (Position : Cursor) return Boolean is
749 if Position.Container = null then
753 return Position.Index <= Position.Container.Last;
761 (Container : in out Vector;
762 Before : Extended_Index;
763 New_Item : Element_Type;
764 Count : Count_Type := 1)
766 N : constant Int := Count_Type'Pos (Count);
768 First : constant Int := Int (Index_Type'First);
769 New_Last_As_Int : Int'Base;
770 New_Last : Index_Type;
772 Max_Length : constant UInt := UInt (Count_Type'Last);
774 Dst : Elements_Access;
777 if Before < Index_Type'First then
778 raise Constraint_Error with
779 "Before index is out of range (too small)";
782 if Before > Container.Last
783 and then Before > Container.Last + 1
785 raise Constraint_Error with
786 "Before index is out of range (too large)";
794 Old_Last_As_Int : constant Int := Int (Container.Last);
797 if Old_Last_As_Int > Int'Last - N then
798 raise Constraint_Error with "new length is out of range";
801 New_Last_As_Int := Old_Last_As_Int + N;
803 if New_Last_As_Int > Int (Index_Type'Last) then
804 raise Constraint_Error with "new length is out of range";
807 New_Length := UInt (New_Last_As_Int - First + Int'(1));
809 if New_Length > Max_Length then
810 raise Constraint_Error with "new length is out of range";
813 New_Last := Index_Type (New_Last_As_Int);
816 if Container.Busy > 0 then
817 raise Program_Error with
818 "attempt to tamper with elements (vector is busy)";
821 if Container.Elements = null then
823 subtype Elements_Subtype is
824 Elements_Type (Index_Type'First .. New_Last);
826 Container.Elements := new Elements_Subtype'(others => New_Item);
829 Container.Last := New_Last;
833 if New_Last <= Container.Elements'Last then
835 E : Elements_Type renames Container.Elements.all;
838 if Before <= Container.Last then
840 Index_As_Int : constant Int'Base :=
841 Index_Type'Pos (Before) + N;
843 Index : constant Index_Type := Index_Type (Index_As_Int);
846 E (Index .. New_Last) := E (Before .. Container.Last);
848 E (Before .. Index_Type'Pred (Index)) :=
849 (others => New_Item);
853 E (Before .. New_Last) := (others => New_Item);
857 Container.Last := New_Last;
865 C := UInt'Max (1, Container.Elements'Length);
866 while C < New_Length loop
867 if C > UInt'Last / 2 then
875 if C > Max_Length then
879 if Index_Type'First <= 0
880 and then Index_Type'Last >= 0
882 CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
885 CC := UInt (Int (Index_Type'Last) - First + 1);
893 Dst_Last : constant Index_Type :=
894 Index_Type (First + UInt'Pos (C) - 1);
897 Dst := new Elements_Type (Index_Type'First .. Dst_Last);
902 Src : Elements_Type renames Container.Elements.all;
905 Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
906 Src (Index_Type'First .. Index_Type'Pred (Before));
908 if Before <= Container.Last then
910 Index_As_Int : constant Int'Base :=
911 Index_Type'Pos (Before) + N;
913 Index : constant Index_Type := Index_Type (Index_As_Int);
916 Dst (Before .. Index_Type'Pred (Index)) := (others => New_Item);
917 Dst (Index .. New_Last) := Src (Before .. Container.Last);
921 Dst (Before .. New_Last) := (others => New_Item);
930 X : Elements_Access := Container.Elements;
932 Container.Elements := Dst;
933 Container.Last := New_Last;
939 (Container : in out Vector;
940 Before : Extended_Index;
943 N : constant Count_Type := Length (New_Item);
946 if Before < Index_Type'First then
947 raise Constraint_Error with
948 "Before index is out of range (too small)";
951 if Before > Container.Last
952 and then Before > Container.Last + 1
954 raise Constraint_Error with
955 "Before index is out of range (too large)";
962 Insert_Space (Container, Before, Count => N);
965 Dst_Last_As_Int : constant Int'Base :=
966 Int'Base (Before) + Int'Base (N) - 1;
968 Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
971 if Container'Address /= New_Item'Address then
972 Container.Elements (Before .. Dst_Last) :=
973 New_Item.Elements (Index_Type'First .. New_Item.Last);
979 subtype Src_Index_Subtype is Index_Type'Base range
980 Index_Type'First .. Before - 1;
982 Src : Elements_Type renames
983 Container.Elements (Src_Index_Subtype);
985 Index_As_Int : constant Int'Base :=
986 Int (Before) + Src'Length - 1;
988 Index : constant Index_Type'Base :=
989 Index_Type'Base (Index_As_Int);
991 Dst : Elements_Type renames
992 Container.Elements (Before .. Index);
998 if Dst_Last = Container.Last then
1003 subtype Src_Index_Subtype is Index_Type'Base range
1004 Dst_Last + 1 .. Container.Last;
1006 Src : Elements_Type renames
1007 Container.Elements (Src_Index_Subtype);
1009 Index_As_Int : constant Int'Base :=
1010 Dst_Last_As_Int - Src'Length + 1;
1012 Index : constant Index_Type :=
1013 Index_Type (Index_As_Int);
1015 Dst : Elements_Type renames
1016 Container.Elements (Index .. Dst_Last);
1025 (Container : in out Vector;
1029 Index : Index_Type'Base;
1032 if Before.Container /= null
1033 and then Before.Container /= Container'Unchecked_Access
1035 raise Program_Error with "Before cursor denotes wrong container";
1038 if Is_Empty (New_Item) then
1042 if Before.Container = null
1043 or else Before.Index > Container.Last
1045 if Container.Last = Index_Type'Last then
1046 raise Constraint_Error with
1047 "vector is already at its maximum length";
1050 Index := Container.Last + 1;
1053 Index := Before.Index;
1056 Insert (Container, Index, New_Item);
1060 (Container : in out Vector;
1063 Position : out Cursor)
1065 Index : Index_Type'Base;
1068 if Before.Container /= null
1069 and then Before.Container /= Container'Unchecked_Access
1071 raise Program_Error with "Before cursor denotes wrong container";
1074 if Is_Empty (New_Item) then
1075 if Before.Container = null
1076 or else Before.Index > Container.Last
1078 Position := No_Element;
1080 Position := (Container'Unchecked_Access, Before.Index);
1086 if Before.Container = null
1087 or else Before.Index > Container.Last
1089 if Container.Last = Index_Type'Last then
1090 raise Constraint_Error with
1091 "vector is already at its maximum length";
1094 Index := Container.Last + 1;
1097 Index := Before.Index;
1100 Insert (Container, Index, New_Item);
1102 Position := Cursor'(Container'Unchecked_Access, Index);
1106 (Container : in out Vector;
1108 New_Item : Element_Type;
1109 Count : Count_Type := 1)
1111 Index : Index_Type'Base;
1114 if Before.Container /= null
1115 and then Before.Container /= Container'Unchecked_Access
1117 raise Program_Error with "Before cursor denotes wrong container";
1124 if Before.Container = null
1125 or else Before.Index > Container.Last
1127 if Container.Last = Index_Type'Last then
1128 raise Constraint_Error with
1129 "vector is already at its maximum length";
1132 Index := Container.Last + 1;
1135 Index := Before.Index;
1138 Insert (Container, Index, New_Item, Count);
1142 (Container : in out Vector;
1144 New_Item : Element_Type;
1145 Position : out Cursor;
1146 Count : Count_Type := 1)
1148 Index : Index_Type'Base;
1151 if Before.Container /= null
1152 and then Before.Container /= Container'Unchecked_Access
1154 raise Program_Error with "Before cursor denotes wrong container";
1158 if Before.Container = null
1159 or else Before.Index > Container.Last
1161 Position := No_Element;
1163 Position := (Container'Unchecked_Access, Before.Index);
1169 if Before.Container = null
1170 or else Before.Index > Container.Last
1172 if Container.Last = Index_Type'Last then
1173 raise Constraint_Error with
1174 "vector is already at its maximum length";
1177 Index := Container.Last + 1;
1180 Index := Before.Index;
1183 Insert (Container, Index, New_Item, Count);
1185 Position := Cursor'(Container'Unchecked_Access, Index);
1189 (Container : in out Vector;
1190 Before : Extended_Index;
1191 Count : Count_Type := 1)
1193 New_Item : Element_Type; -- Default-initialized value
1194 pragma Warnings (Off, New_Item);
1197 Insert (Container, Before, New_Item, Count);
1201 (Container : in out Vector;
1203 Position : out Cursor;
1204 Count : Count_Type := 1)
1206 New_Item : Element_Type; -- Default-initialized value
1207 pragma Warnings (Off, New_Item);
1210 Insert (Container, Before, New_Item, Position, Count);
1217 procedure Insert_Space
1218 (Container : in out Vector;
1219 Before : Extended_Index;
1220 Count : Count_Type := 1)
1222 N : constant Int := Count_Type'Pos (Count);
1224 First : constant Int := Int (Index_Type'First);
1225 New_Last_As_Int : Int'Base;
1226 New_Last : Index_Type;
1228 Max_Length : constant UInt := UInt (Count_Type'Last);
1230 Dst : Elements_Access;
1233 if Before < Index_Type'First then
1234 raise Constraint_Error with
1235 "Before index is out of range (too small)";
1238 if Before > Container.Last
1239 and then Before > Container.Last + 1
1241 raise Constraint_Error with
1242 "Before index is out of range (too large)";
1250 Old_Last_As_Int : constant Int := Int (Container.Last);
1253 if Old_Last_As_Int > Int'Last - N then
1254 raise Constraint_Error with "new length is out of range";
1257 New_Last_As_Int := Old_Last_As_Int + N;
1259 if New_Last_As_Int > Int (Index_Type'Last) then
1260 raise Constraint_Error with "new length is out of range";
1263 New_Length := UInt (New_Last_As_Int - First + Int'(1));
1265 if New_Length > Max_Length then
1266 raise Constraint_Error with "new length is out of range";
1269 New_Last := Index_Type (New_Last_As_Int);
1272 if Container.Busy > 0 then
1273 raise Program_Error with
1274 "attempt to tamper with elements (vector is busy)";
1277 if Container.Elements = null then
1278 Container.Elements :=
1279 new Elements_Type (Index_Type'First .. New_Last);
1281 Container.Last := New_Last;
1285 if New_Last <= Container.Elements'Last then
1287 E : Elements_Type renames Container.Elements.all;
1289 if Before <= Container.Last then
1291 Index_As_Int : constant Int'Base :=
1292 Index_Type'Pos (Before) + N;
1294 Index : constant Index_Type := Index_Type (Index_As_Int);
1297 E (Index .. New_Last) := E (Before .. Container.Last);
1302 Container.Last := New_Last;
1310 C := UInt'Max (1, Container.Elements'Length);
1311 while C < New_Length loop
1312 if C > UInt'Last / 2 then
1320 if C > Max_Length then
1324 if Index_Type'First <= 0
1325 and then Index_Type'Last >= 0
1327 CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
1330 CC := UInt (Int (Index_Type'Last) - First + 1);
1338 Dst_Last : constant Index_Type :=
1339 Index_Type (First + UInt'Pos (C) - 1);
1342 Dst := new Elements_Type (Index_Type'First .. Dst_Last);
1347 Src : Elements_Type renames Container.Elements.all;
1350 Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
1351 Src (Index_Type'First .. Index_Type'Pred (Before));
1353 if Before <= Container.Last then
1355 Index_As_Int : constant Int'Base :=
1356 Index_Type'Pos (Before) + N;
1358 Index : constant Index_Type := Index_Type (Index_As_Int);
1361 Dst (Index .. New_Last) := Src (Before .. Container.Last);
1371 X : Elements_Access := Container.Elements;
1373 Container.Elements := Dst;
1374 Container.Last := New_Last;
1379 procedure Insert_Space
1380 (Container : in out Vector;
1382 Position : out Cursor;
1383 Count : Count_Type := 1)
1385 Index : Index_Type'Base;
1388 if Before.Container /= null
1389 and then Before.Container /= Container'Unchecked_Access
1391 raise Program_Error with "Before cursor denotes wrong container";
1395 if Before.Container = null
1396 or else Before.Index > Container.Last
1398 Position := No_Element;
1400 Position := (Container'Unchecked_Access, Before.Index);
1406 if Before.Container = null
1407 or else Before.Index > Container.Last
1409 if Container.Last = Index_Type'Last then
1410 raise Constraint_Error with
1411 "vector is already at its maximum length";
1414 Index := Container.Last + 1;
1417 Index := Before.Index;
1420 Insert_Space (Container, Index, Count => Count);
1422 Position := Cursor'(Container'Unchecked_Access, Index);
1429 function Is_Empty (Container : Vector) return Boolean is
1431 return Container.Last < Index_Type'First;
1439 (Container : Vector;
1440 Process : not null access procedure (Position : Cursor))
1442 V : Vector renames Container'Unrestricted_Access.all;
1443 B : Natural renames V.Busy;
1449 for Indx in Index_Type'First .. Container.Last loop
1450 Process (Cursor'(Container'Unchecked_Access, Indx));
1465 function Last (Container : Vector) return Cursor is
1467 if Is_Empty (Container) then
1471 return (Container'Unchecked_Access, Container.Last);
1478 function Last_Element (Container : Vector) return Element_Type is
1480 return Element (Container, Container.Last);
1487 function Last_Index (Container : Vector) return Extended_Index is
1489 return Container.Last;
1496 function Length (Container : Vector) return Count_Type is
1497 L : constant Int := Int (Container.Last);
1498 F : constant Int := Int (Index_Type'First);
1499 N : constant Int'Base := L - F + 1;
1502 return Count_Type (N);
1510 (Target : in out Vector;
1511 Source : in out Vector)
1514 if Target'Address = Source'Address then
1518 if Target.Busy > 0 then
1519 raise Program_Error with
1520 "attempt to tamper with elements (Target is busy)";
1523 if Source.Busy > 0 then
1524 raise Program_Error with
1525 "attempt to tamper with elements (Source is busy)";
1529 Target_Elements : constant Elements_Access := Target.Elements;
1531 Target.Elements := Source.Elements;
1532 Source.Elements := Target_Elements;
1535 Target.Last := Source.Last;
1536 Source.Last := No_Index;
1543 function Next (Position : Cursor) return Cursor is
1545 if Position.Container = null then
1549 if Position.Index < Position.Container.Last then
1550 return (Position.Container, Position.Index + 1);
1560 procedure Next (Position : in out Cursor) is
1562 if Position.Container = null then
1566 if Position.Index < Position.Container.Last then
1567 Position.Index := Position.Index + 1;
1569 Position := No_Element;
1577 procedure Prepend (Container : in out Vector; New_Item : Vector) is
1579 Insert (Container, Index_Type'First, New_Item);
1583 (Container : in out Vector;
1584 New_Item : Element_Type;
1585 Count : Count_Type := 1)
1598 procedure Previous (Position : in out Cursor) is
1600 if Position.Container = null then
1604 if Position.Index > Index_Type'First then
1605 Position.Index := Position.Index - 1;
1607 Position := No_Element;
1611 function Previous (Position : Cursor) return Cursor is
1613 if Position.Container = null then
1617 if Position.Index > Index_Type'First then
1618 return (Position.Container, Position.Index - 1);
1628 procedure Query_Element
1629 (Container : Vector;
1631 Process : not null access procedure (Element : Element_Type))
1633 V : Vector renames Container'Unrestricted_Access.all;
1634 B : Natural renames V.Busy;
1635 L : Natural renames V.Lock;
1638 if Index > Container.Last then
1639 raise Constraint_Error with "Index is out of range";
1646 Process (V.Elements (Index));
1658 procedure Query_Element
1660 Process : not null access procedure (Element : Element_Type))
1663 if Position.Container = null then
1664 raise Constraint_Error with "Position cursor has no element";
1667 Query_Element (Position.Container.all, Position.Index, Process);
1675 (Stream : not null access Root_Stream_Type'Class;
1676 Container : out Vector)
1678 Length : Count_Type'Base;
1679 Last : Index_Type'Base := No_Index;
1684 Count_Type'Base'Read (Stream, Length);
1686 if Length > Capacity (Container) then
1687 Reserve_Capacity (Container, Capacity => Length);
1690 for J in Count_Type range 1 .. Length loop
1692 Element_Type'Read (Stream, Container.Elements (Last));
1693 Container.Last := Last;
1698 (Stream : not null access Root_Stream_Type'Class;
1699 Position : out Cursor)
1702 raise Program_Error with "attempt to stream vector cursor";
1705 ---------------------
1706 -- Replace_Element --
1707 ---------------------
1709 procedure Replace_Element
1710 (Container : in out Vector;
1712 New_Item : Element_Type)
1715 if Index > Container.Last then
1716 raise Constraint_Error with "Index is out of range";
1719 if Container.Lock > 0 then
1720 raise Program_Error with
1721 "attempt to tamper with cursors (vector is locked)";
1724 Container.Elements (Index) := New_Item;
1725 end Replace_Element;
1727 procedure Replace_Element
1728 (Container : in out Vector;
1730 New_Item : Element_Type)
1733 if Position.Container = null then
1734 raise Constraint_Error with "Position cursor has no element";
1737 if Position.Container /= Container'Unrestricted_Access then
1738 raise Program_Error with "Position cursor denotes wrong container";
1741 Replace_Element (Container, Position.Index, New_Item);
1742 end Replace_Element;
1744 ----------------------
1745 -- Reserve_Capacity --
1746 ----------------------
1748 procedure Reserve_Capacity
1749 (Container : in out Vector;
1750 Capacity : Count_Type)
1752 N : constant Count_Type := Length (Container);
1755 if Capacity = 0 then
1758 X : Elements_Access := Container.Elements;
1760 Container.Elements := null;
1764 elsif N < Container.Elements'Length then
1765 if Container.Busy > 0 then
1766 raise Program_Error with
1767 "attempt to tamper with elements (vector is busy)";
1771 subtype Array_Index_Subtype is Index_Type'Base range
1772 Index_Type'First .. Container.Last;
1774 Src : Elements_Type renames
1775 Container.Elements (Array_Index_Subtype);
1777 subtype Array_Subtype is
1778 Elements_Type (Array_Index_Subtype);
1780 X : Elements_Access := Container.Elements;
1783 Container.Elements := new Array_Subtype'(Src);
1791 if Container.Elements = null then
1793 Last_As_Int : constant Int'Base :=
1794 Int (Index_Type'First) + Int (Capacity) - 1;
1797 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1798 raise Constraint_Error with "new length is out of range";
1802 Last : constant Index_Type := Index_Type (Last_As_Int);
1804 subtype Array_Subtype is
1805 Elements_Type (Index_Type'First .. Last);
1808 Container.Elements := new Array_Subtype;
1815 if Capacity <= N then
1816 if N < Container.Elements'Length then
1817 if Container.Busy > 0 then
1818 raise Program_Error with
1819 "attempt to tamper with elements (vector is busy)";
1823 subtype Array_Index_Subtype is Index_Type'Base range
1824 Index_Type'First .. Container.Last;
1826 Src : Elements_Type renames
1827 Container.Elements (Array_Index_Subtype);
1829 subtype Array_Subtype is
1830 Elements_Type (Array_Index_Subtype);
1832 X : Elements_Access := Container.Elements;
1835 Container.Elements := new Array_Subtype'(Src);
1844 if Capacity = Container.Elements'Length then
1848 if Container.Busy > 0 then
1849 raise Program_Error with
1850 "attempt to tamper with elements (vector is busy)";
1854 Last_As_Int : constant Int'Base :=
1855 Int (Index_Type'First) + Int (Capacity) - 1;
1858 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1859 raise Constraint_Error with "new length is out of range";
1863 Last : constant Index_Type := Index_Type (Last_As_Int);
1865 subtype Array_Subtype is
1866 Elements_Type (Index_Type'First .. Last);
1868 E : Elements_Access := new Array_Subtype;
1872 Src : Elements_Type renames
1873 Container.Elements (Index_Type'First .. Container.Last);
1875 Tgt : Elements_Type renames
1876 E (Index_Type'First .. Container.Last);
1888 X : Elements_Access := Container.Elements;
1890 Container.Elements := E;
1895 end Reserve_Capacity;
1897 ----------------------
1898 -- Reverse_Elements --
1899 ----------------------
1901 procedure Reverse_Elements (Container : in out Vector) is
1903 if Container.Length <= 1 then
1907 if Container.Lock > 0 then
1908 raise Program_Error with
1909 "attempt to tamper with cursors (vector is locked)";
1914 E : Elements_Type renames Container.Elements.all;
1917 I := Index_Type'First;
1918 J := Container.Last;
1921 EI : constant Element_Type := E (I);
1932 end Reverse_Elements;
1938 function Reverse_Find
1939 (Container : Vector;
1940 Item : Element_Type;
1941 Position : Cursor := No_Element) return Cursor
1943 Last : Index_Type'Base;
1946 if Position.Container /= null
1947 and then Position.Container /= Container'Unchecked_Access
1949 raise Program_Error with "Position cursor denotes wrong container";
1952 if Position.Container = null
1953 or else Position.Index > Container.Last
1955 Last := Container.Last;
1957 Last := Position.Index;
1960 for Indx in reverse Index_Type'First .. Last loop
1961 if Container.Elements (Indx) = Item then
1962 return (Container'Unchecked_Access, Indx);
1969 ------------------------
1970 -- Reverse_Find_Index --
1971 ------------------------
1973 function Reverse_Find_Index
1974 (Container : Vector;
1975 Item : Element_Type;
1976 Index : Index_Type := Index_Type'Last) return Extended_Index
1978 Last : Index_Type'Base;
1981 if Index > Container.Last then
1982 Last := Container.Last;
1987 for Indx in reverse Index_Type'First .. Last loop
1988 if Container.Elements (Indx) = Item then
1994 end Reverse_Find_Index;
1996 ---------------------
1997 -- Reverse_Iterate --
1998 ---------------------
2000 procedure Reverse_Iterate
2001 (Container : Vector;
2002 Process : not null access procedure (Position : Cursor))
2004 V : Vector renames Container'Unrestricted_Access.all;
2005 B : Natural renames V.Busy;
2011 for Indx in reverse Index_Type'First .. Container.Last loop
2012 Process (Cursor'(Container'Unchecked_Access, Indx));
2021 end Reverse_Iterate;
2027 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
2029 if Length = Vectors.Length (Container) then
2033 if Container.Busy > 0 then
2034 raise Program_Error with
2035 "attempt to tamper with elements (vector is busy)";
2038 if Length > Capacity (Container) then
2039 Reserve_Capacity (Container, Capacity => Length);
2043 Last_As_Int : constant Int'Base :=
2044 Int (Index_Type'First) + Int (Length) - 1;
2046 Container.Last := Index_Type'Base (Last_As_Int);
2054 procedure Swap (Container : in out Vector; I, J : Index_Type) is
2056 if I > Container.Last then
2057 raise Constraint_Error with "I index is out of range";
2060 if J > Container.Last then
2061 raise Constraint_Error with "J index is out of range";
2068 if Container.Lock > 0 then
2069 raise Program_Error with
2070 "attempt to tamper with cursors (vector is locked)";
2074 EI : Element_Type renames Container.Elements (I);
2075 EJ : Element_Type renames Container.Elements (J);
2077 EI_Copy : constant Element_Type := EI;
2085 procedure Swap (Container : in out Vector; I, J : Cursor) is
2087 if I.Container = null then
2088 raise Constraint_Error with "I cursor has no element";
2091 if J.Container = null then
2092 raise Constraint_Error with "J cursor has no element";
2095 if I.Container /= Container'Unrestricted_Access then
2096 raise Program_Error with "I cursor denotes wrong container";
2099 if J.Container /= Container'Unrestricted_Access then
2100 raise Program_Error with "J cursor denotes wrong container";
2103 Swap (Container, I.Index, J.Index);
2111 (Container : Vector;
2112 Index : Extended_Index) return Cursor
2115 if Index not in Index_Type'First .. Container.Last then
2119 return Cursor'(Container'Unchecked_Access, Index);
2126 function To_Index (Position : Cursor) return Extended_Index is
2128 if Position.Container = null then
2132 if Position.Index <= Position.Container.Last then
2133 return Position.Index;
2143 function To_Vector (Length : Count_Type) return Vector is
2146 return Empty_Vector;
2150 First : constant Int := Int (Index_Type'First);
2151 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2153 Elements : Elements_Access;
2156 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2157 raise Constraint_Error with "Length is out of range";
2160 Last := Index_Type (Last_As_Int);
2161 Elements := new Elements_Type (Index_Type'First .. Last);
2163 return Vector'(Controlled with Elements, Last, 0, 0);
2168 (New_Item : Element_Type;
2169 Length : Count_Type) return Vector
2173 return Empty_Vector;
2177 First : constant Int := Int (Index_Type'First);
2178 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2180 Elements : Elements_Access;
2183 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2184 raise Constraint_Error with "Length is out of range";
2187 Last := Index_Type (Last_As_Int);
2188 Elements := new Elements_Type'(Index_Type'First .. Last => New_Item);
2190 return Vector'(Controlled with Elements, Last, 0, 0);
2194 --------------------
2195 -- Update_Element --
2196 --------------------
2198 procedure Update_Element
2199 (Container : in out Vector;
2201 Process : not null access procedure (Element : in out Element_Type))
2203 B : Natural renames Container.Busy;
2204 L : Natural renames Container.Lock;
2207 if Index > Container.Last then
2208 raise Constraint_Error with "Index is out of range";
2215 Process (Container.Elements (Index));
2227 procedure Update_Element
2228 (Container : in out Vector;
2230 Process : not null access procedure (Element : in out Element_Type))
2233 if Position.Container = null then
2234 raise Constraint_Error with "Position cursor has no element";
2237 if Position.Container /= Container'Unrestricted_Access then
2238 raise Program_Error with "Position cursor denotes wrong container";
2241 Update_Element (Container, Position.Index, Process);
2249 (Stream : not null access Root_Stream_Type'Class;
2253 Count_Type'Base'Write (Stream, Length (Container));
2255 for J in Index_Type'First .. Container.Last loop
2256 Element_Type'Write (Stream, Container.Elements (J));
2261 (Stream : not null access Root_Stream_Type'Class;
2265 raise Program_Error with "attempt to stream vector cursor";
2268 end Ada.Containers.Vectors;