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-2009, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada.Containers.Generic_Array_Sort;
31 with Ada.Unchecked_Deallocation;
32 with System; use type System.Address;
34 package body Ada.Containers.Indefinite_Vectors is
36 type Int is range System.Min_Int .. System.Max_Int;
37 type UInt is mod System.Max_Binary_Modulus;
40 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
43 new Ada.Unchecked_Deallocation (Element_Type, Element_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_Array renames
61 Right.Elements.EA (Index_Type'First .. Right.Last);
63 Elements : Elements_Access :=
64 new Elements_Type (Right.Last);
67 for I in Elements.EA'Range loop
69 if RE (I) /= null then
70 Elements.EA (I) := new Element_Type'(RE (I).all);
75 for J in Index_Type'First .. I - 1 loop
76 Free (Elements.EA (J));
84 return (Controlled with Elements, Right.Last, 0, 0);
91 LE : Elements_Array renames
92 Left.Elements.EA (Index_Type'First .. Left.Last);
94 Elements : Elements_Access :=
95 new Elements_Type (Left.Last);
98 for I in Elements.EA'Range loop
100 if LE (I) /= null then
101 Elements.EA (I) := new Element_Type'(LE (I).all);
106 for J in Index_Type'First .. I - 1 loop
107 Free (Elements.EA (J));
115 return (Controlled with Elements, Left.Last, 0, 0);
120 N : constant Int'Base := Int (LN) + Int (RN);
121 Last_As_Int : Int'Base;
124 if Int (No_Index) > Int'Last - N then
125 raise Constraint_Error with "new length is out of range";
128 Last_As_Int := Int (No_Index) + N;
130 if Last_As_Int > Int (Index_Type'Last) then
131 raise Constraint_Error with "new length is out of range";
135 Last : constant Index_Type := Index_Type (Last_As_Int);
137 LE : Elements_Array renames
138 Left.Elements.EA (Index_Type'First .. Left.Last);
140 RE : Elements_Array renames
141 Right.Elements.EA (Index_Type'First .. Right.Last);
143 Elements : Elements_Access := new Elements_Type (Last);
145 I : Index_Type'Base := No_Index;
148 for LI in LE'Range loop
152 if LE (LI) /= null then
153 Elements.EA (I) := new Element_Type'(LE (LI).all);
158 for J in Index_Type'First .. I - 1 loop
159 Free (Elements.EA (J));
167 for RI in RE'Range loop
171 if RE (RI) /= null then
172 Elements.EA (I) := new Element_Type'(RE (RI).all);
177 for J in Index_Type'First .. I - 1 loop
178 Free (Elements.EA (J));
186 return (Controlled with Elements, Last, 0, 0);
191 function "&" (Left : Vector; Right : Element_Type) return Vector is
192 LN : constant Count_Type := Length (Left);
197 Elements : Elements_Access := new Elements_Type (Index_Type'First);
201 Elements.EA (Index_Type'First) := new Element_Type'(Right);
208 return (Controlled with Elements, Index_Type'First, 0, 0);
213 Last_As_Int : Int'Base;
216 if Int (Index_Type'First) > Int'Last - Int (LN) then
217 raise Constraint_Error with "new length is out of range";
220 Last_As_Int := Int (Index_Type'First) + Int (LN);
222 if Last_As_Int > Int (Index_Type'Last) then
223 raise Constraint_Error with "new length is out of range";
227 Last : constant Index_Type := Index_Type (Last_As_Int);
229 LE : Elements_Array renames
230 Left.Elements.EA (Index_Type'First .. Left.Last);
232 Elements : Elements_Access :=
233 new Elements_Type (Last);
236 for I in LE'Range loop
238 if LE (I) /= null then
239 Elements.EA (I) := new Element_Type'(LE (I).all);
244 for J in Index_Type'First .. I - 1 loop
245 Free (Elements.EA (J));
254 Elements.EA (Last) := new Element_Type'(Right);
258 for J in Index_Type'First .. Last - 1 loop
259 Free (Elements.EA (J));
266 return (Controlled with Elements, Last, 0, 0);
271 function "&" (Left : Element_Type; Right : Vector) return Vector is
272 RN : constant Count_Type := Length (Right);
277 Elements : Elements_Access := new Elements_Type (Index_Type'First);
281 Elements.EA (Index_Type'First) := new Element_Type'(Left);
288 return (Controlled with Elements, Index_Type'First, 0, 0);
293 Last_As_Int : Int'Base;
296 if Int (Index_Type'First) > Int'Last - Int (RN) then
297 raise Constraint_Error with "new length is out of range";
300 Last_As_Int := Int (Index_Type'First) + Int (RN);
302 if Last_As_Int > Int (Index_Type'Last) then
303 raise Constraint_Error with "new length is out of range";
307 Last : constant Index_Type := Index_Type (Last_As_Int);
309 RE : Elements_Array renames
310 Right.Elements.EA (Index_Type'First .. Right.Last);
312 Elements : Elements_Access :=
313 new Elements_Type (Last);
315 I : Index_Type'Base := Index_Type'First;
319 Elements.EA (I) := new Element_Type'(Left);
326 for RI in RE'Range loop
330 if RE (RI) /= null then
331 Elements.EA (I) := new Element_Type'(RE (RI).all);
336 for J in Index_Type'First .. I - 1 loop
337 Free (Elements.EA (J));
345 return (Controlled with Elements, Last, 0, 0);
350 function "&" (Left, Right : Element_Type) return Vector is
352 if Index_Type'First >= Index_Type'Last then
353 raise Constraint_Error with "new length is out of range";
357 Last : constant Index_Type := Index_Type'First + 1;
358 Elements : Elements_Access := new Elements_Type (Last);
362 Elements.EA (Index_Type'First) := new Element_Type'(Left);
370 Elements.EA (Last) := new Element_Type'(Right);
373 Free (Elements.EA (Index_Type'First));
378 return (Controlled with Elements, Last, 0, 0);
386 overriding function "=" (Left, Right : Vector) return Boolean is
388 if Left'Address = Right'Address then
392 if Left.Last /= Right.Last then
396 for J in Index_Type'First .. Left.Last loop
397 if Left.Elements.EA (J) = null then
398 if Right.Elements.EA (J) /= null then
402 elsif Right.Elements.EA (J) = null then
405 elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
417 procedure Adjust (Container : in out Vector) is
419 if Container.Last = No_Index then
420 Container.Elements := null;
425 L : constant Index_Type := Container.Last;
426 E : Elements_Array renames
427 Container.Elements.EA (Index_Type'First .. L);
430 Container.Elements := null;
431 Container.Last := No_Index;
435 Container.Elements := new Elements_Type (L);
437 for I in E'Range loop
438 if E (I) /= null then
439 Container.Elements.EA (I) := new Element_Type'(E (I).all);
451 procedure Append (Container : in out Vector; New_Item : Vector) is
453 if Is_Empty (New_Item) then
457 if Container.Last = Index_Type'Last then
458 raise Constraint_Error with "vector is already at its maximum length";
468 (Container : in out Vector;
469 New_Item : Element_Type;
470 Count : Count_Type := 1)
477 if Container.Last = Index_Type'Last then
478 raise Constraint_Error with "vector is already at its maximum length";
492 function Capacity (Container : Vector) return Count_Type is
494 if Container.Elements = null then
498 return Container.Elements.EA'Length;
505 procedure Clear (Container : in out Vector) is
507 if Container.Busy > 0 then
508 raise Program_Error with
509 "attempt to tamper with elements (vector is busy)";
512 while Container.Last >= Index_Type'First loop
514 X : Element_Access := Container.Elements.EA (Container.Last);
516 Container.Elements.EA (Container.Last) := null;
517 Container.Last := Container.Last - 1;
529 Item : Element_Type) return Boolean
532 return Find_Index (Container, Item) /= No_Index;
540 (Container : in out Vector;
541 Index : Extended_Index;
542 Count : Count_Type := 1)
545 if Index < Index_Type'First then
546 raise Constraint_Error with "Index is out of range (too small)";
549 if Index > Container.Last then
550 if Index > Container.Last + 1 then
551 raise Constraint_Error with "Index is out of range (too large)";
561 if Container.Busy > 0 then
562 raise Program_Error with
563 "attempt to tamper with elements (vector is busy)";
567 Index_As_Int : constant Int := Int (Index);
568 Old_Last_As_Int : constant Int := Int (Container.Last);
570 Count1 : constant Int'Base := Int (Count);
571 Count2 : constant Int'Base := Old_Last_As_Int - Index_As_Int + 1;
572 N : constant Int'Base := Int'Min (Count1, Count2);
574 J_As_Int : constant Int'Base := Index_As_Int + N;
575 E : Elements_Array renames Container.Elements.EA;
578 if J_As_Int > Old_Last_As_Int then
579 while Container.Last >= Index loop
581 K : constant Index_Type := Container.Last;
582 X : Element_Access := E (K);
586 Container.Last := K - 1;
593 J : constant Index_Type := Index_Type (J_As_Int);
595 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
596 New_Last : constant Index_Type :=
597 Index_Type (New_Last_As_Int);
600 for K in Index .. J - 1 loop
602 X : Element_Access := E (K);
609 E (Index .. New_Last) := E (J .. Container.Last);
610 Container.Last := New_Last;
617 (Container : in out Vector;
618 Position : in out Cursor;
619 Count : Count_Type := 1)
621 pragma Warnings (Off, Position);
624 if Position.Container = null then
625 raise Constraint_Error with "Position cursor has no element";
628 if Position.Container /= Container'Unrestricted_Access then
629 raise Program_Error with "Position cursor denotes wrong container";
632 if Position.Index > Container.Last then
633 raise Program_Error with "Position index is out of range";
636 Delete (Container, Position.Index, Count);
638 Position := No_Element;
645 procedure Delete_First
646 (Container : in out Vector;
647 Count : Count_Type := 1)
654 if Count >= Length (Container) then
659 Delete (Container, Index_Type'First, Count);
666 procedure Delete_Last
667 (Container : in out Vector;
668 Count : Count_Type := 1)
670 N : constant Count_Type := Length (Container);
679 if Container.Busy > 0 then
680 raise Program_Error with
681 "attempt to tamper with elements (vector is busy)";
685 E : Elements_Array renames Container.Elements.EA;
688 for Indx in 1 .. Count_Type'Min (Count, N) loop
690 J : constant Index_Type := Container.Last;
691 X : Element_Access := E (J);
695 Container.Last := J - 1;
708 Index : Index_Type) return Element_Type
711 if Index > Container.Last then
712 raise Constraint_Error with "Index is out of range";
716 EA : constant Element_Access := Container.Elements.EA (Index);
720 raise Constraint_Error with "element is empty";
727 function Element (Position : Cursor) return Element_Type is
729 if Position.Container = null then
730 raise Constraint_Error with "Position cursor has no element";
733 if Position.Index > Position.Container.Last then
734 raise Constraint_Error with "Position cursor is out of range";
738 EA : constant Element_Access :=
739 Position.Container.Elements.EA (Position.Index);
743 raise Constraint_Error with "element is empty";
754 procedure Finalize (Container : in out Vector) is
756 Clear (Container); -- Checks busy-bit
759 X : Elements_Access := Container.Elements;
761 Container.Elements := null;
773 Position : Cursor := No_Element) return Cursor
776 if Position.Container /= null then
777 if Position.Container /= Container'Unrestricted_Access then
778 raise Program_Error with "Position cursor denotes wrong container";
781 if Position.Index > Container.Last then
782 raise Program_Error with "Position index is out of range";
786 for J in Position.Index .. Container.Last loop
787 if Container.Elements.EA (J) /= null
788 and then Container.Elements.EA (J).all = Item
790 return (Container'Unchecked_Access, J);
804 Index : Index_Type := Index_Type'First) return Extended_Index
807 for Indx in Index .. Container.Last loop
808 if Container.Elements.EA (Indx) /= null
809 and then Container.Elements.EA (Indx).all = Item
822 function First (Container : Vector) return Cursor is
824 if Is_Empty (Container) then
828 return (Container'Unchecked_Access, Index_Type'First);
835 function First_Element (Container : Vector) return Element_Type is
837 if Container.Last = No_Index then
838 raise Constraint_Error with "Container is empty";
842 EA : constant Element_Access :=
843 Container.Elements.EA (Index_Type'First);
847 raise Constraint_Error with "first element is empty";
858 function First_Index (Container : Vector) return Index_Type is
859 pragma Unreferenced (Container);
861 return Index_Type'First;
864 ---------------------
865 -- Generic_Sorting --
866 ---------------------
868 package body Generic_Sorting is
870 -----------------------
871 -- Local Subprograms --
872 -----------------------
874 function Is_Less (L, R : Element_Access) return Boolean;
875 pragma Inline (Is_Less);
881 function Is_Less (L, R : Element_Access) return Boolean is
888 return L.all < R.all;
896 function Is_Sorted (Container : Vector) return Boolean is
898 if Container.Last <= Index_Type'First then
903 E : Elements_Array renames Container.Elements.EA;
905 for I in Index_Type'First .. Container.Last - 1 loop
906 if Is_Less (E (I + 1), E (I)) then
919 procedure Merge (Target, Source : in out Vector) is
920 I, J : Index_Type'Base;
923 if Target.Last < Index_Type'First then
924 Move (Target => Target, Source => Source);
928 if Target'Address = Source'Address then
932 if Source.Last < Index_Type'First then
936 if Source.Busy > 0 then
937 raise Program_Error with
938 "attempt to tamper with elements (vector is busy)";
941 I := Target.Last; -- original value (before Set_Length)
942 Target.Set_Length (Length (Target) + Length (Source));
944 J := Target.Last; -- new value (after Set_Length)
945 while Source.Last >= Index_Type'First loop
947 (Source.Last <= Index_Type'First
949 (Source.Elements.EA (Source.Last),
950 Source.Elements.EA (Source.Last - 1))));
952 if I < Index_Type'First then
954 Src : Elements_Array renames
955 Source.Elements.EA (Index_Type'First .. Source.Last);
958 Target.Elements.EA (Index_Type'First .. J) := Src;
959 Src := (others => null);
962 Source.Last := No_Index;
967 (I <= Index_Type'First
969 (Target.Elements.EA (I),
970 Target.Elements.EA (I - 1))));
973 Src : Element_Access renames Source.Elements.EA (Source.Last);
974 Tgt : Element_Access renames Target.Elements.EA (I);
977 if Is_Less (Src, Tgt) then
978 Target.Elements.EA (J) := Tgt;
983 Target.Elements.EA (J) := Src;
985 Source.Last := Source.Last - 1;
997 procedure Sort (Container : in out Vector) is
999 procedure Sort is new Generic_Array_Sort
1000 (Index_Type => Index_Type,
1001 Element_Type => Element_Access,
1002 Array_Type => Elements_Array,
1005 -- Start of processing for Sort
1008 if Container.Last <= Index_Type'First then
1012 if Container.Lock > 0 then
1013 raise Program_Error with
1014 "attempt to tamper with cursors (vector is locked)";
1017 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1020 end Generic_Sorting;
1026 function Has_Element (Position : Cursor) return Boolean is
1028 if Position.Container = null then
1032 return Position.Index <= Position.Container.Last;
1040 (Container : in out Vector;
1041 Before : Extended_Index;
1042 New_Item : Element_Type;
1043 Count : Count_Type := 1)
1045 N : constant Int := Int (Count);
1047 First : constant Int := Int (Index_Type'First);
1048 New_Last_As_Int : Int'Base;
1049 New_Last : Index_Type;
1051 Max_Length : constant UInt := UInt (Count_Type'Last);
1053 Dst : Elements_Access;
1056 if Before < Index_Type'First then
1057 raise Constraint_Error with
1058 "Before index is out of range (too small)";
1061 if Before > Container.Last
1062 and then Before > Container.Last + 1
1064 raise Constraint_Error with
1065 "Before index is out of range (too large)";
1073 Old_Last_As_Int : constant Int := Int (Container.Last);
1076 if Old_Last_As_Int > Int'Last - N then
1077 raise Constraint_Error with "new length is out of range";
1080 New_Last_As_Int := Old_Last_As_Int + N;
1082 if New_Last_As_Int > Int (Index_Type'Last) then
1083 raise Constraint_Error with "new length is out of range";
1086 New_Length := UInt (New_Last_As_Int - First + 1);
1088 if New_Length > Max_Length then
1089 raise Constraint_Error with "new length is out of range";
1092 New_Last := Index_Type (New_Last_As_Int);
1095 if Container.Busy > 0 then
1096 raise Program_Error with
1097 "attempt to tamper with elements (vector is busy)";
1100 if Container.Elements = null then
1101 Container.Elements := new Elements_Type (New_Last);
1102 Container.Last := No_Index;
1104 for J in Container.Elements.EA'Range loop
1105 Container.Elements.EA (J) := new Element_Type'(New_Item);
1106 Container.Last := J;
1112 if New_Last <= Container.Elements.Last then
1114 E : Elements_Array renames Container.Elements.EA;
1117 if Before <= Container.Last then
1119 Index_As_Int : constant Int'Base :=
1120 Index_Type'Pos (Before) + N;
1122 Index : constant Index_Type := Index_Type (Index_As_Int);
1124 J : Index_Type'Base;
1127 -- The new items are being inserted in the middle of the
1128 -- array, in the range [Before, Index). Copy the existing
1129 -- elements to the end of the array, to make room for the
1132 E (Index .. New_Last) := E (Before .. Container.Last);
1133 Container.Last := New_Last;
1135 -- We have copied the existing items up to the end of the
1136 -- array, to make room for the new items in the middle of
1137 -- the array. Now we actually allocate the new items.
1139 -- Note: initialize J outside loop to make it clear that
1140 -- J always has a value if the exception handler triggers.
1144 while J < Index loop
1145 E (J) := new Element_Type'(New_Item);
1152 -- Values in the range [Before, J) were successfully
1153 -- allocated, but values in the range [J, Index) are
1154 -- stale (these array positions contain copies of the
1155 -- old items, that did not get assigned a new item,
1156 -- because the allocation failed). We must finish what
1157 -- we started by clearing out all of the stale values,
1158 -- leaving a "hole" in the middle of the array.
1160 E (J .. Index - 1) := (others => null);
1166 for J in Before .. New_Last loop
1167 E (J) := new Element_Type'(New_Item);
1168 Container.Last := J;
1176 -- There follows LOTS of code completely devoid of comments ???
1177 -- This is not our general style ???
1183 C := UInt'Max (1, Container.Elements.EA'Length); -- ???
1184 while C < New_Length loop
1185 if C > UInt'Last / 2 then
1193 if C > Max_Length then
1197 if Index_Type'First <= 0
1198 and then Index_Type'Last >= 0
1200 CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
1202 CC := UInt (Int (Index_Type'Last) - First + 1);
1210 Dst_Last : constant Index_Type :=
1211 Index_Type (First + UInt'Pos (C) - Int'(1));
1214 Dst := new Elements_Type (Dst_Last);
1218 if Before <= Container.Last then
1220 Index_As_Int : constant Int'Base :=
1221 Index_Type'Pos (Before) + N;
1223 Index : constant Index_Type := Index_Type (Index_As_Int);
1225 Src : Elements_Access := Container.Elements;
1228 Dst.EA (Index_Type'First .. Before - 1) :=
1229 Src.EA (Index_Type'First .. Before - 1);
1231 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1233 Container.Elements := Dst;
1234 Container.Last := New_Last;
1237 for J in Before .. Index - 1 loop
1238 Dst.EA (J) := new Element_Type'(New_Item);
1244 Src : Elements_Access := Container.Elements;
1247 Dst.EA (Index_Type'First .. Container.Last) :=
1248 Src.EA (Index_Type'First .. Container.Last);
1250 Container.Elements := Dst;
1253 for J in Before .. New_Last loop
1254 Dst.EA (J) := new Element_Type'(New_Item);
1255 Container.Last := J;
1262 (Container : in out Vector;
1263 Before : Extended_Index;
1266 N : constant Count_Type := Length (New_Item);
1269 if Before < Index_Type'First then
1270 raise Constraint_Error with
1271 "Before index is out of range (too small)";
1274 if Before > Container.Last
1275 and then Before > Container.Last + 1
1277 raise Constraint_Error with
1278 "Before index is out of range (too large)";
1285 Insert_Space (Container, Before, Count => N);
1288 Dst_Last_As_Int : constant Int'Base :=
1289 Int'Base (Before) + Int'Base (N) - 1;
1291 Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
1293 Dst : Elements_Array renames
1294 Container.Elements.EA (Before .. Dst_Last);
1296 Dst_Index : Index_Type'Base := Before - 1;
1299 if Container'Address /= New_Item'Address then
1301 subtype Src_Index_Subtype is Index_Type'Base range
1302 Index_Type'First .. New_Item.Last;
1304 Src : Elements_Array renames
1305 New_Item.Elements.EA (Src_Index_Subtype);
1308 for Src_Index in Src'Range loop
1309 Dst_Index := Dst_Index + 1;
1311 if Src (Src_Index) /= null then
1312 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1321 subtype Src_Index_Subtype is Index_Type'Base range
1322 Index_Type'First .. Before - 1;
1324 Src : Elements_Array renames
1325 Container.Elements.EA (Src_Index_Subtype);
1328 for Src_Index in Src'Range loop
1329 Dst_Index := Dst_Index + 1;
1331 if Src (Src_Index) /= null then
1332 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1337 if Dst_Last = Container.Last then
1342 subtype Src_Index_Subtype is Index_Type'Base range
1343 Dst_Last + 1 .. Container.Last;
1345 Src : Elements_Array renames
1346 Container.Elements.EA (Src_Index_Subtype);
1349 for Src_Index in Src'Range loop
1350 Dst_Index := Dst_Index + 1;
1352 if Src (Src_Index) /= null then
1353 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1361 (Container : in out Vector;
1365 Index : Index_Type'Base;
1368 if Before.Container /= null
1369 and then Before.Container /= Container'Unchecked_Access
1371 raise Program_Error with "Before cursor denotes wrong container";
1374 if Is_Empty (New_Item) then
1378 if Before.Container = null
1379 or else Before.Index > Container.Last
1381 if Container.Last = Index_Type'Last then
1382 raise Constraint_Error with
1383 "vector is already at its maximum length";
1386 Index := Container.Last + 1;
1389 Index := Before.Index;
1392 Insert (Container, Index, New_Item);
1396 (Container : in out Vector;
1399 Position : out Cursor)
1401 Index : Index_Type'Base;
1404 if Before.Container /= null
1405 and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1407 raise Program_Error with "Before cursor denotes wrong container";
1410 if Is_Empty (New_Item) then
1411 if Before.Container = null
1412 or else Before.Index > Container.Last
1414 Position := No_Element;
1416 Position := (Container'Unchecked_Access, Before.Index);
1422 if Before.Container = null
1423 or else Before.Index > Container.Last
1425 if Container.Last = Index_Type'Last then
1426 raise Constraint_Error with
1427 "vector is already at its maximum length";
1430 Index := Container.Last + 1;
1433 Index := Before.Index;
1436 Insert (Container, Index, New_Item);
1438 Position := Cursor'(Container'Unchecked_Access, Index);
1442 (Container : in out Vector;
1444 New_Item : Element_Type;
1445 Count : Count_Type := 1)
1447 Index : Index_Type'Base;
1450 if Before.Container /= null
1451 and then Before.Container /= Container'Unchecked_Access
1453 raise Program_Error with "Before cursor denotes wrong container";
1460 if Before.Container = null
1461 or else Before.Index > Container.Last
1463 if Container.Last = Index_Type'Last then
1464 raise Constraint_Error with
1465 "vector is already at its maximum length";
1468 Index := Container.Last + 1;
1471 Index := Before.Index;
1474 Insert (Container, Index, New_Item, Count);
1478 (Container : in out Vector;
1480 New_Item : Element_Type;
1481 Position : out Cursor;
1482 Count : Count_Type := 1)
1484 Index : Index_Type'Base;
1487 if Before.Container /= null
1488 and then Before.Container /= Container'Unchecked_Access
1490 raise Program_Error with "Before cursor denotes wrong container";
1494 if Before.Container = null
1495 or else Before.Index > Container.Last
1497 Position := No_Element;
1499 Position := (Container'Unchecked_Access, Before.Index);
1505 if Before.Container = null
1506 or else Before.Index > Container.Last
1508 if Container.Last = Index_Type'Last then
1509 raise Constraint_Error with
1510 "vector is already at its maximum length";
1513 Index := Container.Last + 1;
1516 Index := Before.Index;
1519 Insert (Container, Index, New_Item, Count);
1521 Position := (Container'Unchecked_Access, Index);
1528 procedure Insert_Space
1529 (Container : in out Vector;
1530 Before : Extended_Index;
1531 Count : Count_Type := 1)
1533 N : constant Int := Int (Count);
1535 First : constant Int := Int (Index_Type'First);
1536 New_Last_As_Int : Int'Base;
1537 New_Last : Index_Type;
1539 Max_Length : constant UInt := UInt (Count_Type'Last);
1541 Dst : Elements_Access;
1544 if Before < Index_Type'First then
1545 raise Constraint_Error with
1546 "Before index is out of range (too small)";
1549 if Before > Container.Last
1550 and then Before > Container.Last + 1
1552 raise Constraint_Error with
1553 "Before index is out of range (too large)";
1561 Old_Last_As_Int : constant Int := Int (Container.Last);
1564 if Old_Last_As_Int > Int'Last - N then
1565 raise Constraint_Error with "new length is out of range";
1568 New_Last_As_Int := Old_Last_As_Int + N;
1570 if New_Last_As_Int > Int (Index_Type'Last) then
1571 raise Constraint_Error with "new length is out of range";
1574 New_Length := UInt (New_Last_As_Int - First + 1);
1576 if New_Length > Max_Length then
1577 raise Constraint_Error with "new length is out of range";
1580 New_Last := Index_Type (New_Last_As_Int);
1583 if Container.Busy > 0 then
1584 raise Program_Error with
1585 "attempt to tamper with elements (vector is busy)";
1588 if Container.Elements = null then
1589 Container.Elements := new Elements_Type (New_Last);
1590 Container.Last := New_Last;
1594 if New_Last <= Container.Elements.Last then
1596 E : Elements_Array renames Container.Elements.EA;
1599 if Before <= Container.Last then
1601 Index_As_Int : constant Int'Base :=
1602 Index_Type'Pos (Before) + N;
1604 Index : constant Index_Type := Index_Type (Index_As_Int);
1607 E (Index .. New_Last) := E (Before .. Container.Last);
1608 E (Before .. Index - 1) := (others => null);
1613 Container.Last := New_Last;
1621 C := UInt'Max (1, Container.Elements.EA'Length); -- ???
1622 while C < New_Length loop
1623 if C > UInt'Last / 2 then
1631 if C > Max_Length then
1635 if Index_Type'First <= 0
1636 and then Index_Type'Last >= 0
1638 CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
1640 CC := UInt (Int (Index_Type'Last) - First + 1);
1648 Dst_Last : constant Index_Type :=
1649 Index_Type (First + UInt'Pos (C) - 1);
1652 Dst := new Elements_Type (Dst_Last);
1657 Src : Elements_Access := Container.Elements;
1660 if Before <= Container.Last then
1662 Index_As_Int : constant Int'Base :=
1663 Index_Type'Pos (Before) + N;
1665 Index : constant Index_Type := Index_Type (Index_As_Int);
1668 Dst.EA (Index_Type'First .. Before - 1) :=
1669 Src.EA (Index_Type'First .. Before - 1);
1671 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1675 Dst.EA (Index_Type'First .. Container.Last) :=
1676 Src.EA (Index_Type'First .. Container.Last);
1679 Container.Elements := Dst;
1680 Container.Last := New_Last;
1685 procedure Insert_Space
1686 (Container : in out Vector;
1688 Position : out Cursor;
1689 Count : Count_Type := 1)
1691 Index : Index_Type'Base;
1694 if Before.Container /= null
1695 and then Before.Container /= Container'Unchecked_Access
1697 raise Program_Error with "Before cursor denotes wrong container";
1701 if Before.Container = null
1702 or else Before.Index > Container.Last
1704 Position := No_Element;
1706 Position := (Container'Unchecked_Access, Before.Index);
1712 if Before.Container = null
1713 or else Before.Index > Container.Last
1715 if Container.Last = Index_Type'Last then
1716 raise Constraint_Error with
1717 "vector is already at its maximum length";
1720 Index := Container.Last + 1;
1723 Index := Before.Index;
1726 Insert_Space (Container, Index, Count);
1728 Position := Cursor'(Container'Unchecked_Access, Index);
1735 function Is_Empty (Container : Vector) return Boolean is
1737 return Container.Last < Index_Type'First;
1745 (Container : Vector;
1746 Process : not null access procedure (Position : Cursor))
1748 V : Vector renames Container'Unrestricted_Access.all;
1749 B : Natural renames V.Busy;
1755 for Indx in Index_Type'First .. Container.Last loop
1756 Process (Cursor'(Container'Unchecked_Access, Indx));
1771 function Last (Container : Vector) return Cursor is
1773 if Is_Empty (Container) then
1777 return (Container'Unchecked_Access, Container.Last);
1784 function Last_Element (Container : Vector) return Element_Type is
1786 if Container.Last = No_Index then
1787 raise Constraint_Error with "Container is empty";
1791 EA : constant Element_Access :=
1792 Container.Elements.EA (Container.Last);
1796 raise Constraint_Error with "last element is empty";
1807 function Last_Index (Container : Vector) return Extended_Index is
1809 return Container.Last;
1816 function Length (Container : Vector) return Count_Type is
1817 L : constant Int := Int (Container.Last);
1818 F : constant Int := Int (Index_Type'First);
1819 N : constant Int'Base := L - F + 1;
1822 return Count_Type (N);
1830 (Target : in out Vector;
1831 Source : in out Vector)
1834 if Target'Address = Source'Address then
1838 if Source.Busy > 0 then
1839 raise Program_Error with
1840 "attempt to tamper with elements (Source is busy)";
1843 Clear (Target); -- Checks busy-bit
1846 Target_Elements : constant Elements_Access := Target.Elements;
1848 Target.Elements := Source.Elements;
1849 Source.Elements := Target_Elements;
1852 Target.Last := Source.Last;
1853 Source.Last := No_Index;
1860 function Next (Position : Cursor) return Cursor is
1862 if Position.Container = null then
1866 if Position.Index < Position.Container.Last then
1867 return (Position.Container, Position.Index + 1);
1877 procedure Next (Position : in out Cursor) is
1879 if Position.Container = null then
1883 if Position.Index < Position.Container.Last then
1884 Position.Index := Position.Index + 1;
1886 Position := No_Element;
1894 procedure Prepend (Container : in out Vector; New_Item : Vector) is
1896 Insert (Container, Index_Type'First, New_Item);
1900 (Container : in out Vector;
1901 New_Item : Element_Type;
1902 Count : Count_Type := 1)
1915 procedure Previous (Position : in out Cursor) is
1917 if Position.Container = null then
1921 if Position.Index > Index_Type'First then
1922 Position.Index := Position.Index - 1;
1924 Position := No_Element;
1928 function Previous (Position : Cursor) return Cursor is
1930 if Position.Container = null then
1934 if Position.Index > Index_Type'First then
1935 return (Position.Container, Position.Index - 1);
1945 procedure Query_Element
1946 (Container : Vector;
1948 Process : not null access procedure (Element : Element_Type))
1950 V : Vector renames Container'Unrestricted_Access.all;
1951 B : Natural renames V.Busy;
1952 L : Natural renames V.Lock;
1955 if Index > Container.Last then
1956 raise Constraint_Error with "Index is out of range";
1959 if V.Elements.EA (Index) = null then
1960 raise Constraint_Error with "element is null";
1967 Process (V.Elements.EA (Index).all);
1979 procedure Query_Element
1981 Process : not null access procedure (Element : Element_Type))
1984 if Position.Container = null then
1985 raise Constraint_Error with "Position cursor has no element";
1988 Query_Element (Position.Container.all, Position.Index, Process);
1996 (Stream : not null access Root_Stream_Type'Class;
1997 Container : out Vector)
1999 Length : Count_Type'Base;
2000 Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
2007 Count_Type'Base'Read (Stream, Length);
2009 if Length > Capacity (Container) then
2010 Reserve_Capacity (Container, Capacity => Length);
2013 for J in Count_Type range 1 .. Length loop
2016 Boolean'Read (Stream, B);
2019 Container.Elements.EA (Last) :=
2020 new Element_Type'(Element_Type'Input (Stream));
2023 Container.Last := Last;
2028 (Stream : not null access Root_Stream_Type'Class;
2029 Position : out Cursor)
2032 raise Program_Error with "attempt to stream vector cursor";
2035 ---------------------
2036 -- Replace_Element --
2037 ---------------------
2039 procedure Replace_Element
2040 (Container : in out Vector;
2042 New_Item : Element_Type)
2045 if Index > Container.Last then
2046 raise Constraint_Error with "Index is out of range";
2049 if Container.Lock > 0 then
2050 raise Program_Error with
2051 "attempt to tamper with cursors (vector is locked)";
2055 X : Element_Access := Container.Elements.EA (Index);
2057 Container.Elements.EA (Index) := new Element_Type'(New_Item);
2060 end Replace_Element;
2062 procedure Replace_Element
2063 (Container : in out Vector;
2065 New_Item : Element_Type)
2068 if Position.Container = null then
2069 raise Constraint_Error with "Position cursor has no element";
2072 if Position.Container /= Container'Unrestricted_Access then
2073 raise Program_Error with "Position cursor denotes wrong container";
2076 if Position.Index > Container.Last then
2077 raise Constraint_Error with "Position cursor is out of range";
2080 if Container.Lock > 0 then
2081 raise Program_Error with
2082 "attempt to tamper with cursors (vector is locked)";
2086 X : Element_Access := Container.Elements.EA (Position.Index);
2088 Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
2091 end Replace_Element;
2093 ----------------------
2094 -- Reserve_Capacity --
2095 ----------------------
2097 procedure Reserve_Capacity
2098 (Container : in out Vector;
2099 Capacity : Count_Type)
2101 N : constant Count_Type := Length (Container);
2104 if Capacity = 0 then
2107 X : Elements_Access := Container.Elements;
2109 Container.Elements := null;
2113 elsif N < Container.Elements.EA'Length then
2114 if Container.Busy > 0 then
2115 raise Program_Error with
2116 "attempt to tamper with elements (vector is busy)";
2120 subtype Array_Index_Subtype is Index_Type'Base range
2121 Index_Type'First .. Container.Last;
2123 Src : Elements_Array renames
2124 Container.Elements.EA (Array_Index_Subtype);
2126 X : Elements_Access := Container.Elements;
2129 Container.Elements := new Elements_Type'(Container.Last, Src);
2137 if Container.Elements = null then
2139 Last_As_Int : constant Int'Base :=
2140 Int (Index_Type'First) + Int (Capacity) - 1;
2143 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2144 raise Constraint_Error with "new length is out of range";
2148 Last : constant Index_Type := Index_Type (Last_As_Int);
2151 Container.Elements := new Elements_Type (Last);
2158 if Capacity <= N then
2159 if N < Container.Elements.EA'Length then
2160 if Container.Busy > 0 then
2161 raise Program_Error with
2162 "attempt to tamper with elements (vector is busy)";
2166 subtype Array_Index_Subtype is Index_Type'Base range
2167 Index_Type'First .. Container.Last;
2169 Src : Elements_Array renames
2170 Container.Elements.EA (Array_Index_Subtype);
2172 X : Elements_Access := Container.Elements;
2175 Container.Elements := new Elements_Type'(Container.Last, Src);
2183 if Capacity = Container.Elements.EA'Length then
2187 if Container.Busy > 0 then
2188 raise Program_Error with
2189 "attempt to tamper with elements (vector is busy)";
2193 Last_As_Int : constant Int'Base :=
2194 Int (Index_Type'First) + Int (Capacity) - 1;
2197 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2198 raise Constraint_Error with "new length is out of range";
2202 Last : constant Index_Type := Index_Type (Last_As_Int);
2203 X : Elements_Access := Container.Elements;
2205 subtype Index_Subtype is Index_Type'Base range
2206 Index_Type'First .. Container.Last;
2209 Container.Elements := new Elements_Type (Last);
2212 Src : Elements_Array renames
2213 X.EA (Index_Subtype);
2215 Tgt : Elements_Array renames
2216 Container.Elements.EA (Index_Subtype);
2225 end Reserve_Capacity;
2227 ----------------------
2228 -- Reverse_Elements --
2229 ----------------------
2231 procedure Reverse_Elements (Container : in out Vector) is
2233 if Container.Length <= 1 then
2237 if Container.Lock > 0 then
2238 raise Program_Error with
2239 "attempt to tamper with cursors (vector is locked)";
2245 E : Elements_Array renames Container.Elements.EA;
2248 I := Index_Type'First;
2249 J := Container.Last;
2252 EI : constant Element_Access := E (I);
2263 end Reverse_Elements;
2269 function Reverse_Find
2270 (Container : Vector;
2271 Item : Element_Type;
2272 Position : Cursor := No_Element) return Cursor
2274 Last : Index_Type'Base;
2277 if Position.Container /= null
2278 and then Position.Container /= Container'Unchecked_Access
2280 raise Program_Error with "Position cursor denotes wrong container";
2283 if Position.Container = null
2284 or else Position.Index > Container.Last
2286 Last := Container.Last;
2288 Last := Position.Index;
2291 for Indx in reverse Index_Type'First .. Last loop
2292 if Container.Elements.EA (Indx) /= null
2293 and then Container.Elements.EA (Indx).all = Item
2295 return (Container'Unchecked_Access, Indx);
2302 ------------------------
2303 -- Reverse_Find_Index --
2304 ------------------------
2306 function Reverse_Find_Index
2307 (Container : Vector;
2308 Item : Element_Type;
2309 Index : Index_Type := Index_Type'Last) return Extended_Index
2311 Last : constant Index_Type'Base :=
2312 (if Index > Container.Last then Container.Last else Index);
2314 for Indx in reverse Index_Type'First .. Last loop
2315 if Container.Elements.EA (Indx) /= null
2316 and then Container.Elements.EA (Indx).all = Item
2323 end Reverse_Find_Index;
2325 ---------------------
2326 -- Reverse_Iterate --
2327 ---------------------
2329 procedure Reverse_Iterate
2330 (Container : Vector;
2331 Process : not null access procedure (Position : Cursor))
2333 V : Vector renames Container'Unrestricted_Access.all;
2334 B : Natural renames V.Busy;
2340 for Indx in reverse Index_Type'First .. Container.Last loop
2341 Process (Cursor'(Container'Unchecked_Access, Indx));
2350 end Reverse_Iterate;
2356 procedure Set_Length
2357 (Container : in out Vector;
2358 Length : Count_Type)
2360 N : constant Count_Type := Indefinite_Vectors.Length (Container);
2367 if Container.Busy > 0 then
2368 raise Program_Error with
2369 "attempt to tamper with elements (vector is busy)";
2373 for Index in 1 .. N - Length loop
2375 J : constant Index_Type := Container.Last;
2376 X : Element_Access := Container.Elements.EA (J);
2379 Container.Elements.EA (J) := null;
2380 Container.Last := J - 1;
2388 if Length > Capacity (Container) then
2389 Reserve_Capacity (Container, Capacity => Length);
2393 Last_As_Int : constant Int'Base :=
2394 Int (Index_Type'First) + Int (Length) - 1;
2397 Container.Last := Index_Type (Last_As_Int);
2406 (Container : in out Vector;
2410 if I > Container.Last then
2411 raise Constraint_Error with "I index is out of range";
2414 if J > Container.Last then
2415 raise Constraint_Error with "J index is out of range";
2422 if Container.Lock > 0 then
2423 raise Program_Error with
2424 "attempt to tamper with cursors (vector is locked)";
2428 EI : Element_Access renames Container.Elements.EA (I);
2429 EJ : Element_Access renames Container.Elements.EA (J);
2431 EI_Copy : constant Element_Access := EI;
2440 (Container : in out Vector;
2444 if I.Container = null then
2445 raise Constraint_Error with "I cursor has no element";
2448 if J.Container = null then
2449 raise Constraint_Error with "J cursor has no element";
2452 if I.Container /= Container'Unrestricted_Access then
2453 raise Program_Error with "I cursor denotes wrong container";
2456 if J.Container /= Container'Unrestricted_Access then
2457 raise Program_Error with "J cursor denotes wrong container";
2460 Swap (Container, I.Index, J.Index);
2468 (Container : Vector;
2469 Index : Extended_Index) return Cursor
2472 if Index not in Index_Type'First .. Container.Last then
2476 return Cursor'(Container'Unchecked_Access, Index);
2483 function To_Index (Position : Cursor) return Extended_Index is
2485 if Position.Container = null then
2489 if Position.Index <= Position.Container.Last then
2490 return Position.Index;
2500 function To_Vector (Length : Count_Type) return Vector is
2503 return Empty_Vector;
2507 First : constant Int := Int (Index_Type'First);
2508 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2510 Elements : Elements_Access;
2513 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2514 raise Constraint_Error with "Length is out of range";
2517 Last := Index_Type (Last_As_Int);
2518 Elements := new Elements_Type (Last);
2520 return (Controlled with Elements, Last, 0, 0);
2525 (New_Item : Element_Type;
2526 Length : Count_Type) return Vector
2530 return Empty_Vector;
2534 First : constant Int := Int (Index_Type'First);
2535 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2536 Last : Index_Type'Base;
2537 Elements : Elements_Access;
2540 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2541 raise Constraint_Error with "Length is out of range";
2544 Last := Index_Type (Last_As_Int);
2545 Elements := new Elements_Type (Last);
2547 Last := Index_Type'First;
2551 Elements.EA (Last) := new Element_Type'(New_Item);
2552 exit when Last = Elements.Last;
2558 for J in Index_Type'First .. Last - 1 loop
2559 Free (Elements.EA (J));
2566 return (Controlled with Elements, Last, 0, 0);
2570 --------------------
2571 -- Update_Element --
2572 --------------------
2574 procedure Update_Element
2575 (Container : in out Vector;
2577 Process : not null access procedure (Element : in out Element_Type))
2579 B : Natural renames Container.Busy;
2580 L : Natural renames Container.Lock;
2583 if Index > Container.Last then
2584 raise Constraint_Error with "Index is out of range";
2587 if Container.Elements.EA (Index) = null then
2588 raise Constraint_Error with "element is null";
2595 Process (Container.Elements.EA (Index).all);
2607 procedure Update_Element
2608 (Container : in out Vector;
2610 Process : not null access procedure (Element : in out Element_Type))
2613 if Position.Container = null then
2614 raise Constraint_Error with "Position cursor has no element";
2617 if Position.Container /= Container'Unrestricted_Access then
2618 raise Program_Error with "Position cursor denotes wrong container";
2621 Update_Element (Container, Position.Index, Process);
2629 (Stream : not null access Root_Stream_Type'Class;
2632 N : constant Count_Type := Length (Container);
2635 Count_Type'Base'Write (Stream, N);
2642 E : Elements_Array renames Container.Elements.EA;
2645 for Indx in Index_Type'First .. Container.Last loop
2646 if E (Indx) = null then
2647 Boolean'Write (Stream, False);
2649 Boolean'Write (Stream, True);
2650 Element_Type'Output (Stream, E (Indx).all);
2657 (Stream : not null access Root_Stream_Type'Class;
2661 raise Program_Error with "attempt to stream vector cursor";
2664 end Ada.Containers.Indefinite_Vectors;