1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S --
9 -- Copyright (C) 2004-2008, 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;
34 with System; use type System.Address;
36 package body Ada.Containers.Indefinite_Vectors is
38 type Int is range System.Min_Int .. System.Max_Int;
39 type UInt is mod System.Max_Binary_Modulus;
42 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
45 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
51 function "&" (Left, Right : Vector) return Vector is
52 LN : constant Count_Type := Length (Left);
53 RN : constant Count_Type := Length (Right);
62 RE : Elements_Array renames
63 Right.Elements.EA (Index_Type'First .. Right.Last);
65 Elements : Elements_Access :=
66 new Elements_Type (Right.Last);
69 for I in Elements.EA'Range loop
71 if RE (I) /= null then
72 Elements.EA (I) := new Element_Type'(RE (I).all);
77 for J in Index_Type'First .. I - 1 loop
78 Free (Elements.EA (J));
86 return (Controlled with Elements, Right.Last, 0, 0);
93 LE : Elements_Array renames
94 Left.Elements.EA (Index_Type'First .. Left.Last);
96 Elements : Elements_Access :=
97 new Elements_Type (Left.Last);
100 for I in Elements.EA'Range loop
102 if LE (I) /= null then
103 Elements.EA (I) := new Element_Type'(LE (I).all);
108 for J in Index_Type'First .. I - 1 loop
109 Free (Elements.EA (J));
117 return (Controlled with Elements, Left.Last, 0, 0);
122 N : constant Int'Base := Int (LN) + Int (RN);
123 Last_As_Int : Int'Base;
126 if Int (No_Index) > Int'Last - N then
127 raise Constraint_Error with "new length is out of range";
130 Last_As_Int := Int (No_Index) + N;
132 if Last_As_Int > Int (Index_Type'Last) then
133 raise Constraint_Error with "new length is out of range";
137 Last : constant Index_Type := Index_Type (Last_As_Int);
139 LE : Elements_Array renames
140 Left.Elements.EA (Index_Type'First .. Left.Last);
142 RE : Elements_Array renames
143 Right.Elements.EA (Index_Type'First .. Right.Last);
145 Elements : Elements_Access := new Elements_Type (Last);
147 I : Index_Type'Base := No_Index;
150 for LI in LE'Range loop
154 if LE (LI) /= null then
155 Elements.EA (I) := new Element_Type'(LE (LI).all);
160 for J in Index_Type'First .. I - 1 loop
161 Free (Elements.EA (J));
169 for RI in RE'Range loop
173 if RE (RI) /= null then
174 Elements.EA (I) := new Element_Type'(RE (RI).all);
179 for J in Index_Type'First .. I - 1 loop
180 Free (Elements.EA (J));
188 return (Controlled with Elements, Last, 0, 0);
193 function "&" (Left : Vector; Right : Element_Type) return Vector is
194 LN : constant Count_Type := Length (Left);
199 Elements : Elements_Access := new Elements_Type (Index_Type'First);
203 Elements.EA (Index_Type'First) := new Element_Type'(Right);
210 return (Controlled with Elements, Index_Type'First, 0, 0);
215 Last_As_Int : Int'Base;
218 if Int (Index_Type'First) > Int'Last - Int (LN) then
219 raise Constraint_Error with "new length is out of range";
222 Last_As_Int := Int (Index_Type'First) + Int (LN);
224 if Last_As_Int > Int (Index_Type'Last) then
225 raise Constraint_Error with "new length is out of range";
229 Last : constant Index_Type := Index_Type (Last_As_Int);
231 LE : Elements_Array renames
232 Left.Elements.EA (Index_Type'First .. Left.Last);
234 Elements : Elements_Access :=
235 new Elements_Type (Last);
238 for I in LE'Range loop
240 if LE (I) /= null then
241 Elements.EA (I) := new Element_Type'(LE (I).all);
246 for J in Index_Type'First .. I - 1 loop
247 Free (Elements.EA (J));
256 Elements.EA (Last) := new Element_Type'(Right);
260 for J in Index_Type'First .. Last - 1 loop
261 Free (Elements.EA (J));
268 return (Controlled with Elements, Last, 0, 0);
273 function "&" (Left : Element_Type; Right : Vector) return Vector is
274 RN : constant Count_Type := Length (Right);
279 Elements : Elements_Access := new Elements_Type (Index_Type'First);
283 Elements.EA (Index_Type'First) := new Element_Type'(Left);
290 return (Controlled with Elements, Index_Type'First, 0, 0);
295 Last_As_Int : Int'Base;
298 if Int (Index_Type'First) > Int'Last - Int (RN) then
299 raise Constraint_Error with "new length is out of range";
302 Last_As_Int := Int (Index_Type'First) + Int (RN);
304 if Last_As_Int > Int (Index_Type'Last) then
305 raise Constraint_Error with "new length is out of range";
309 Last : constant Index_Type := Index_Type (Last_As_Int);
311 RE : Elements_Array renames
312 Right.Elements.EA (Index_Type'First .. Right.Last);
314 Elements : Elements_Access :=
315 new Elements_Type (Last);
317 I : Index_Type'Base := Index_Type'First;
321 Elements.EA (I) := new Element_Type'(Left);
328 for RI in RE'Range loop
332 if RE (RI) /= null then
333 Elements.EA (I) := new Element_Type'(RE (RI).all);
338 for J in Index_Type'First .. I - 1 loop
339 Free (Elements.EA (J));
347 return (Controlled with Elements, Last, 0, 0);
352 function "&" (Left, Right : Element_Type) return Vector is
354 if Index_Type'First >= Index_Type'Last then
355 raise Constraint_Error with "new length is out of range";
359 Last : constant Index_Type := Index_Type'First + 1;
360 Elements : Elements_Access := new Elements_Type (Last);
364 Elements.EA (Index_Type'First) := new Element_Type'(Left);
372 Elements.EA (Last) := new Element_Type'(Right);
375 Free (Elements.EA (Index_Type'First));
380 return (Controlled with Elements, Last, 0, 0);
388 function "=" (Left, Right : Vector) return Boolean is
390 if Left'Address = Right'Address then
394 if Left.Last /= Right.Last then
398 for J in Index_Type'First .. Left.Last loop
399 if Left.Elements.EA (J) = null then
400 if Right.Elements.EA (J) /= null then
404 elsif Right.Elements.EA (J) = null then
407 elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
419 procedure Adjust (Container : in out Vector) is
421 if Container.Last = No_Index then
422 Container.Elements := null;
427 L : constant Index_Type := Container.Last;
428 E : Elements_Array renames
429 Container.Elements.EA (Index_Type'First .. L);
432 Container.Elements := null;
433 Container.Last := No_Index;
437 Container.Elements := new Elements_Type (L);
439 for I in E'Range loop
440 if E (I) /= null then
441 Container.Elements.EA (I) := new Element_Type'(E (I).all);
453 procedure Append (Container : in out Vector; New_Item : Vector) is
455 if Is_Empty (New_Item) then
459 if Container.Last = Index_Type'Last then
460 raise Constraint_Error with "vector is already at its maximum length";
470 (Container : in out Vector;
471 New_Item : Element_Type;
472 Count : Count_Type := 1)
479 if Container.Last = Index_Type'Last then
480 raise Constraint_Error with "vector is already at its maximum length";
494 function Capacity (Container : Vector) return Count_Type is
496 if Container.Elements = null then
500 return Container.Elements.EA'Length;
507 procedure Clear (Container : in out Vector) is
509 if Container.Busy > 0 then
510 raise Program_Error with
511 "attempt to tamper with elements (vector is busy)";
514 while Container.Last >= Index_Type'First loop
516 X : Element_Access := Container.Elements.EA (Container.Last);
518 Container.Elements.EA (Container.Last) := null;
519 Container.Last := Container.Last - 1;
531 Item : Element_Type) return Boolean
534 return Find_Index (Container, Item) /= No_Index;
542 (Container : in out Vector;
543 Index : Extended_Index;
544 Count : Count_Type := 1)
547 if Index < Index_Type'First then
548 raise Constraint_Error with "Index is out of range (too small)";
551 if Index > Container.Last then
552 if Index > Container.Last + 1 then
553 raise Constraint_Error with "Index is out of range (too large)";
563 if Container.Busy > 0 then
564 raise Program_Error with
565 "attempt to tamper with elements (vector is busy)";
569 Index_As_Int : constant Int := Int (Index);
570 Old_Last_As_Int : constant Int := Int (Container.Last);
572 Count1 : constant Int'Base := Int (Count);
573 Count2 : constant Int'Base := Old_Last_As_Int - Index_As_Int + 1;
574 N : constant Int'Base := Int'Min (Count1, Count2);
576 J_As_Int : constant Int'Base := Index_As_Int + N;
577 E : Elements_Array renames Container.Elements.EA;
580 if J_As_Int > Old_Last_As_Int then
581 while Container.Last >= Index loop
583 K : constant Index_Type := Container.Last;
584 X : Element_Access := E (K);
588 Container.Last := K - 1;
595 J : constant Index_Type := Index_Type (J_As_Int);
597 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
598 New_Last : constant Index_Type :=
599 Index_Type (New_Last_As_Int);
602 for K in Index .. J - 1 loop
604 X : Element_Access := E (K);
611 E (Index .. New_Last) := E (J .. Container.Last);
612 Container.Last := New_Last;
619 (Container : in out Vector;
620 Position : in out Cursor;
621 Count : Count_Type := 1)
623 pragma Warnings (Off, Position);
626 if Position.Container = null then
627 raise Constraint_Error with "Position cursor has no element";
630 if Position.Container /= Container'Unrestricted_Access then
631 raise Program_Error with "Position cursor denotes wrong container";
634 if Position.Index > Container.Last then
635 raise Program_Error with "Position index is out of range";
638 Delete (Container, Position.Index, Count);
640 Position := No_Element;
647 procedure Delete_First
648 (Container : in out Vector;
649 Count : Count_Type := 1)
656 if Count >= Length (Container) then
661 Delete (Container, Index_Type'First, Count);
668 procedure Delete_Last
669 (Container : in out Vector;
670 Count : Count_Type := 1)
672 N : constant Count_Type := Length (Container);
681 if Container.Busy > 0 then
682 raise Program_Error with
683 "attempt to tamper with elements (vector is busy)";
687 E : Elements_Array renames Container.Elements.EA;
690 for Indx in 1 .. Count_Type'Min (Count, N) loop
692 J : constant Index_Type := Container.Last;
693 X : Element_Access := E (J);
697 Container.Last := J - 1;
710 Index : Index_Type) return Element_Type
713 if Index > Container.Last then
714 raise Constraint_Error with "Index is out of range";
718 EA : constant Element_Access := Container.Elements.EA (Index);
722 raise Constraint_Error with "element is empty";
729 function Element (Position : Cursor) return Element_Type is
731 if Position.Container = null then
732 raise Constraint_Error with "Position cursor has no element";
735 if Position.Index > Position.Container.Last then
736 raise Constraint_Error with "Position cursor is out of range";
740 EA : constant Element_Access :=
741 Position.Container.Elements.EA (Position.Index);
745 raise Constraint_Error with "element is empty";
756 procedure Finalize (Container : in out Vector) is
758 Clear (Container); -- Checks busy-bit
761 X : Elements_Access := Container.Elements;
763 Container.Elements := null;
775 Position : Cursor := No_Element) return Cursor
778 if Position.Container /= null then
779 if Position.Container /= Container'Unrestricted_Access then
780 raise Program_Error with "Position cursor denotes wrong container";
783 if Position.Index > Container.Last then
784 raise Program_Error with "Position index is out of range";
788 for J in Position.Index .. Container.Last loop
789 if Container.Elements.EA (J) /= null
790 and then Container.Elements.EA (J).all = Item
792 return (Container'Unchecked_Access, J);
806 Index : Index_Type := Index_Type'First) return Extended_Index
809 for Indx in Index .. Container.Last loop
810 if Container.Elements.EA (Indx) /= null
811 and then Container.Elements.EA (Indx).all = Item
824 function First (Container : Vector) return Cursor is
826 if Is_Empty (Container) then
830 return (Container'Unchecked_Access, Index_Type'First);
837 function First_Element (Container : Vector) return Element_Type is
839 if Container.Last = No_Index then
840 raise Constraint_Error with "Container is empty";
844 EA : constant Element_Access :=
845 Container.Elements.EA (Index_Type'First);
849 raise Constraint_Error with "first element is empty";
860 function First_Index (Container : Vector) return Index_Type is
861 pragma Unreferenced (Container);
863 return Index_Type'First;
866 ---------------------
867 -- Generic_Sorting --
868 ---------------------
870 package body Generic_Sorting is
872 -----------------------
873 -- Local Subprograms --
874 -----------------------
876 function Is_Less (L, R : Element_Access) return Boolean;
877 pragma Inline (Is_Less);
883 function Is_Less (L, R : Element_Access) return Boolean is
890 return L.all < R.all;
898 function Is_Sorted (Container : Vector) return Boolean is
900 if Container.Last <= Index_Type'First then
905 E : Elements_Array renames Container.Elements.EA;
907 for I in Index_Type'First .. Container.Last - 1 loop
908 if Is_Less (E (I + 1), E (I)) then
921 procedure Merge (Target, Source : in out Vector) is
922 I, J : Index_Type'Base;
925 if Target.Last < Index_Type'First then
926 Move (Target => Target, Source => Source);
930 if Target'Address = Source'Address then
934 if Source.Last < Index_Type'First then
938 if Source.Busy > 0 then
939 raise Program_Error with
940 "attempt to tamper with elements (vector is busy)";
943 I := Target.Last; -- original value (before Set_Length)
944 Target.Set_Length (Length (Target) + Length (Source));
946 J := Target.Last; -- new value (after Set_Length)
947 while Source.Last >= Index_Type'First loop
949 (Source.Last <= Index_Type'First
951 (Source.Elements.EA (Source.Last),
952 Source.Elements.EA (Source.Last - 1))));
954 if I < Index_Type'First then
956 Src : Elements_Array renames
957 Source.Elements.EA (Index_Type'First .. Source.Last);
960 Target.Elements.EA (Index_Type'First .. J) := Src;
961 Src := (others => null);
964 Source.Last := No_Index;
969 (I <= Index_Type'First
971 (Target.Elements.EA (I),
972 Target.Elements.EA (I - 1))));
975 Src : Element_Access renames Source.Elements.EA (Source.Last);
976 Tgt : Element_Access renames Target.Elements.EA (I);
979 if Is_Less (Src, Tgt) then
980 Target.Elements.EA (J) := Tgt;
985 Target.Elements.EA (J) := Src;
987 Source.Last := Source.Last - 1;
999 procedure Sort (Container : in out Vector) is
1001 procedure Sort is new Generic_Array_Sort
1002 (Index_Type => Index_Type,
1003 Element_Type => Element_Access,
1004 Array_Type => Elements_Array,
1007 -- Start of processing for Sort
1010 if Container.Last <= Index_Type'First then
1014 if Container.Lock > 0 then
1015 raise Program_Error with
1016 "attempt to tamper with cursors (vector is locked)";
1019 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1022 end Generic_Sorting;
1028 function Has_Element (Position : Cursor) return Boolean is
1030 if Position.Container = null then
1034 return Position.Index <= Position.Container.Last;
1042 (Container : in out Vector;
1043 Before : Extended_Index;
1044 New_Item : Element_Type;
1045 Count : Count_Type := 1)
1047 N : constant Int := Int (Count);
1049 First : constant Int := Int (Index_Type'First);
1050 New_Last_As_Int : Int'Base;
1051 New_Last : Index_Type;
1053 Max_Length : constant UInt := UInt (Count_Type'Last);
1055 Dst : Elements_Access;
1058 if Before < Index_Type'First then
1059 raise Constraint_Error with
1060 "Before index is out of range (too small)";
1063 if Before > Container.Last
1064 and then Before > Container.Last + 1
1066 raise Constraint_Error with
1067 "Before index is out of range (too large)";
1075 Old_Last_As_Int : constant Int := Int (Container.Last);
1078 if Old_Last_As_Int > Int'Last - N then
1079 raise Constraint_Error with "new length is out of range";
1082 New_Last_As_Int := Old_Last_As_Int + N;
1084 if New_Last_As_Int > Int (Index_Type'Last) then
1085 raise Constraint_Error with "new length is out of range";
1088 New_Length := UInt (New_Last_As_Int - First + 1);
1090 if New_Length > Max_Length then
1091 raise Constraint_Error with "new length is out of range";
1094 New_Last := Index_Type (New_Last_As_Int);
1097 if Container.Busy > 0 then
1098 raise Program_Error with
1099 "attempt to tamper with elements (vector is busy)";
1102 if Container.Elements = null then
1103 Container.Elements := new Elements_Type (New_Last);
1104 Container.Last := No_Index;
1106 for J in Container.Elements.EA'Range loop
1107 Container.Elements.EA (J) := new Element_Type'(New_Item);
1108 Container.Last := J;
1114 if New_Last <= Container.Elements.Last then
1116 E : Elements_Array renames Container.Elements.EA;
1119 if Before <= Container.Last then
1121 Index_As_Int : constant Int'Base :=
1122 Index_Type'Pos (Before) + N;
1124 Index : constant Index_Type := Index_Type (Index_As_Int);
1126 J : Index_Type'Base := Before;
1129 E (Index .. New_Last) := E (Before .. Container.Last);
1130 Container.Last := New_Last;
1132 while J < Index loop
1133 E (J) := new Element_Type'(New_Item);
1139 E (J .. Index - 1) := (others => null);
1144 for J in Before .. New_Last loop
1145 E (J) := new Element_Type'(New_Item);
1146 Container.Last := J;
1158 C := UInt'Max (1, Container.Elements.EA'Length); -- ???
1159 while C < New_Length loop
1160 if C > UInt'Last / 2 then
1168 if C > Max_Length then
1172 if Index_Type'First <= 0
1173 and then Index_Type'Last >= 0
1175 CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
1178 CC := UInt (Int (Index_Type'Last) - First + 1);
1186 Dst_Last : constant Index_Type :=
1187 Index_Type (First + UInt'Pos (C) - Int'(1));
1190 Dst := new Elements_Type (Dst_Last);
1194 if Before <= Container.Last then
1196 Index_As_Int : constant Int'Base :=
1197 Index_Type'Pos (Before) + N;
1199 Index : constant Index_Type := Index_Type (Index_As_Int);
1201 Src : Elements_Access := Container.Elements;
1204 Dst.EA (Index_Type'First .. Before - 1) :=
1205 Src.EA (Index_Type'First .. Before - 1);
1207 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1209 Container.Elements := Dst;
1210 Container.Last := New_Last;
1213 for J in Before .. Index - 1 loop
1214 Dst.EA (J) := new Element_Type'(New_Item);
1220 Src : Elements_Access := Container.Elements;
1223 Dst.EA (Index_Type'First .. Container.Last) :=
1224 Src.EA (Index_Type'First .. Container.Last);
1226 Container.Elements := Dst;
1229 for J in Before .. New_Last loop
1230 Dst.EA (J) := new Element_Type'(New_Item);
1231 Container.Last := J;
1238 (Container : in out Vector;
1239 Before : Extended_Index;
1242 N : constant Count_Type := Length (New_Item);
1245 if Before < Index_Type'First then
1246 raise Constraint_Error with
1247 "Before index is out of range (too small)";
1250 if Before > Container.Last
1251 and then Before > Container.Last + 1
1253 raise Constraint_Error with
1254 "Before index is out of range (too large)";
1261 Insert_Space (Container, Before, Count => N);
1264 Dst_Last_As_Int : constant Int'Base :=
1265 Int'Base (Before) + Int'Base (N) - 1;
1267 Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
1269 Dst : Elements_Array renames
1270 Container.Elements.EA (Before .. Dst_Last);
1272 Dst_Index : Index_Type'Base := Before - 1;
1275 if Container'Address /= New_Item'Address then
1277 subtype Src_Index_Subtype is Index_Type'Base range
1278 Index_Type'First .. New_Item.Last;
1280 Src : Elements_Array renames
1281 New_Item.Elements.EA (Src_Index_Subtype);
1284 for Src_Index in Src'Range loop
1285 Dst_Index := Dst_Index + 1;
1287 if Src (Src_Index) /= null then
1288 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1297 subtype Src_Index_Subtype is Index_Type'Base range
1298 Index_Type'First .. Before - 1;
1300 Src : Elements_Array renames
1301 Container.Elements.EA (Src_Index_Subtype);
1304 for Src_Index in Src'Range loop
1305 Dst_Index := Dst_Index + 1;
1307 if Src (Src_Index) /= null then
1308 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1313 if Dst_Last = Container.Last then
1318 subtype Src_Index_Subtype is Index_Type'Base range
1319 Dst_Last + 1 .. Container.Last;
1321 Src : Elements_Array renames
1322 Container.Elements.EA (Src_Index_Subtype);
1325 for Src_Index in Src'Range loop
1326 Dst_Index := Dst_Index + 1;
1328 if Src (Src_Index) /= null then
1329 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1337 (Container : in out Vector;
1341 Index : Index_Type'Base;
1344 if Before.Container /= null
1345 and then Before.Container /= Container'Unchecked_Access
1347 raise Program_Error with "Before cursor denotes wrong container";
1350 if Is_Empty (New_Item) then
1354 if Before.Container = null
1355 or else Before.Index > Container.Last
1357 if Container.Last = Index_Type'Last then
1358 raise Constraint_Error with
1359 "vector is already at its maximum length";
1362 Index := Container.Last + 1;
1365 Index := Before.Index;
1368 Insert (Container, Index, New_Item);
1372 (Container : in out Vector;
1375 Position : out Cursor)
1377 Index : Index_Type'Base;
1380 if Before.Container /= null
1381 and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1383 raise Program_Error with "Before cursor denotes wrong container";
1386 if Is_Empty (New_Item) then
1387 if Before.Container = null
1388 or else Before.Index > Container.Last
1390 Position := No_Element;
1392 Position := (Container'Unchecked_Access, Before.Index);
1398 if Before.Container = null
1399 or else Before.Index > Container.Last
1401 if Container.Last = Index_Type'Last then
1402 raise Constraint_Error with
1403 "vector is already at its maximum length";
1406 Index := Container.Last + 1;
1409 Index := Before.Index;
1412 Insert (Container, Index, New_Item);
1414 Position := Cursor'(Container'Unchecked_Access, Index);
1418 (Container : in out Vector;
1420 New_Item : Element_Type;
1421 Count : Count_Type := 1)
1423 Index : Index_Type'Base;
1426 if Before.Container /= null
1427 and then Before.Container /= Container'Unchecked_Access
1429 raise Program_Error with "Before cursor denotes wrong container";
1436 if Before.Container = null
1437 or else Before.Index > Container.Last
1439 if Container.Last = Index_Type'Last then
1440 raise Constraint_Error with
1441 "vector is already at its maximum length";
1444 Index := Container.Last + 1;
1447 Index := Before.Index;
1450 Insert (Container, Index, New_Item, Count);
1454 (Container : in out Vector;
1456 New_Item : Element_Type;
1457 Position : out Cursor;
1458 Count : Count_Type := 1)
1460 Index : Index_Type'Base;
1463 if Before.Container /= null
1464 and then Before.Container /= Container'Unchecked_Access
1466 raise Program_Error with "Before cursor denotes wrong container";
1470 if Before.Container = null
1471 or else Before.Index > Container.Last
1473 Position := No_Element;
1475 Position := (Container'Unchecked_Access, Before.Index);
1481 if Before.Container = null
1482 or else Before.Index > Container.Last
1484 if Container.Last = Index_Type'Last then
1485 raise Constraint_Error with
1486 "vector is already at its maximum length";
1489 Index := Container.Last + 1;
1492 Index := Before.Index;
1495 Insert (Container, Index, New_Item, Count);
1497 Position := (Container'Unchecked_Access, Index);
1504 procedure Insert_Space
1505 (Container : in out Vector;
1506 Before : Extended_Index;
1507 Count : Count_Type := 1)
1509 N : constant Int := Int (Count);
1511 First : constant Int := Int (Index_Type'First);
1512 New_Last_As_Int : Int'Base;
1513 New_Last : Index_Type;
1515 Max_Length : constant UInt := UInt (Count_Type'Last);
1517 Dst : Elements_Access;
1520 if Before < Index_Type'First then
1521 raise Constraint_Error with
1522 "Before index is out of range (too small)";
1525 if Before > Container.Last
1526 and then Before > Container.Last + 1
1528 raise Constraint_Error with
1529 "Before index is out of range (too large)";
1537 Old_Last_As_Int : constant Int := Int (Container.Last);
1540 if Old_Last_As_Int > Int'Last - N then
1541 raise Constraint_Error with "new length is out of range";
1544 New_Last_As_Int := Old_Last_As_Int + N;
1546 if New_Last_As_Int > Int (Index_Type'Last) then
1547 raise Constraint_Error with "new length is out of range";
1550 New_Length := UInt (New_Last_As_Int - First + 1);
1552 if New_Length > Max_Length then
1553 raise Constraint_Error with "new length is out of range";
1556 New_Last := Index_Type (New_Last_As_Int);
1559 if Container.Busy > 0 then
1560 raise Program_Error with
1561 "attempt to tamper with elements (vector is busy)";
1564 if Container.Elements = null then
1565 Container.Elements := new Elements_Type (New_Last);
1566 Container.Last := New_Last;
1570 if New_Last <= Container.Elements.Last then
1572 E : Elements_Array renames Container.Elements.EA;
1575 if Before <= Container.Last then
1577 Index_As_Int : constant Int'Base :=
1578 Index_Type'Pos (Before) + N;
1580 Index : constant Index_Type := Index_Type (Index_As_Int);
1583 E (Index .. New_Last) := E (Before .. Container.Last);
1584 E (Before .. Index - 1) := (others => null);
1589 Container.Last := New_Last;
1597 C := UInt'Max (1, Container.Elements.EA'Length); -- ???
1598 while C < New_Length loop
1599 if C > UInt'Last / 2 then
1607 if C > Max_Length then
1611 if Index_Type'First <= 0
1612 and then Index_Type'Last >= 0
1614 CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
1617 CC := UInt (Int (Index_Type'Last) - First + 1);
1625 Dst_Last : constant Index_Type :=
1626 Index_Type (First + UInt'Pos (C) - 1);
1629 Dst := new Elements_Type (Dst_Last);
1634 Src : Elements_Access := Container.Elements;
1637 if Before <= Container.Last then
1639 Index_As_Int : constant Int'Base :=
1640 Index_Type'Pos (Before) + N;
1642 Index : constant Index_Type := Index_Type (Index_As_Int);
1645 Dst.EA (Index_Type'First .. Before - 1) :=
1646 Src.EA (Index_Type'First .. Before - 1);
1648 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1652 Dst.EA (Index_Type'First .. Container.Last) :=
1653 Src.EA (Index_Type'First .. Container.Last);
1656 Container.Elements := Dst;
1657 Container.Last := New_Last;
1662 procedure Insert_Space
1663 (Container : in out Vector;
1665 Position : out Cursor;
1666 Count : Count_Type := 1)
1668 Index : Index_Type'Base;
1671 if Before.Container /= null
1672 and then Before.Container /= Container'Unchecked_Access
1674 raise Program_Error with "Before cursor denotes wrong container";
1678 if Before.Container = null
1679 or else Before.Index > Container.Last
1681 Position := No_Element;
1683 Position := (Container'Unchecked_Access, Before.Index);
1689 if Before.Container = null
1690 or else Before.Index > Container.Last
1692 if Container.Last = Index_Type'Last then
1693 raise Constraint_Error with
1694 "vector is already at its maximum length";
1697 Index := Container.Last + 1;
1700 Index := Before.Index;
1703 Insert_Space (Container, Index, Count);
1705 Position := Cursor'(Container'Unchecked_Access, Index);
1712 function Is_Empty (Container : Vector) return Boolean is
1714 return Container.Last < Index_Type'First;
1722 (Container : Vector;
1723 Process : not null access procedure (Position : Cursor))
1725 V : Vector renames Container'Unrestricted_Access.all;
1726 B : Natural renames V.Busy;
1732 for Indx in Index_Type'First .. Container.Last loop
1733 Process (Cursor'(Container'Unchecked_Access, Indx));
1748 function Last (Container : Vector) return Cursor is
1750 if Is_Empty (Container) then
1754 return (Container'Unchecked_Access, Container.Last);
1761 function Last_Element (Container : Vector) return Element_Type is
1763 if Container.Last = No_Index then
1764 raise Constraint_Error with "Container is empty";
1768 EA : constant Element_Access :=
1769 Container.Elements.EA (Container.Last);
1773 raise Constraint_Error with "last element is empty";
1784 function Last_Index (Container : Vector) return Extended_Index is
1786 return Container.Last;
1793 function Length (Container : Vector) return Count_Type is
1794 L : constant Int := Int (Container.Last);
1795 F : constant Int := Int (Index_Type'First);
1796 N : constant Int'Base := L - F + 1;
1799 return Count_Type (N);
1807 (Target : in out Vector;
1808 Source : in out Vector)
1811 if Target'Address = Source'Address then
1815 if Source.Busy > 0 then
1816 raise Program_Error with
1817 "attempt to tamper with elements (Source is busy)";
1820 Clear (Target); -- Checks busy-bit
1823 Target_Elements : constant Elements_Access := Target.Elements;
1825 Target.Elements := Source.Elements;
1826 Source.Elements := Target_Elements;
1829 Target.Last := Source.Last;
1830 Source.Last := No_Index;
1837 function Next (Position : Cursor) return Cursor is
1839 if Position.Container = null then
1843 if Position.Index < Position.Container.Last then
1844 return (Position.Container, Position.Index + 1);
1854 procedure Next (Position : in out Cursor) is
1856 if Position.Container = null then
1860 if Position.Index < Position.Container.Last then
1861 Position.Index := Position.Index + 1;
1863 Position := No_Element;
1871 procedure Prepend (Container : in out Vector; New_Item : Vector) is
1873 Insert (Container, Index_Type'First, New_Item);
1877 (Container : in out Vector;
1878 New_Item : Element_Type;
1879 Count : Count_Type := 1)
1892 procedure Previous (Position : in out Cursor) is
1894 if Position.Container = null then
1898 if Position.Index > Index_Type'First then
1899 Position.Index := Position.Index - 1;
1901 Position := No_Element;
1905 function Previous (Position : Cursor) return Cursor is
1907 if Position.Container = null then
1911 if Position.Index > Index_Type'First then
1912 return (Position.Container, Position.Index - 1);
1922 procedure Query_Element
1923 (Container : Vector;
1925 Process : not null access procedure (Element : Element_Type))
1927 V : Vector renames Container'Unrestricted_Access.all;
1928 B : Natural renames V.Busy;
1929 L : Natural renames V.Lock;
1932 if Index > Container.Last then
1933 raise Constraint_Error with "Index is out of range";
1936 if V.Elements.EA (Index) = null then
1937 raise Constraint_Error with "element is null";
1944 Process (V.Elements.EA (Index).all);
1956 procedure Query_Element
1958 Process : not null access procedure (Element : Element_Type))
1961 if Position.Container = null then
1962 raise Constraint_Error with "Position cursor has no element";
1965 Query_Element (Position.Container.all, Position.Index, Process);
1973 (Stream : not null access Root_Stream_Type'Class;
1974 Container : out Vector)
1976 Length : Count_Type'Base;
1977 Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
1984 Count_Type'Base'Read (Stream, Length);
1986 if Length > Capacity (Container) then
1987 Reserve_Capacity (Container, Capacity => Length);
1990 for J in Count_Type range 1 .. Length loop
1993 Boolean'Read (Stream, B);
1996 Container.Elements.EA (Last) :=
1997 new Element_Type'(Element_Type'Input (Stream));
2000 Container.Last := Last;
2005 (Stream : not null access Root_Stream_Type'Class;
2006 Position : out Cursor)
2009 raise Program_Error with "attempt to stream vector cursor";
2012 ---------------------
2013 -- Replace_Element --
2014 ---------------------
2016 procedure Replace_Element
2017 (Container : in out Vector;
2019 New_Item : Element_Type)
2022 if Index > Container.Last then
2023 raise Constraint_Error with "Index is out of range";
2026 if Container.Lock > 0 then
2027 raise Program_Error with
2028 "attempt to tamper with cursors (vector is locked)";
2032 X : Element_Access := Container.Elements.EA (Index);
2034 Container.Elements.EA (Index) := new Element_Type'(New_Item);
2037 end Replace_Element;
2039 procedure Replace_Element
2040 (Container : in out Vector;
2042 New_Item : Element_Type)
2045 if Position.Container = null then
2046 raise Constraint_Error with "Position cursor has no element";
2049 if Position.Container /= Container'Unrestricted_Access then
2050 raise Program_Error with "Position cursor denotes wrong container";
2053 if Position.Index > Container.Last then
2054 raise Constraint_Error with "Position cursor is out of range";
2057 if Container.Lock > 0 then
2058 raise Program_Error with
2059 "attempt to tamper with cursors (vector is locked)";
2063 X : Element_Access := Container.Elements.EA (Position.Index);
2065 Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
2068 end Replace_Element;
2070 ----------------------
2071 -- Reserve_Capacity --
2072 ----------------------
2074 procedure Reserve_Capacity
2075 (Container : in out Vector;
2076 Capacity : Count_Type)
2078 N : constant Count_Type := Length (Container);
2081 if Capacity = 0 then
2084 X : Elements_Access := Container.Elements;
2086 Container.Elements := null;
2090 elsif N < Container.Elements.EA'Length then
2091 if Container.Busy > 0 then
2092 raise Program_Error with
2093 "attempt to tamper with elements (vector is busy)";
2097 subtype Array_Index_Subtype is Index_Type'Base range
2098 Index_Type'First .. Container.Last;
2100 Src : Elements_Array renames
2101 Container.Elements.EA (Array_Index_Subtype);
2103 X : Elements_Access := Container.Elements;
2106 Container.Elements := new Elements_Type'(Container.Last, Src);
2114 if Container.Elements = null then
2116 Last_As_Int : constant Int'Base :=
2117 Int (Index_Type'First) + Int (Capacity) - 1;
2120 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2121 raise Constraint_Error with "new length is out of range";
2125 Last : constant Index_Type := Index_Type (Last_As_Int);
2128 Container.Elements := new Elements_Type (Last);
2135 if Capacity <= N then
2136 if N < Container.Elements.EA'Length then
2137 if Container.Busy > 0 then
2138 raise Program_Error with
2139 "attempt to tamper with elements (vector is busy)";
2143 subtype Array_Index_Subtype is Index_Type'Base range
2144 Index_Type'First .. Container.Last;
2146 Src : Elements_Array renames
2147 Container.Elements.EA (Array_Index_Subtype);
2149 X : Elements_Access := Container.Elements;
2152 Container.Elements := new Elements_Type'(Container.Last, Src);
2160 if Capacity = Container.Elements.EA'Length then
2164 if Container.Busy > 0 then
2165 raise Program_Error with
2166 "attempt to tamper with elements (vector is busy)";
2170 Last_As_Int : constant Int'Base :=
2171 Int (Index_Type'First) + Int (Capacity) - 1;
2174 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2175 raise Constraint_Error with "new length is out of range";
2179 Last : constant Index_Type := Index_Type (Last_As_Int);
2180 X : Elements_Access := Container.Elements;
2182 subtype Index_Subtype is Index_Type'Base range
2183 Index_Type'First .. Container.Last;
2186 Container.Elements := new Elements_Type (Last);
2189 Src : Elements_Array renames
2190 X.EA (Index_Subtype);
2192 Tgt : Elements_Array renames
2193 Container.Elements.EA (Index_Subtype);
2202 end Reserve_Capacity;
2204 ----------------------
2205 -- Reverse_Elements --
2206 ----------------------
2208 procedure Reverse_Elements (Container : in out Vector) is
2210 if Container.Length <= 1 then
2214 if Container.Lock > 0 then
2215 raise Program_Error with
2216 "attempt to tamper with cursors (vector is locked)";
2222 E : Elements_Array renames Container.Elements.EA;
2225 I := Index_Type'First;
2226 J := Container.Last;
2229 EI : constant Element_Access := E (I);
2240 end Reverse_Elements;
2246 function Reverse_Find
2247 (Container : Vector;
2248 Item : Element_Type;
2249 Position : Cursor := No_Element) return Cursor
2251 Last : Index_Type'Base;
2254 if Position.Container /= null
2255 and then Position.Container /= Container'Unchecked_Access
2257 raise Program_Error with "Position cursor denotes wrong container";
2260 if Position.Container = null
2261 or else Position.Index > Container.Last
2263 Last := Container.Last;
2265 Last := Position.Index;
2268 for Indx in reverse Index_Type'First .. Last loop
2269 if Container.Elements.EA (Indx) /= null
2270 and then Container.Elements.EA (Indx).all = Item
2272 return (Container'Unchecked_Access, Indx);
2279 ------------------------
2280 -- Reverse_Find_Index --
2281 ------------------------
2283 function Reverse_Find_Index
2284 (Container : Vector;
2285 Item : Element_Type;
2286 Index : Index_Type := Index_Type'Last) return Extended_Index
2288 Last : Index_Type'Base;
2291 if Index > Container.Last then
2292 Last := Container.Last;
2297 for Indx in reverse Index_Type'First .. Last loop
2298 if Container.Elements.EA (Indx) /= null
2299 and then Container.Elements.EA (Indx).all = Item
2306 end Reverse_Find_Index;
2308 ---------------------
2309 -- Reverse_Iterate --
2310 ---------------------
2312 procedure Reverse_Iterate
2313 (Container : Vector;
2314 Process : not null access procedure (Position : Cursor))
2316 V : Vector renames Container'Unrestricted_Access.all;
2317 B : Natural renames V.Busy;
2323 for Indx in reverse Index_Type'First .. Container.Last loop
2324 Process (Cursor'(Container'Unchecked_Access, Indx));
2333 end Reverse_Iterate;
2339 procedure Set_Length
2340 (Container : in out Vector;
2341 Length : Count_Type)
2343 N : constant Count_Type := Indefinite_Vectors.Length (Container);
2350 if Container.Busy > 0 then
2351 raise Program_Error with
2352 "attempt to tamper with elements (vector is busy)";
2356 for Index in 1 .. N - Length loop
2358 J : constant Index_Type := Container.Last;
2359 X : Element_Access := Container.Elements.EA (J);
2362 Container.Elements.EA (J) := null;
2363 Container.Last := J - 1;
2371 if Length > Capacity (Container) then
2372 Reserve_Capacity (Container, Capacity => Length);
2376 Last_As_Int : constant Int'Base :=
2377 Int (Index_Type'First) + Int (Length) - 1;
2380 Container.Last := Index_Type (Last_As_Int);
2389 (Container : in out Vector;
2393 if I > Container.Last then
2394 raise Constraint_Error with "I index is out of range";
2397 if J > Container.Last then
2398 raise Constraint_Error with "J index is out of range";
2405 if Container.Lock > 0 then
2406 raise Program_Error with
2407 "attempt to tamper with cursors (vector is locked)";
2411 EI : Element_Access renames Container.Elements.EA (I);
2412 EJ : Element_Access renames Container.Elements.EA (J);
2414 EI_Copy : constant Element_Access := EI;
2423 (Container : in out Vector;
2427 if I.Container = null then
2428 raise Constraint_Error with "I cursor has no element";
2431 if J.Container = null then
2432 raise Constraint_Error with "J cursor has no element";
2435 if I.Container /= Container'Unrestricted_Access then
2436 raise Program_Error with "I cursor denotes wrong container";
2439 if J.Container /= Container'Unrestricted_Access then
2440 raise Program_Error with "J cursor denotes wrong container";
2443 Swap (Container, I.Index, J.Index);
2451 (Container : Vector;
2452 Index : Extended_Index) return Cursor
2455 if Index not in Index_Type'First .. Container.Last then
2459 return Cursor'(Container'Unchecked_Access, Index);
2466 function To_Index (Position : Cursor) return Extended_Index is
2468 if Position.Container = null then
2472 if Position.Index <= Position.Container.Last then
2473 return Position.Index;
2483 function To_Vector (Length : Count_Type) return Vector is
2486 return Empty_Vector;
2490 First : constant Int := Int (Index_Type'First);
2491 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2493 Elements : Elements_Access;
2496 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2497 raise Constraint_Error with "Length is out of range";
2500 Last := Index_Type (Last_As_Int);
2501 Elements := new Elements_Type (Last);
2503 return (Controlled with Elements, Last, 0, 0);
2508 (New_Item : Element_Type;
2509 Length : Count_Type) return Vector
2513 return Empty_Vector;
2517 First : constant Int := Int (Index_Type'First);
2518 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2519 Last : Index_Type'Base;
2520 Elements : Elements_Access;
2523 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2524 raise Constraint_Error with "Length is out of range";
2527 Last := Index_Type (Last_As_Int);
2528 Elements := new Elements_Type (Last);
2530 Last := Index_Type'First;
2534 Elements.EA (Last) := new Element_Type'(New_Item);
2535 exit when Last = Elements.Last;
2541 for J in Index_Type'First .. Last - 1 loop
2542 Free (Elements.EA (J));
2549 return (Controlled with Elements, Last, 0, 0);
2553 --------------------
2554 -- Update_Element --
2555 --------------------
2557 procedure Update_Element
2558 (Container : in out Vector;
2560 Process : not null access procedure (Element : in out Element_Type))
2562 B : Natural renames Container.Busy;
2563 L : Natural renames Container.Lock;
2566 if Index > Container.Last then
2567 raise Constraint_Error with "Index is out of range";
2570 if Container.Elements.EA (Index) = null then
2571 raise Constraint_Error with "element is null";
2578 Process (Container.Elements.EA (Index).all);
2590 procedure Update_Element
2591 (Container : in out Vector;
2593 Process : not null access procedure (Element : in out Element_Type))
2596 if Position.Container = null then
2597 raise Constraint_Error with "Position cursor has no element";
2600 if Position.Container /= Container'Unrestricted_Access then
2601 raise Program_Error with "Position cursor denotes wrong container";
2604 Update_Element (Container, Position.Index, Process);
2612 (Stream : not null access Root_Stream_Type'Class;
2615 N : constant Count_Type := Length (Container);
2618 Count_Type'Base'Write (Stream, N);
2625 E : Elements_Array renames Container.Elements.EA;
2628 for Indx in Index_Type'First .. Container.Last loop
2629 if E (Indx) = null then
2630 Boolean'Write (Stream, False);
2632 Boolean'Write (Stream, True);
2633 Element_Type'Output (Stream, E (Indx).all);
2640 (Stream : not null access Root_Stream_Type'Class;
2644 raise Program_Error with "attempt to stream vector cursor";
2647 end Ada.Containers.Indefinite_Vectors;