1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . V E C T O R S --
9 -- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- This unit was originally developed by Matthew J Heaney. --
30 ------------------------------------------------------------------------------
32 with Ada
.Containers
.Generic_Array_Sort
;
33 with Ada
.Unchecked_Deallocation
;
35 with System
; use type System
.Address
;
37 package body Ada
.Containers
.Vectors
is
39 type Int
is range System
.Min_Int
.. System
.Max_Int
;
40 type UInt
is mod System
.Max_Binary_Modulus
;
43 new Ada
.Unchecked_Deallocation
(Elements_Type
, Elements_Access
);
49 function "&" (Left
, Right
: Vector
) return Vector
is
50 LN
: constant Count_Type
:= Length
(Left
);
51 RN
: constant Count_Type
:= Length
(Right
);
60 RE
: Elements_Array
renames
61 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
63 Elements
: constant Elements_Access
:=
64 new Elements_Type
'(Right.Last, RE);
67 return (Controlled with Elements, Right.Last, 0, 0);
73 LE : Elements_Array renames
74 Left.Elements.EA (Index_Type'First .. Left.Last);
76 Elements : constant Elements_Access :=
77 new Elements_Type'(Left
.Last
, LE
);
80 return (Controlled
with Elements
, Left
.Last
, 0, 0);
86 N
: constant Int
'Base := Int
(LN
) + Int
(RN
);
87 Last_As_Int
: Int
'Base;
90 if Int
(No_Index
) > Int
'Last - N
then
91 raise Constraint_Error
with "new length is out of range";
94 Last_As_Int
:= Int
(No_Index
) + N
;
96 if Last_As_Int
> Int
(Index_Type
'Last) then
97 raise Constraint_Error
with "new length is out of range";
101 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
103 LE
: Elements_Array
renames
104 Left
.Elements
.EA
(Index_Type
'First .. Left
.Last
);
106 RE
: Elements_Array
renames
107 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
109 Elements
: constant Elements_Access
:=
110 new Elements_Type
'(Last, LE & RE);
113 return (Controlled with Elements, Last, 0, 0);
118 function "&" (Left : Vector; Right : Element_Type) return Vector is
119 LN : constant Count_Type := Length (Left);
124 Elements : constant Elements_Access :=
126 (Last
=> Index_Type
'First,
127 EA
=> (others => Right
));
130 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
135 Last_As_Int
: Int
'Base;
138 if Int
(Index_Type
'First) > Int
'Last - Int
(LN
) then
139 raise Constraint_Error
with "new length is out of range";
142 Last_As_Int
:= Int
(Index_Type
'First) + Int
(LN
);
144 if Last_As_Int
> Int
(Index_Type
'Last) then
145 raise Constraint_Error
with "new length is out of range";
149 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
151 LE
: Elements_Array
renames
152 Left
.Elements
.EA
(Index_Type
'First .. Left
.Last
);
154 Elements
: constant Elements_Access
:=
160 return (Controlled with Elements, Last, 0, 0);
165 function "&" (Left : Element_Type; Right : Vector) return Vector is
166 RN : constant Count_Type := Length (Right);
171 Elements : constant Elements_Access :=
173 (Last
=> Index_Type
'First,
174 EA
=> (others => Left
));
177 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
182 Last_As_Int
: Int
'Base;
185 if Int
(Index_Type
'First) > Int
'Last - Int
(RN
) then
186 raise Constraint_Error
with "new length is out of range";
189 Last_As_Int
:= Int
(Index_Type
'First) + Int
(RN
);
191 if Last_As_Int
> Int
(Index_Type
'Last) then
192 raise Constraint_Error
with "new length is out of range";
196 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
198 RE
: Elements_Array
renames
199 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
201 Elements
: constant Elements_Access
:=
207 return (Controlled with Elements, Last, 0, 0);
212 function "&" (Left, Right : Element_Type) return Vector is
214 if Index_Type'First >= Index_Type'Last then
215 raise Constraint_Error with "new length is out of range";
219 Last : constant Index_Type := Index_Type'First + 1;
221 Elements : constant Elements_Access :=
224 EA
=> (Left
, Right
));
227 return (Controlled
with Elements
, Last
, 0, 0);
235 function "=" (Left
, Right
: Vector
) return Boolean is
237 if Left
'Address = Right
'Address then
241 if Left
.Last
/= Right
.Last
then
245 for J
in Index_Type
range Index_Type
'First .. Left
.Last
loop
246 if Left
.Elements
.EA
(J
) /= Right
.Elements
.EA
(J
) then
258 procedure Adjust
(Container
: in out Vector
) is
260 if Container
.Last
= No_Index
then
261 Container
.Elements
:= null;
266 L
: constant Index_Type
:= Container
.Last
;
267 EA
: Elements_Array
renames
268 Container
.Elements
.EA
(Index_Type
'First .. L
);
271 Container
.Elements
:= null;
272 Container
.Last
:= No_Index
;
276 Container
.Elements
:= new Elements_Type
'(L, EA);
285 procedure Append (Container : in out Vector; New_Item : Vector) is
287 if Is_Empty (New_Item) then
291 if Container.Last = Index_Type'Last then
292 raise Constraint_Error with "vector is already at its maximum length";
302 (Container : in out Vector;
303 New_Item : Element_Type;
304 Count : Count_Type := 1)
311 if Container.Last = Index_Type'Last then
312 raise Constraint_Error with "vector is already at its maximum length";
326 function Capacity (Container : Vector) return Count_Type is
328 if Container.Elements = null then
332 return Container.Elements.EA'Length;
339 procedure Clear (Container : in out Vector) is
341 if Container.Busy > 0 then
342 raise Program_Error with
343 "attempt to tamper with elements (vector is busy)";
346 Container.Last := No_Index;
355 Item : Element_Type) return Boolean
358 return Find_Index (Container, Item) /= No_Index;
366 (Container : in out Vector;
367 Index : Extended_Index;
368 Count : Count_Type := 1)
371 if Index < Index_Type'First then
372 raise Constraint_Error with "Index is out of range (too small)";
375 if Index > Container.Last then
376 if Index > Container.Last + 1 then
377 raise Constraint_Error with "Index is out of range (too large)";
387 if Container.Busy > 0 then
388 raise Program_Error with
389 "attempt to tamper with elements (vector is busy)";
393 I_As_Int : constant Int := Int (Index);
394 Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
396 Count1 : constant Int'Base := Count_Type'Pos (Count);
397 Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
398 N : constant Int'Base := Int'Min (Count1, Count2);
400 J_As_Int : constant Int'Base := I_As_Int + N;
403 if J_As_Int > Old_Last_As_Int then
404 Container.Last := Index - 1;
408 J : constant Index_Type := Index_Type (J_As_Int);
409 EA : Elements_Array renames Container.Elements.EA;
411 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
412 New_Last : constant Index_Type :=
413 Index_Type (New_Last_As_Int);
416 EA (Index .. New_Last) := EA (J .. Container.Last);
417 Container.Last := New_Last;
424 (Container : in out Vector;
425 Position : in out Cursor;
426 Count : Count_Type := 1)
429 if Position.Container = null then
430 raise Constraint_Error with "Position cursor has no element";
433 if Position.Container /= Container'Unrestricted_Access then
434 raise Program_Error with "Position cursor denotes wrong container";
437 if Position.Index > Container.Last then
438 raise Program_Error with "Position index is out of range";
441 Delete (Container, Position.Index, Count);
442 Position := No_Element;
449 procedure Delete_First
450 (Container : in out Vector;
451 Count : Count_Type := 1)
458 if Count >= Length (Container) then
463 Delete (Container, Index_Type'First, Count);
470 procedure Delete_Last
471 (Container : in out Vector;
472 Count : Count_Type := 1)
481 if Container.Busy > 0 then
482 raise Program_Error with
483 "attempt to tamper with elements (vector is busy)";
486 Index := Int'Base (Container.Last) - Int'Base (Count);
488 if Index < Index_Type'Pos (Index_Type'First) then
489 Container.Last := No_Index;
491 Container.Last := Index_Type (Index);
501 Index : Index_Type) return Element_Type
504 if Index > Container.Last then
505 raise Constraint_Error with "Index is out of range";
508 return Container.Elements.EA (Index);
511 function Element (Position : Cursor) return Element_Type is
513 if Position.Container = null then
514 raise Constraint_Error with "Position cursor has no element";
517 if Position.Index > Position.Container.Last then
518 raise Constraint_Error with "Position cursor is out of range";
521 return Position.Container.Elements.EA (Position.Index);
528 procedure Finalize (Container : in out Vector) is
529 X : Elements_Access := Container.Elements;
532 if Container.Busy > 0 then
533 raise Program_Error with
534 "attempt to tamper with elements (vector is busy)";
537 Container.Elements := null;
538 Container.Last := No_Index;
549 Position : Cursor := No_Element) return Cursor
552 if Position.Container /= null then
553 if Position.Container /= Container'Unrestricted_Access then
554 raise Program_Error with "Position cursor denotes wrong container";
557 if Position.Index > Container.Last then
558 raise Program_Error with "Position index is out of range";
562 for J in Position.Index .. Container.Last loop
563 if Container.Elements.EA (J) = Item then
564 return (Container'Unchecked_Access, J);
578 Index : Index_Type := Index_Type'First) return Extended_Index
581 for Indx in Index .. Container.Last loop
582 if Container.Elements.EA (Indx) = Item then
594 function First (Container : Vector) return Cursor is
596 if Is_Empty (Container) then
600 return (Container'Unchecked_Access, Index_Type'First);
607 function First_Element (Container : Vector) return Element_Type is
609 if Container.Last = No_Index then
610 raise Constraint_Error with "Container is empty";
613 return Container.Elements.EA (Index_Type'First);
620 function First_Index (Container : Vector) return Index_Type is
621 pragma Unreferenced (Container);
623 return Index_Type'First;
626 ---------------------
627 -- Generic_Sorting --
628 ---------------------
630 package body Generic_Sorting is
636 function Is_Sorted (Container : Vector) return Boolean is
638 if Container.Last <= Index_Type'First then
643 EA : Elements_Array renames Container.Elements.EA;
645 for I in Index_Type'First .. Container.Last - 1 loop
646 if EA (I + 1) < EA (I) then
659 procedure Merge (Target, Source : in out Vector) is
660 I : Index_Type'Base := Target.Last;
664 if Target.Last < Index_Type'First then
665 Move (Target => Target, Source => Source);
669 if Target'Address = Source'Address then
673 if Source.Last < Index_Type'First then
677 if Source.Busy > 0 then
678 raise Program_Error with
679 "attempt to tamper with elements (vector is busy)";
682 Target.Set_Length (Length (Target) + Length (Source));
685 TA : Elements_Array renames Target.Elements.EA;
686 SA : Elements_Array renames Source.Elements.EA;
690 while Source.Last >= Index_Type'First loop
691 pragma Assert (Source.Last <= Index_Type'First
692 or else not (SA (Source.Last) <
693 SA (Source.Last - 1)));
695 if I < Index_Type'First then
696 TA (Index_Type'First .. J) :=
697 SA (Index_Type'First .. Source.Last);
699 Source.Last := No_Index;
703 pragma Assert (I <= Index_Type'First
704 or else not (TA (I) < TA (I - 1)));
706 if SA (Source.Last) < TA (I) then
711 TA (J) := SA (Source.Last);
712 Source.Last := Source.Last - 1;
724 procedure Sort (Container : in out Vector)
727 new Generic_Array_Sort
728 (Index_Type => Index_Type,
729 Element_Type => Element_Type,
730 Array_Type => Elements_Array,
734 if Container.Last <= Index_Type'First then
738 if Container.Lock > 0 then
739 raise Program_Error with
740 "attempt to tamper with cursors (vector is locked)";
743 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
752 function Has_Element (Position : Cursor) return Boolean is
754 if Position.Container = null then
758 return Position.Index <= Position.Container.Last;
766 (Container : in out Vector;
767 Before : Extended_Index;
768 New_Item : Element_Type;
769 Count : Count_Type := 1)
771 N : constant Int := Count_Type'Pos (Count);
773 First : constant Int := Int (Index_Type'First);
774 New_Last_As_Int : Int'Base;
775 New_Last : Index_Type;
777 Max_Length : constant UInt := UInt (Count_Type'Last);
779 Dst : Elements_Access;
782 if Before < Index_Type'First then
783 raise Constraint_Error with
784 "Before index is out of range (too small)";
787 if Before > Container.Last
788 and then Before > Container.Last + 1
790 raise Constraint_Error with
791 "Before index is out of range (too large)";
799 Old_Last_As_Int : constant Int := Int (Container.Last);
802 if Old_Last_As_Int > Int'Last - N then
803 raise Constraint_Error with "new length is out of range";
806 New_Last_As_Int := Old_Last_As_Int + N;
808 if New_Last_As_Int > Int (Index_Type'Last) then
809 raise Constraint_Error with "new length is out of range";
812 New_Length := UInt (New_Last_As_Int - First + Int'(1));
814 if New_Length
> Max_Length
then
815 raise Constraint_Error
with "new length is out of range";
818 New_Last
:= Index_Type
(New_Last_As_Int
);
821 if Container
.Busy
> 0 then
822 raise Program_Error
with
823 "attempt to tamper with elements (vector is busy)";
826 if Container
.Elements
= null then
827 Container
.Elements
:= new Elements_Type
'
829 EA => (others => New_Item));
830 Container.Last := New_Last;
834 if New_Last <= Container.Elements.Last then
836 EA : Elements_Array renames Container.Elements.EA;
839 if Before <= Container.Last then
841 Index_As_Int : constant Int'Base :=
842 Index_Type'Pos (Before) + N;
844 Index : constant Index_Type := Index_Type (Index_As_Int);
847 EA (Index .. New_Last) := EA (Before .. Container.Last);
849 EA (Before .. Index_Type'Pred (Index)) :=
850 (others => New_Item);
854 EA (Before .. New_Last) := (others => New_Item);
858 Container.Last := New_Last;
866 C := UInt'Max (1, Container.Elements.EA'Length); -- ???
867 while C < New_Length loop
868 if C > UInt'Last / 2 then
876 if C > Max_Length then
880 if Index_Type'First <= 0
881 and then Index_Type'Last >= 0
883 CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1;
886 CC := UInt (Int (Index_Type'Last) - First + 1);
894 Dst_Last : constant Index_Type :=
895 Index_Type (First + UInt'Pos (C) - 1);
898 Dst := new Elements_Type (Dst_Last);
903 SA : Elements_Array renames Container.Elements.EA;
904 DA : Elements_Array renames Dst.EA;
907 DA (Index_Type'First .. Index_Type'Pred (Before)) :=
908 SA (Index_Type'First .. Index_Type'Pred (Before));
910 if Before <= Container.Last then
912 Index_As_Int : constant Int'Base :=
913 Index_Type'Pos (Before) + N;
915 Index : constant Index_Type := Index_Type (Index_As_Int);
918 DA (Before .. Index_Type'Pred (Index)) := (others => New_Item);
919 DA (Index .. New_Last) := SA (Before .. Container.Last);
923 DA (Before .. New_Last) := (others => New_Item);
932 X : Elements_Access := Container.Elements;
934 Container.Elements := Dst;
935 Container.Last := New_Last;
941 (Container : in out Vector;
942 Before : Extended_Index;
945 N : constant Count_Type := Length (New_Item);
948 if Before < Index_Type'First then
949 raise Constraint_Error with
950 "Before index is out of range (too small)";
953 if Before > Container.Last
954 and then Before > Container.Last + 1
956 raise Constraint_Error with
957 "Before index is out of range (too large)";
964 Insert_Space (Container, Before, Count => N);
967 Dst_Last_As_Int : constant Int'Base :=
968 Int'Base (Before) + Int'Base (N) - 1;
970 Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int);
973 if Container'Address /= New_Item'Address then
974 Container.Elements.EA (Before .. Dst_Last) :=
975 New_Item.Elements.EA (Index_Type'First .. New_Item.Last);
981 subtype Src_Index_Subtype is Index_Type'Base range
982 Index_Type'First .. Before - 1;
984 Src : Elements_Array renames
985 Container.Elements.EA (Src_Index_Subtype);
987 Index_As_Int : constant Int'Base :=
988 Int (Before) + Src'Length - 1;
990 Index : constant Index_Type'Base :=
991 Index_Type'Base (Index_As_Int);
993 Dst : Elements_Array renames
994 Container.Elements.EA (Before .. Index);
1000 if Dst_Last = Container.Last then
1005 subtype Src_Index_Subtype is Index_Type'Base range
1006 Dst_Last + 1 .. Container.Last;
1008 Src : Elements_Array renames
1009 Container.Elements.EA (Src_Index_Subtype);
1011 Index_As_Int : constant Int'Base :=
1012 Dst_Last_As_Int - Src'Length + 1;
1014 Index : constant Index_Type :=
1015 Index_Type (Index_As_Int);
1017 Dst : Elements_Array renames
1018 Container.Elements.EA (Index .. Dst_Last);
1027 (Container : in out Vector;
1031 Index : Index_Type'Base;
1034 if Before.Container /= null
1035 and then Before.Container /= Container'Unchecked_Access
1037 raise Program_Error with "Before cursor denotes wrong container";
1040 if Is_Empty (New_Item) then
1044 if Before.Container = null
1045 or else Before.Index > Container.Last
1047 if Container.Last = Index_Type'Last then
1048 raise Constraint_Error with
1049 "vector is already at its maximum length";
1052 Index := Container.Last + 1;
1055 Index := Before.Index;
1058 Insert (Container, Index, New_Item);
1062 (Container : in out Vector;
1065 Position : out Cursor)
1067 Index : Index_Type'Base;
1070 if Before.Container /= null
1071 and then Before.Container /= Container'Unchecked_Access
1073 raise Program_Error with "Before cursor denotes wrong container";
1076 if Is_Empty (New_Item) then
1077 if Before.Container = null
1078 or else Before.Index > Container.Last
1080 Position := No_Element;
1082 Position := (Container'Unchecked_Access, Before.Index);
1088 if Before.Container = null
1089 or else Before.Index > Container.Last
1091 if Container.Last = Index_Type'Last then
1092 raise Constraint_Error with
1093 "vector is already at its maximum length";
1096 Index := Container.Last + 1;
1099 Index := Before.Index;
1102 Insert (Container, Index, New_Item);
1104 Position := Cursor'(Container
'Unchecked_Access, Index
);
1108 (Container
: in out Vector
;
1110 New_Item
: Element_Type
;
1111 Count
: Count_Type
:= 1)
1113 Index
: Index_Type
'Base;
1116 if Before
.Container
/= null
1117 and then Before
.Container
/= Container
'Unchecked_Access
1119 raise Program_Error
with "Before cursor denotes wrong container";
1126 if Before
.Container
= null
1127 or else Before
.Index
> Container
.Last
1129 if Container
.Last
= Index_Type
'Last then
1130 raise Constraint_Error
with
1131 "vector is already at its maximum length";
1134 Index
:= Container
.Last
+ 1;
1137 Index
:= Before
.Index
;
1140 Insert
(Container
, Index
, New_Item
, Count
);
1144 (Container
: in out Vector
;
1146 New_Item
: Element_Type
;
1147 Position
: out Cursor
;
1148 Count
: Count_Type
:= 1)
1150 Index
: Index_Type
'Base;
1153 if Before
.Container
/= null
1154 and then Before
.Container
/= Container
'Unchecked_Access
1156 raise Program_Error
with "Before cursor denotes wrong container";
1160 if Before
.Container
= null
1161 or else Before
.Index
> Container
.Last
1163 Position
:= No_Element
;
1165 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1171 if Before
.Container
= null
1172 or else Before
.Index
> Container
.Last
1174 if Container
.Last
= Index_Type
'Last then
1175 raise Constraint_Error
with
1176 "vector is already at its maximum length";
1179 Index
:= Container
.Last
+ 1;
1182 Index
:= Before
.Index
;
1185 Insert
(Container
, Index
, New_Item
, Count
);
1187 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1191 (Container : in out Vector;
1192 Before : Extended_Index;
1193 Count : Count_Type := 1)
1195 New_Item : Element_Type; -- Default-initialized value
1196 pragma Warnings (Off, New_Item);
1199 Insert (Container, Before, New_Item, Count);
1203 (Container : in out Vector;
1205 Position : out Cursor;
1206 Count : Count_Type := 1)
1208 New_Item : Element_Type; -- Default-initialized value
1209 pragma Warnings (Off, New_Item);
1212 Insert (Container, Before, New_Item, Position, Count);
1219 procedure Insert_Space
1220 (Container : in out Vector;
1221 Before : Extended_Index;
1222 Count : Count_Type := 1)
1224 N : constant Int := Count_Type'Pos (Count);
1226 First : constant Int := Int (Index_Type'First);
1227 New_Last_As_Int : Int'Base;
1228 New_Last : Index_Type;
1230 Max_Length : constant UInt := UInt (Count_Type'Last);
1232 Dst : Elements_Access;
1235 if Before < Index_Type'First then
1236 raise Constraint_Error with
1237 "Before index is out of range (too small)";
1240 if Before > Container.Last
1241 and then Before > Container.Last + 1
1243 raise Constraint_Error with
1244 "Before index is out of range (too large)";
1252 Old_Last_As_Int : constant Int := Int (Container.Last);
1255 if Old_Last_As_Int > Int'Last - N then
1256 raise Constraint_Error with "new length is out of range";
1259 New_Last_As_Int := Old_Last_As_Int + N;
1261 if New_Last_As_Int > Int (Index_Type'Last) then
1262 raise Constraint_Error with "new length is out of range";
1265 New_Length := UInt (New_Last_As_Int - First + Int'(1));
1267 if New_Length
> Max_Length
then
1268 raise Constraint_Error
with "new length is out of range";
1271 New_Last
:= Index_Type
(New_Last_As_Int
);
1274 if Container
.Busy
> 0 then
1275 raise Program_Error
with
1276 "attempt to tamper with elements (vector is busy)";
1279 if Container
.Elements
= null then
1280 Container
.Elements
:= new Elements_Type
(New_Last
);
1281 Container
.Last
:= New_Last
;
1285 if New_Last
<= Container
.Elements
.Last
then
1287 EA
: Elements_Array
renames Container
.Elements
.EA
;
1289 if Before
<= Container
.Last
then
1291 Index_As_Int
: constant Int
'Base :=
1292 Index_Type
'Pos (Before
) + N
;
1294 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1297 EA
(Index
.. New_Last
) := EA
(Before
.. Container
.Last
);
1302 Container
.Last
:= New_Last
;
1310 C
:= UInt
'Max (1, Container
.Elements
.EA
'Length); -- ???
1311 while C
< New_Length
loop
1312 if C
> UInt
'Last / 2 then
1320 if C
> Max_Length
then
1324 if Index_Type
'First <= 0
1325 and then Index_Type
'Last >= 0
1327 CC
:= UInt
(Index_Type
'Last) + UInt
(-Index_Type
'First) + 1;
1330 CC
:= UInt
(Int
(Index_Type
'Last) - First
+ 1);
1338 Dst_Last
: constant Index_Type
:=
1339 Index_Type
(First
+ UInt
'Pos (C
) - 1);
1342 Dst
:= new Elements_Type
(Dst_Last
);
1347 SA
: Elements_Array
renames Container
.Elements
.EA
;
1348 DA
: Elements_Array
renames Dst
.EA
;
1351 DA
(Index_Type
'First .. Index_Type
'Pred (Before
)) :=
1352 SA
(Index_Type
'First .. Index_Type
'Pred (Before
));
1354 if Before
<= Container
.Last
then
1356 Index_As_Int
: constant Int
'Base :=
1357 Index_Type
'Pos (Before
) + N
;
1359 Index
: constant Index_Type
:= Index_Type
(Index_As_Int
);
1362 DA
(Index
.. New_Last
) := SA
(Before
.. Container
.Last
);
1372 X
: Elements_Access
:= Container
.Elements
;
1374 Container
.Elements
:= Dst
;
1375 Container
.Last
:= New_Last
;
1380 procedure Insert_Space
1381 (Container
: in out Vector
;
1383 Position
: out Cursor
;
1384 Count
: Count_Type
:= 1)
1386 Index
: Index_Type
'Base;
1389 if Before
.Container
/= null
1390 and then Before
.Container
/= Container
'Unchecked_Access
1392 raise Program_Error
with "Before cursor denotes wrong container";
1396 if Before
.Container
= null
1397 or else Before
.Index
> Container
.Last
1399 Position
:= No_Element
;
1401 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1407 if Before
.Container
= null
1408 or else Before
.Index
> Container
.Last
1410 if Container
.Last
= Index_Type
'Last then
1411 raise Constraint_Error
with
1412 "vector is already at its maximum length";
1415 Index
:= Container
.Last
+ 1;
1418 Index
:= Before
.Index
;
1421 Insert_Space
(Container
, Index
, Count
=> Count
);
1423 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1430 function Is_Empty (Container : Vector) return Boolean is
1432 return Container.Last < Index_Type'First;
1440 (Container : Vector;
1441 Process : not null access procedure (Position : Cursor))
1443 V : Vector renames Container'Unrestricted_Access.all;
1444 B : Natural renames V.Busy;
1450 for Indx in Index_Type'First .. Container.Last loop
1451 Process (Cursor'(Container
'Unchecked_Access, Indx
));
1466 function Last
(Container
: Vector
) return Cursor
is
1468 if Is_Empty
(Container
) then
1472 return (Container
'Unchecked_Access, Container
.Last
);
1479 function Last_Element
(Container
: Vector
) return Element_Type
is
1481 if Container
.Last
= No_Index
then
1482 raise Constraint_Error
with "Container is empty";
1485 return Container
.Elements
.EA
(Container
.Last
);
1492 function Last_Index
(Container
: Vector
) return Extended_Index
is
1494 return Container
.Last
;
1501 function Length
(Container
: Vector
) return Count_Type
is
1502 L
: constant Int
:= Int
(Container
.Last
);
1503 F
: constant Int
:= Int
(Index_Type
'First);
1504 N
: constant Int
'Base := L
- F
+ 1;
1507 return Count_Type
(N
);
1515 (Target
: in out Vector
;
1516 Source
: in out Vector
)
1519 if Target
'Address = Source
'Address then
1523 if Target
.Busy
> 0 then
1524 raise Program_Error
with
1525 "attempt to tamper with elements (Target is busy)";
1528 if Source
.Busy
> 0 then
1529 raise Program_Error
with
1530 "attempt to tamper with elements (Source is busy)";
1534 Target_Elements
: constant Elements_Access
:= Target
.Elements
;
1536 Target
.Elements
:= Source
.Elements
;
1537 Source
.Elements
:= Target_Elements
;
1540 Target
.Last
:= Source
.Last
;
1541 Source
.Last
:= No_Index
;
1548 function Next
(Position
: Cursor
) return Cursor
is
1550 if Position
.Container
= null then
1554 if Position
.Index
< Position
.Container
.Last
then
1555 return (Position
.Container
, Position
.Index
+ 1);
1565 procedure Next
(Position
: in out Cursor
) is
1567 if Position
.Container
= null then
1571 if Position
.Index
< Position
.Container
.Last
then
1572 Position
.Index
:= Position
.Index
+ 1;
1574 Position
:= No_Element
;
1582 procedure Prepend
(Container
: in out Vector
; New_Item
: Vector
) is
1584 Insert
(Container
, Index_Type
'First, New_Item
);
1588 (Container
: in out Vector
;
1589 New_Item
: Element_Type
;
1590 Count
: Count_Type
:= 1)
1603 procedure Previous
(Position
: in out Cursor
) is
1605 if Position
.Container
= null then
1609 if Position
.Index
> Index_Type
'First then
1610 Position
.Index
:= Position
.Index
- 1;
1612 Position
:= No_Element
;
1616 function Previous
(Position
: Cursor
) return Cursor
is
1618 if Position
.Container
= null then
1622 if Position
.Index
> Index_Type
'First then
1623 return (Position
.Container
, Position
.Index
- 1);
1633 procedure Query_Element
1634 (Container
: Vector
;
1636 Process
: not null access procedure (Element
: Element_Type
))
1638 V
: Vector
renames Container
'Unrestricted_Access.all;
1639 B
: Natural renames V
.Busy
;
1640 L
: Natural renames V
.Lock
;
1643 if Index
> Container
.Last
then
1644 raise Constraint_Error
with "Index is out of range";
1651 Process
(V
.Elements
.EA
(Index
));
1663 procedure Query_Element
1665 Process
: not null access procedure (Element
: Element_Type
))
1668 if Position
.Container
= null then
1669 raise Constraint_Error
with "Position cursor has no element";
1672 Query_Element
(Position
.Container
.all, Position
.Index
, Process
);
1680 (Stream
: not null access Root_Stream_Type
'Class;
1681 Container
: out Vector
)
1683 Length
: Count_Type
'Base;
1684 Last
: Index_Type
'Base := No_Index
;
1689 Count_Type
'Base'Read (Stream, Length);
1691 if Length > Capacity (Container) then
1692 Reserve_Capacity (Container, Capacity => Length);
1695 for J in Count_Type range 1 .. Length loop
1697 Element_Type'Read (Stream, Container.Elements.EA (Last));
1698 Container.Last := Last;
1703 (Stream : not null access Root_Stream_Type'Class;
1704 Position : out Cursor)
1707 raise Program_Error with "attempt to stream vector cursor";
1710 ---------------------
1711 -- Replace_Element --
1712 ---------------------
1714 procedure Replace_Element
1715 (Container : in out Vector;
1717 New_Item : Element_Type)
1720 if Index > Container.Last then
1721 raise Constraint_Error with "Index is out of range";
1724 if Container.Lock > 0 then
1725 raise Program_Error with
1726 "attempt to tamper with cursors (vector is locked)";
1729 Container.Elements.EA (Index) := New_Item;
1730 end Replace_Element;
1732 procedure Replace_Element
1733 (Container : in out Vector;
1735 New_Item : Element_Type)
1738 if Position.Container = null then
1739 raise Constraint_Error with "Position cursor has no element";
1742 if Position.Container /= Container'Unrestricted_Access then
1743 raise Program_Error with "Position cursor denotes wrong container";
1746 if Position.Index > Container.Last then
1747 raise Constraint_Error with "Position cursor is out of range";
1750 if Container.Lock > 0 then
1751 raise Program_Error with
1752 "attempt to tamper with cursors (vector is locked)";
1755 Container.Elements.EA (Position.Index) := New_Item;
1756 end Replace_Element;
1758 ----------------------
1759 -- Reserve_Capacity --
1760 ----------------------
1762 procedure Reserve_Capacity
1763 (Container : in out Vector;
1764 Capacity : Count_Type)
1766 N : constant Count_Type := Length (Container);
1769 if Capacity = 0 then
1772 X : Elements_Access := Container.Elements;
1774 Container.Elements := null;
1778 elsif N < Container.Elements.EA'Length then
1779 if Container.Busy > 0 then
1780 raise Program_Error with
1781 "attempt to tamper with elements (vector is busy)";
1785 subtype Src_Index_Subtype is Index_Type'Base range
1786 Index_Type'First .. Container.Last;
1788 Src : Elements_Array renames
1789 Container.Elements.EA (Src_Index_Subtype);
1791 X : Elements_Access := Container.Elements;
1794 Container.Elements := new Elements_Type'(Container
.Last
, Src
);
1802 if Container
.Elements
= null then
1804 Last_As_Int
: constant Int
'Base :=
1805 Int
(Index_Type
'First) + Int
(Capacity
) - 1;
1808 if Last_As_Int
> Index_Type
'Pos (Index_Type
'Last) then
1809 raise Constraint_Error
with "new length is out of range";
1813 Last
: constant Index_Type
:= Index_Type
(Last_As_Int
);
1816 Container
.Elements
:= new Elements_Type
(Last
);
1823 if Capacity
<= N
then
1824 if N
< Container
.Elements
.EA
'Length then
1825 if Container
.Busy
> 0 then
1826 raise Program_Error
with
1827 "attempt to tamper with elements (vector is busy)";
1831 subtype Src_Index_Subtype
is Index_Type
'Base range
1832 Index_Type
'First .. Container
.Last
;
1834 Src
: Elements_Array
renames
1835 Container
.Elements
.EA
(Src_Index_Subtype
);
1837 X
: Elements_Access
:= Container
.Elements
;
1840 Container
.Elements
:= new Elements_Type
'(Container.Last, Src);
1849 if Capacity = Container.Elements.EA'Length then
1853 if Container.Busy > 0 then
1854 raise Program_Error with
1855 "attempt to tamper with elements (vector is busy)";
1859 Last_As_Int : constant Int'Base :=
1860 Int (Index_Type'First) + Int (Capacity) - 1;
1863 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1864 raise Constraint_Error with "new length is out of range";
1868 Last : constant Index_Type := Index_Type (Last_As_Int);
1870 E : Elements_Access := new Elements_Type (Last);
1874 subtype Index_Subtype is Index_Type'Base range
1875 Index_Type'First .. Container.Last;
1877 Src : Elements_Array renames
1878 Container.Elements.EA (Index_Subtype);
1880 Tgt : Elements_Array renames E.EA (Index_Subtype);
1892 X : Elements_Access := Container.Elements;
1894 Container.Elements := E;
1899 end Reserve_Capacity;
1901 ----------------------
1902 -- Reverse_Elements --
1903 ----------------------
1905 procedure Reverse_Elements (Container : in out Vector) is
1907 if Container.Length <= 1 then
1911 if Container.Lock > 0 then
1912 raise Program_Error with
1913 "attempt to tamper with cursors (vector is locked)";
1918 E : Elements_Type renames Container.Elements.all;
1921 I := Index_Type'First;
1922 J := Container.Last;
1925 EI : constant Element_Type := E.EA (I);
1928 E.EA (I) := E.EA (J);
1936 end Reverse_Elements;
1942 function Reverse_Find
1943 (Container : Vector;
1944 Item : Element_Type;
1945 Position : Cursor := No_Element) return Cursor
1947 Last : Index_Type'Base;
1950 if Position.Container /= null
1951 and then Position.Container /= Container'Unchecked_Access
1953 raise Program_Error with "Position cursor denotes wrong container";
1956 if Position.Container = null
1957 or else Position.Index > Container.Last
1959 Last := Container.Last;
1961 Last := Position.Index;
1964 for Indx in reverse Index_Type'First .. Last loop
1965 if Container.Elements.EA (Indx) = Item then
1966 return (Container'Unchecked_Access, Indx);
1973 ------------------------
1974 -- Reverse_Find_Index --
1975 ------------------------
1977 function Reverse_Find_Index
1978 (Container : Vector;
1979 Item : Element_Type;
1980 Index : Index_Type := Index_Type'Last) return Extended_Index
1982 Last : Index_Type'Base;
1985 if Index > Container.Last then
1986 Last := Container.Last;
1991 for Indx in reverse Index_Type'First .. Last loop
1992 if Container.Elements.EA (Indx) = Item then
1998 end Reverse_Find_Index;
2000 ---------------------
2001 -- Reverse_Iterate --
2002 ---------------------
2004 procedure Reverse_Iterate
2005 (Container : Vector;
2006 Process : not null access procedure (Position : Cursor))
2008 V : Vector renames Container'Unrestricted_Access.all;
2009 B : Natural renames V.Busy;
2015 for Indx in reverse Index_Type'First .. Container.Last loop
2016 Process (Cursor'(Container
'Unchecked_Access, Indx
));
2025 end Reverse_Iterate
;
2031 procedure Set_Length
(Container
: in out Vector
; Length
: Count_Type
) is
2033 if Length
= Vectors
.Length
(Container
) then
2037 if Container
.Busy
> 0 then
2038 raise Program_Error
with
2039 "attempt to tamper with elements (vector is busy)";
2042 if Length
> Capacity
(Container
) then
2043 Reserve_Capacity
(Container
, Capacity
=> Length
);
2047 Last_As_Int
: constant Int
'Base :=
2048 Int
(Index_Type
'First) + Int
(Length
) - 1;
2050 Container
.Last
:= Index_Type
'Base (Last_As_Int
);
2058 procedure Swap
(Container
: in out Vector
; I
, J
: Index_Type
) is
2060 if I
> Container
.Last
then
2061 raise Constraint_Error
with "I index is out of range";
2064 if J
> Container
.Last
then
2065 raise Constraint_Error
with "J index is out of range";
2072 if Container
.Lock
> 0 then
2073 raise Program_Error
with
2074 "attempt to tamper with cursors (vector is locked)";
2078 EI
: Element_Type
renames Container
.Elements
.EA
(I
);
2079 EJ
: Element_Type
renames Container
.Elements
.EA
(J
);
2081 EI_Copy
: constant Element_Type
:= EI
;
2089 procedure Swap
(Container
: in out Vector
; I
, J
: Cursor
) is
2091 if I
.Container
= null then
2092 raise Constraint_Error
with "I cursor has no element";
2095 if J
.Container
= null then
2096 raise Constraint_Error
with "J cursor has no element";
2099 if I
.Container
/= Container
'Unrestricted_Access then
2100 raise Program_Error
with "I cursor denotes wrong container";
2103 if J
.Container
/= Container
'Unrestricted_Access then
2104 raise Program_Error
with "J cursor denotes wrong container";
2107 Swap
(Container
, I
.Index
, J
.Index
);
2115 (Container
: Vector
;
2116 Index
: Extended_Index
) return Cursor
2119 if Index
not in Index_Type
'First .. Container
.Last
then
2123 return Cursor
'(Container'Unchecked_Access, Index);
2130 function To_Index (Position : Cursor) return Extended_Index is
2132 if Position.Container = null then
2136 if Position.Index <= Position.Container.Last then
2137 return Position.Index;
2147 function To_Vector (Length : Count_Type) return Vector is
2150 return Empty_Vector;
2154 First : constant Int := Int (Index_Type'First);
2155 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
2157 Elements : Elements_Access;
2160 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
2161 raise Constraint_Error with "Length is out of range";
2164 Last := Index_Type (Last_As_Int);
2165 Elements := new Elements_Type (Last);
2167 return Vector'(Controlled
with Elements
, Last
, 0, 0);
2172 (New_Item
: Element_Type
;
2173 Length
: Count_Type
) return Vector
2177 return Empty_Vector
;
2181 First
: constant Int
:= Int
(Index_Type
'First);
2182 Last_As_Int
: constant Int
'Base := First
+ Int
(Length
) - 1;
2184 Elements
: Elements_Access
;
2187 if Last_As_Int
> Index_Type
'Pos (Index_Type
'Last) then
2188 raise Constraint_Error
with "Length is out of range";
2191 Last
:= Index_Type
(Last_As_Int
);
2192 Elements
:= new Elements_Type
'(Last, EA => (others => New_Item));
2194 return Vector'(Controlled
with Elements
, Last
, 0, 0);
2198 --------------------
2199 -- Update_Element --
2200 --------------------
2202 procedure Update_Element
2203 (Container
: in out Vector
;
2205 Process
: not null access procedure (Element
: in out Element_Type
))
2207 B
: Natural renames Container
.Busy
;
2208 L
: Natural renames Container
.Lock
;
2211 if Index
> Container
.Last
then
2212 raise Constraint_Error
with "Index is out of range";
2219 Process
(Container
.Elements
.EA
(Index
));
2231 procedure Update_Element
2232 (Container
: in out Vector
;
2234 Process
: not null access procedure (Element
: in out Element_Type
))
2237 if Position
.Container
= null then
2238 raise Constraint_Error
with "Position cursor has no element";
2241 if Position
.Container
/= Container
'Unrestricted_Access then
2242 raise Program_Error
with "Position cursor denotes wrong container";
2245 Update_Element
(Container
, Position
.Index
, Process
);
2253 (Stream
: not null access Root_Stream_Type
'Class;
2257 Count_Type
'Base'Write (Stream, Length (Container));
2259 for J in Index_Type'First .. Container.Last loop
2260 Element_Type'Write (Stream, Container.Elements.EA (J));
2265 (Stream : not null access Root_Stream_Type'Class;
2269 raise Program_Error with "attempt to stream vector cursor";
2272 end Ada.Containers.Vectors;