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 := Before;
1127 E (Index .. New_Last) := E (Before .. Container.Last);
1128 Container.Last := New_Last;
1130 while J < Index loop
1131 E (J) := new Element_Type'(New_Item);
1137 E (J .. Index - 1) := (others => null);
1142 for J in Before .. New_Last loop
1143 E (J) := new Element_Type'(New_Item);
1144 Container.Last := J;
1156 C := UInt'Max (1, Container.Elements.EA'Length); -- ???
1157 while C < New_Length loop
1158 if C > UInt'Last / 2 then
1166 if C > Max_Length then
1170 if Index_Type'First <= 0
1171 and then Index_Type'Last >= 0
1173 CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
1176 CC := UInt (Int (Index_Type'Last) - First + 1);
1184 Dst_Last : constant Index_Type :=
1185 Index_Type (First + UInt'Pos (C) - Int'(1));
1188 Dst := new Elements_Type (Dst_Last);
1192 if Before <= Container.Last then
1194 Index_As_Int : constant Int'Base :=
1195 Index_Type'Pos (Before) + N;
1197 Index : constant Index_Type := Index_Type (Index_As_Int);
1199 Src : Elements_Access := Container.Elements;
1202 Dst.EA (Index_Type'First .. Before - 1) :=
1203 Src.EA (Index_Type'First .. Before - 1);
1205 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1207 Container.Elements := Dst;
1208 Container.Last := New_Last;
1211 for J in Before .. Index - 1 loop
1212 Dst.EA (J) := new Element_Type'(New_Item);
1218 Src : Elements_Access := Container.Elements;
1221 Dst.EA (Index_Type'First .. Container.Last) :=
1222 Src.EA (Index_Type'First .. Container.Last);
1224 Container.Elements := Dst;
1227 for J in Before .. New_Last loop
1228 Dst.EA (J) := new Element_Type'(New_Item);
1229 Container.Last := J;
1236 (Container : in out Vector;
1237 Before : Extended_Index;
1240 N : constant Count_Type := Length (New_Item);
1243 if Before < Index_Type'First then
1244 raise Constraint_Error with
1245 "Before index is out of range (too small)";
1248 if Before > Container.Last
1249 and then Before > Container.Last + 1
1251 raise Constraint_Error with
1252 "Before index is out of range (too large)";
1259 Insert_Space (Container, Before, Count => N);
1262 Dst_Last_As_Int : constant Int'Base :=
1263 Int'Base (Before) + Int'Base (N) - 1;
1265 Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
1267 Dst : Elements_Array renames
1268 Container.Elements.EA (Before .. Dst_Last);
1270 Dst_Index : Index_Type'Base := Before - 1;
1273 if Container'Address /= New_Item'Address then
1275 subtype Src_Index_Subtype is Index_Type'Base range
1276 Index_Type'First .. New_Item.Last;
1278 Src : Elements_Array renames
1279 New_Item.Elements.EA (Src_Index_Subtype);
1282 for Src_Index in Src'Range loop
1283 Dst_Index := Dst_Index + 1;
1285 if Src (Src_Index) /= null then
1286 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1295 subtype Src_Index_Subtype is Index_Type'Base range
1296 Index_Type'First .. Before - 1;
1298 Src : Elements_Array renames
1299 Container.Elements.EA (Src_Index_Subtype);
1302 for Src_Index in Src'Range loop
1303 Dst_Index := Dst_Index + 1;
1305 if Src (Src_Index) /= null then
1306 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1311 if Dst_Last = Container.Last then
1316 subtype Src_Index_Subtype is Index_Type'Base range
1317 Dst_Last + 1 .. Container.Last;
1319 Src : Elements_Array renames
1320 Container.Elements.EA (Src_Index_Subtype);
1323 for Src_Index in Src'Range loop
1324 Dst_Index := Dst_Index + 1;
1326 if Src (Src_Index) /= null then
1327 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1335 (Container : in out Vector;
1339 Index : Index_Type'Base;
1342 if Before.Container /= null
1343 and then Before.Container /= Container'Unchecked_Access
1345 raise Program_Error with "Before cursor denotes wrong container";
1348 if Is_Empty (New_Item) then
1352 if Before.Container = null
1353 or else Before.Index > Container.Last
1355 if Container.Last = Index_Type'Last then
1356 raise Constraint_Error with
1357 "vector is already at its maximum length";
1360 Index := Container.Last + 1;
1363 Index := Before.Index;
1366 Insert (Container, Index, New_Item);
1370 (Container : in out Vector;
1373 Position : out Cursor)
1375 Index : Index_Type'Base;
1378 if Before.Container /= null
1379 and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1381 raise Program_Error with "Before cursor denotes wrong container";
1384 if Is_Empty (New_Item) then
1385 if Before.Container = null
1386 or else Before.Index > Container.Last
1388 Position := No_Element;
1390 Position := (Container'Unchecked_Access, Before.Index);
1396 if Before.Container = null
1397 or else Before.Index > Container.Last
1399 if Container.Last = Index_Type'Last then
1400 raise Constraint_Error with
1401 "vector is already at its maximum length";
1404 Index := Container.Last + 1;
1407 Index := Before.Index;
1410 Insert (Container, Index, New_Item);
1412 Position := Cursor'(Container'Unchecked_Access, Index);
1416 (Container : in out Vector;
1418 New_Item : Element_Type;
1419 Count : Count_Type := 1)
1421 Index : Index_Type'Base;
1424 if Before.Container /= null
1425 and then Before.Container /= Container'Unchecked_Access
1427 raise Program_Error with "Before cursor denotes wrong container";
1434 if Before.Container = null
1435 or else Before.Index > Container.Last
1437 if Container.Last = Index_Type'Last then
1438 raise Constraint_Error with
1439 "vector is already at its maximum length";
1442 Index := Container.Last + 1;
1445 Index := Before.Index;
1448 Insert (Container, Index, New_Item, Count);
1452 (Container : in out Vector;
1454 New_Item : Element_Type;
1455 Position : out Cursor;
1456 Count : Count_Type := 1)
1458 Index : Index_Type'Base;
1461 if Before.Container /= null
1462 and then Before.Container /= Container'Unchecked_Access
1464 raise Program_Error with "Before cursor denotes wrong container";
1468 if Before.Container = null
1469 or else Before.Index > Container.Last
1471 Position := No_Element;
1473 Position := (Container'Unchecked_Access, Before.Index);
1479 if Before.Container = null
1480 or else Before.Index > Container.Last
1482 if Container.Last = Index_Type'Last then
1483 raise Constraint_Error with
1484 "vector is already at its maximum length";
1487 Index := Container.Last + 1;
1490 Index := Before.Index;
1493 Insert (Container, Index, New_Item, Count);
1495 Position := (Container'Unchecked_Access, Index);
1502 procedure Insert_Space
1503 (Container : in out Vector;
1504 Before : Extended_Index;
1505 Count : Count_Type := 1)
1507 N : constant Int := Int (Count);
1509 First : constant Int := Int (Index_Type'First);
1510 New_Last_As_Int : Int'Base;
1511 New_Last : Index_Type;
1513 Max_Length : constant UInt := UInt (Count_Type'Last);
1515 Dst : Elements_Access;
1518 if Before < Index_Type'First then
1519 raise Constraint_Error with
1520 "Before index is out of range (too small)";
1523 if Before > Container.Last
1524 and then Before > Container.Last + 1
1526 raise Constraint_Error with
1527 "Before index is out of range (too large)";
1535 Old_Last_As_Int : constant Int := Int (Container.Last);
1538 if Old_Last_As_Int > Int'Last - N then
1539 raise Constraint_Error with "new length is out of range";
1542 New_Last_As_Int := Old_Last_As_Int + N;
1544 if New_Last_As_Int > Int (Index_Type'Last) then
1545 raise Constraint_Error with "new length is out of range";
1548 New_Length := UInt (New_Last_As_Int - First + 1);
1550 if New_Length > Max_Length then
1551 raise Constraint_Error with "new length is out of range";
1554 New_Last := Index_Type (New_Last_As_Int);
1557 if Container.Busy > 0 then
1558 raise Program_Error with
1559 "attempt to tamper with elements (vector is busy)";
1562 if Container.Elements = null then
1563 Container.Elements := new Elements_Type (New_Last);
1564 Container.Last := New_Last;
1568 if New_Last <= Container.Elements.Last then
1570 E : Elements_Array renames Container.Elements.EA;
1573 if Before <= Container.Last then
1575 Index_As_Int : constant Int'Base :=
1576 Index_Type'Pos (Before) + N;
1578 Index : constant Index_Type := Index_Type (Index_As_Int);
1581 E (Index .. New_Last) := E (Before .. Container.Last);
1582 E (Before .. Index - 1) := (others => null);
1587 Container.Last := New_Last;
1595 C := UInt'Max (1, Container.Elements.EA'Length); -- ???
1596 while C < New_Length loop
1597 if C > UInt'Last / 2 then
1605 if C > Max_Length then
1609 if Index_Type'First <= 0
1610 and then Index_Type'Last >= 0
1612 CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
1615 CC := UInt (Int (Index_Type'Last) - First + 1);
1623 Dst_Last : constant Index_Type :=
1624 Index_Type (First + UInt'Pos (C) - 1);
1627 Dst := new Elements_Type (Dst_Last);
1632 Src : Elements_Access := Container.Elements;
1635 if Before <= Container.Last then
1637 Index_As_Int : constant Int'Base :=
1638 Index_Type'Pos (Before) + N;
1640 Index : constant Index_Type := Index_Type (Index_As_Int);
1643 Dst.EA (Index_Type'First .. Before - 1) :=
1644 Src.EA (Index_Type'First .. Before - 1);
1646 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1650 Dst.EA (Index_Type'First .. Container.Last) :=
1651 Src.EA (Index_Type'First .. Container.Last);
1654 Container.Elements := Dst;
1655 Container.Last := New_Last;
1660 procedure Insert_Space
1661 (Container : in out Vector;
1663 Position : out Cursor;
1664 Count : Count_Type := 1)
1666 Index : Index_Type'Base;
1669 if Before.Container /= null
1670 and then Before.Container /= Container'Unchecked_Access
1672 raise Program_Error with "Before cursor denotes wrong container";
1676 if Before.Container = null
1677 or else Before.Index > Container.Last
1679 Position := No_Element;
1681 Position := (Container'Unchecked_Access, Before.Index);
1687 if Before.Container = null
1688 or else Before.Index > Container.Last
1690 if Container.Last = Index_Type'Last then
1691 raise Constraint_Error with
1692 "vector is already at its maximum length";
1695 Index := Container.Last + 1;
1698 Index := Before.Index;
1701 Insert_Space (Container, Index, Count);
1703 Position := Cursor'(Container'Unchecked_Access, Index);
1710 function Is_Empty (Container : Vector) return Boolean is
1712 return Container.Last < Index_Type'First;
1720 (Container : Vector;
1721 Process : not null access procedure (Position : Cursor))
1723 V : Vector renames Container'Unrestricted_Access.all;
1724 B : Natural renames V.Busy;
1730 for Indx in Index_Type'First .. Container.Last loop
1731 Process (Cursor'(Container'Unchecked_Access, Indx));
1746 function Last (Container : Vector) return Cursor is
1748 if Is_Empty (Container) then
1752 return (Container'Unchecked_Access, Container.Last);
1759 function Last_Element (Container : Vector) return Element_Type is
1761 if Container.Last = No_Index then
1762 raise Constraint_Error with "Container is empty";
1766 EA : constant Element_Access :=
1767 Container.Elements.EA (Container.Last);
1771 raise Constraint_Error with "last element is empty";
1782 function Last_Index (Container : Vector) return Extended_Index is
1784 return Container.Last;
1791 function Length (Container : Vector) return Count_Type is
1792 L : constant Int := Int (Container.Last);
1793 F : constant Int := Int (Index_Type'First);
1794 N : constant Int'Base := L - F + 1;
1797 return Count_Type (N);
1805 (Target : in out Vector;
1806 Source : in out Vector)
1809 if Target'Address = Source'Address then
1813 if Source.Busy > 0 then
1814 raise Program_Error with
1815 "attempt to tamper with elements (Source is busy)";
1818 Clear (Target); -- Checks busy-bit
1821 Target_Elements : constant Elements_Access := Target.Elements;
1823 Target.Elements := Source.Elements;
1824 Source.Elements := Target_Elements;
1827 Target.Last := Source.Last;
1828 Source.Last := No_Index;
1835 function Next (Position : Cursor) return Cursor is
1837 if Position.Container = null then
1841 if Position.Index < Position.Container.Last then
1842 return (Position.Container, Position.Index + 1);
1852 procedure Next (Position : in out Cursor) is
1854 if Position.Container = null then
1858 if Position.Index < Position.Container.Last then
1859 Position.Index := Position.Index + 1;
1861 Position := No_Element;
1869 procedure Prepend (Container : in out Vector; New_Item : Vector) is
1871 Insert (Container, Index_Type'First, New_Item);
1875 (Container : in out Vector;
1876 New_Item : Element_Type;
1877 Count : Count_Type := 1)
1890 procedure Previous (Position : in out Cursor) is
1892 if Position.Container = null then
1896 if Position.Index > Index_Type'First then
1897 Position.Index := Position.Index - 1;
1899 Position := No_Element;
1903 function Previous (Position : Cursor) return Cursor is
1905 if Position.Container = null then
1909 if Position.Index > Index_Type'First then
1910 return (Position.Container, Position.Index - 1);
1920 procedure Query_Element
1921 (Container : Vector;
1923 Process : not null access procedure (Element : Element_Type))
1925 V : Vector renames Container'Unrestricted_Access.all;
1926 B : Natural renames V.Busy;
1927 L : Natural renames V.Lock;
1930 if Index > Container.Last then
1931 raise Constraint_Error with "Index is out of range";
1934 if V.Elements.EA (Index) = null then
1935 raise Constraint_Error with "element is null";
1942 Process (V.Elements.EA (Index).all);
1954 procedure Query_Element
1956 Process : not null access procedure (Element : Element_Type))
1959 if Position.Container = null then
1960 raise Constraint_Error with "Position cursor has no element";
1963 Query_Element (Position.Container.all, Position.Index, Process);
1971 (Stream : not null access Root_Stream_Type'Class;
1972 Container : out Vector)
1974 Length : Count_Type'Base;
1975 Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
1982 Count_Type'Base'Read (Stream, Length);
1984 if Length > Capacity (Container) then
1985 Reserve_Capacity (Container, Capacity => Length);
1988 for J in Count_Type range 1 .. Length loop
1991 Boolean'Read (Stream, B);
1994 Container.Elements.EA (Last) :=
1995 new Element_Type'(Element_Type'Input (Stream));
1998 Container.Last := Last;
2003 (Stream : not null access Root_Stream_Type'Class;
2004 Position : out Cursor)
2007 raise Program_Error with "attempt to stream vector cursor";
2010 ---------------------
2011 -- Replace_Element --
2012 ---------------------
2014 procedure Replace_Element
2015 (Container : in out Vector;
2017 New_Item : Element_Type)
2020 if Index > Container.Last then
2021 raise Constraint_Error with "Index is out of range";
2024 if Container.Lock > 0 then
2025 raise Program_Error with
2026 "attempt to tamper with cursors (vector is locked)";
2030 X : Element_Access := Container.Elements.EA (Index);
2032 Container.Elements.EA (Index) := new Element_Type'(New_Item);
2035 end Replace_Element;
2037 procedure Replace_Element
2038 (Container : in out Vector;
2040 New_Item : Element_Type)
2043 if Position.Container = null then
2044 raise Constraint_Error with "Position cursor has no element";
2047 if Position.Container /= Container'Unrestricted_Access then
2048 raise Program_Error with "Position cursor denotes wrong container";
2051 if Position.Index > Container.Last then
2052 raise Constraint_Error with "Position cursor is out of range";
2055 if Container.Lock > 0 then
2056 raise Program_Error with
2057 "attempt to tamper with cursors (vector is locked)";
2061 X : Element_Access := Container.Elements.EA (Position.Index);
2063 Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
2066 end Replace_Element;
2068 ----------------------
2069 -- Reserve_Capacity --
2070 ----------------------
2072 procedure Reserve_Capacity
2073 (Container : in out Vector;
2074 Capacity : Count_Type)
2076 N : constant Count_Type := Length (Container);
2079 if Capacity = 0 then
2082 X : Elements_Access := Container.Elements;
2084 Container.Elements := null;
2088 elsif N < Container.Elements.EA'Length then
2089 if Container.Busy > 0 then
2090 raise Program_Error with
2091 "attempt to tamper with elements (vector is busy)";
2095 subtype Array_Index_Subtype is Index_Type'Base range
2096 Index_Type'First .. Container.Last;
2098 Src : Elements_Array renames
2099 Container.Elements.EA (Array_Index_Subtype);
2101 X : Elements_Access := Container.Elements;
2104 Container.Elements := new Elements_Type'(Container.Last, Src);
2112 if Container.Elements = null then
2114 Last_As_Int : constant Int'Base :=
2115 Int (Index_Type'First) + Int (Capacity) - 1;
2118 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2119 raise Constraint_Error with "new length is out of range";
2123 Last : constant Index_Type := Index_Type (Last_As_Int);
2126 Container.Elements := new Elements_Type (Last);
2133 if Capacity <= N then
2134 if N < Container.Elements.EA'Length then
2135 if Container.Busy > 0 then
2136 raise Program_Error with
2137 "attempt to tamper with elements (vector is busy)";
2141 subtype Array_Index_Subtype is Index_Type'Base range
2142 Index_Type'First .. Container.Last;
2144 Src : Elements_Array renames
2145 Container.Elements.EA (Array_Index_Subtype);
2147 X : Elements_Access := Container.Elements;
2150 Container.Elements := new Elements_Type'(Container.Last, Src);
2158 if Capacity = Container.Elements.EA'Length then
2162 if Container.Busy > 0 then
2163 raise Program_Error with
2164 "attempt to tamper with elements (vector is busy)";
2168 Last_As_Int : constant Int'Base :=
2169 Int (Index_Type'First) + Int (Capacity) - 1;
2172 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2173 raise Constraint_Error with "new length is out of range";
2177 Last : constant Index_Type := Index_Type (Last_As_Int);
2178 X : Elements_Access := Container.Elements;
2180 subtype Index_Subtype is Index_Type'Base range
2181 Index_Type'First .. Container.Last;
2184 Container.Elements := new Elements_Type (Last);
2187 Src : Elements_Array renames
2188 X.EA (Index_Subtype);
2190 Tgt : Elements_Array renames
2191 Container.Elements.EA (Index_Subtype);
2200 end Reserve_Capacity;
2202 ----------------------
2203 -- Reverse_Elements --
2204 ----------------------
2206 procedure Reverse_Elements (Container : in out Vector) is
2208 if Container.Length <= 1 then
2212 if Container.Lock > 0 then
2213 raise Program_Error with
2214 "attempt to tamper with cursors (vector is locked)";
2220 E : Elements_Array renames Container.Elements.EA;
2223 I := Index_Type'First;
2224 J := Container.Last;
2227 EI : constant Element_Access := E (I);
2238 end Reverse_Elements;
2244 function Reverse_Find
2245 (Container : Vector;
2246 Item : Element_Type;
2247 Position : Cursor := No_Element) return Cursor
2249 Last : Index_Type'Base;
2252 if Position.Container /= null
2253 and then Position.Container /= Container'Unchecked_Access
2255 raise Program_Error with "Position cursor denotes wrong container";
2258 if Position.Container = null
2259 or else Position.Index > Container.Last
2261 Last := Container.Last;
2263 Last := Position.Index;
2266 for Indx in reverse Index_Type'First .. Last loop
2267 if Container.Elements.EA (Indx) /= null
2268 and then Container.Elements.EA (Indx).all = Item
2270 return (Container'Unchecked_Access, Indx);
2277 ------------------------
2278 -- Reverse_Find_Index --
2279 ------------------------
2281 function Reverse_Find_Index
2282 (Container : Vector;
2283 Item : Element_Type;
2284 Index : Index_Type := Index_Type'Last) return Extended_Index
2286 Last : Index_Type'Base;
2289 if Index > Container.Last then
2290 Last := Container.Last;
2295 for Indx in reverse Index_Type'First .. Last loop
2296 if Container.Elements.EA (Indx) /= null
2297 and then Container.Elements.EA (Indx).all = Item
2304 end Reverse_Find_Index;
2306 ---------------------
2307 -- Reverse_Iterate --
2308 ---------------------
2310 procedure Reverse_Iterate
2311 (Container : Vector;
2312 Process : not null access procedure (Position : Cursor))
2314 V : Vector renames Container'Unrestricted_Access.all;
2315 B : Natural renames V.Busy;
2321 for Indx in reverse Index_Type'First .. Container.Last loop
2322 Process (Cursor'(Container'Unchecked_Access, Indx));
2331 end Reverse_Iterate;
2337 procedure Set_Length
2338 (Container : in out Vector;
2339 Length : Count_Type)
2341 N : constant Count_Type := Indefinite_Vectors.Length (Container);
2348 if Container.Busy > 0 then
2349 raise Program_Error with
2350 "attempt to tamper with elements (vector is busy)";
2354 for Index in 1 .. N - Length loop
2356 J : constant Index_Type := Container.Last;
2357 X : Element_Access := Container.Elements.EA (J);
2360 Container.Elements.EA (J) := null;
2361 Container.Last := J - 1;
2369 if Length > Capacity (Container) then
2370 Reserve_Capacity (Container, Capacity => Length);
2374 Last_As_Int : constant Int'Base :=
2375 Int (Index_Type'First) + Int (Length) - 1;
2378 Container.Last := Index_Type (Last_As_Int);
2387 (Container : in out Vector;
2391 if I > Container.Last then
2392 raise Constraint_Error with "I index is out of range";
2395 if J > Container.Last then
2396 raise Constraint_Error with "J index is out of range";
2403 if Container.Lock > 0 then
2404 raise Program_Error with
2405 "attempt to tamper with cursors (vector is locked)";
2409 EI : Element_Access renames Container.Elements.EA (I);
2410 EJ : Element_Access renames Container.Elements.EA (J);
2412 EI_Copy : constant Element_Access := EI;
2421 (Container : in out Vector;
2425 if I.Container = null then
2426 raise Constraint_Error with "I cursor has no element";
2429 if J.Container = null then
2430 raise Constraint_Error with "J cursor has no element";
2433 if I.Container /= Container'Unrestricted_Access then
2434 raise Program_Error with "I cursor denotes wrong container";
2437 if J.Container /= Container'Unrestricted_Access then
2438 raise Program_Error with "J cursor denotes wrong container";
2441 Swap (Container, I.Index, J.Index);
2449 (Container : Vector;
2450 Index : Extended_Index) return Cursor
2453 if Index not in Index_Type'First .. Container.Last then
2457 return Cursor'(Container'Unchecked_Access, Index);
2464 function To_Index (Position : Cursor) return Extended_Index is
2466 if Position.Container = null then
2470 if Position.Index <= Position.Container.Last then
2471 return Position.Index;
2481 function To_Vector (Length : Count_Type) return Vector is
2484 return Empty_Vector;
2488 First : constant Int := Int (Index_Type'First);
2489 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2491 Elements : Elements_Access;
2494 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2495 raise Constraint_Error with "Length is out of range";
2498 Last := Index_Type (Last_As_Int);
2499 Elements := new Elements_Type (Last);
2501 return (Controlled with Elements, Last, 0, 0);
2506 (New_Item : Element_Type;
2507 Length : Count_Type) return Vector
2511 return Empty_Vector;
2515 First : constant Int := Int (Index_Type'First);
2516 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2517 Last : Index_Type'Base;
2518 Elements : Elements_Access;
2521 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2522 raise Constraint_Error with "Length is out of range";
2525 Last := Index_Type (Last_As_Int);
2526 Elements := new Elements_Type (Last);
2528 Last := Index_Type'First;
2532 Elements.EA (Last) := new Element_Type'(New_Item);
2533 exit when Last = Elements.Last;
2539 for J in Index_Type'First .. Last - 1 loop
2540 Free (Elements.EA (J));
2547 return (Controlled with Elements, Last, 0, 0);
2551 --------------------
2552 -- Update_Element --
2553 --------------------
2555 procedure Update_Element
2556 (Container : in out Vector;
2558 Process : not null access procedure (Element : in out Element_Type))
2560 B : Natural renames Container.Busy;
2561 L : Natural renames Container.Lock;
2564 if Index > Container.Last then
2565 raise Constraint_Error with "Index is out of range";
2568 if Container.Elements.EA (Index) = null then
2569 raise Constraint_Error with "element is null";
2576 Process (Container.Elements.EA (Index).all);
2588 procedure Update_Element
2589 (Container : in out Vector;
2591 Process : not null access procedure (Element : in out Element_Type))
2594 if Position.Container = null then
2595 raise Constraint_Error with "Position cursor has no element";
2598 if Position.Container /= Container'Unrestricted_Access then
2599 raise Program_Error with "Position cursor denotes wrong container";
2602 Update_Element (Container, Position.Index, Process);
2610 (Stream : not null access Root_Stream_Type'Class;
2613 N : constant Count_Type := Length (Container);
2616 Count_Type'Base'Write (Stream, N);
2623 E : Elements_Array renames Container.Elements.EA;
2626 for Indx in Index_Type'First .. Container.Last loop
2627 if E (Indx) = null then
2628 Boolean'Write (Stream, False);
2630 Boolean'Write (Stream, True);
2631 Element_Type'Output (Stream, E (Indx).all);
2638 (Stream : not null access Root_Stream_Type'Class;
2642 raise Program_Error with "attempt to stream vector cursor";
2645 end Ada.Containers.Indefinite_Vectors;