1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S --
9 -- Copyright (C) 2010-2011, 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/>. --
26 ------------------------------------------------------------------------------
28 with Ada.Containers.Generic_Array_Sort;
29 with System; use type System.Address;
31 package body Ada.Containers.Formal_Vectors is
33 type Int is range System.Min_Int .. System.Max_Int;
34 type UInt is mod System.Max_Binary_Modulus;
38 Position : Count_Type) return Element_Type;
44 function "&" (Left, Right : Vector) return Vector is
45 LN : constant Count_Type := Length (Left);
46 RN : constant Count_Type := Length (Right);
55 E : constant Elements_Array (1 .. Length (Right)) :=
56 Right.Elements (1 .. RN);
58 return (Length (Right), E, Last => Right.Last, others => <>);
64 E : constant Elements_Array (1 .. Length (Left)) :=
65 Left.Elements (1 .. LN);
67 return (Length (Left), E, Last => Left.Last, others => <>);
72 N : constant Int'Base := Int (LN) + Int (RN);
73 Last_As_Int : Int'Base;
76 if Int (No_Index) > Int'Last - N then
77 raise Constraint_Error with "new length is out of range";
80 Last_As_Int := Int (No_Index) + N;
82 if Last_As_Int > Int (Index_Type'Last) then
83 raise Constraint_Error with "new length is out of range";
86 -- TODO: should check whether length > max capacity (cnt_t'last) ???
89 Last : constant Index_Type := Index_Type (Last_As_Int);
91 LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
92 RE : Elements_Array renames Right.Elements (1 .. RN);
94 Capacity : constant Count_Type := Length (Left) + Length (Right);
97 return (Capacity, LE & RE, Last => Last, others => <>);
102 function "&" (Left : Vector; Right : Element_Type) return Vector is
103 LN : constant Count_Type := Length (Left);
104 Last_As_Int : Int'Base;
108 return (1, (1 .. 1 => Right), Index_Type'First, others => <>);
111 if Int (Index_Type'First) > Int'Last - Int (LN) then
112 raise Constraint_Error with "new length is out of range";
115 Last_As_Int := Int (Index_Type'First) + Int (LN);
117 if Last_As_Int > Int (Index_Type'Last) then
118 raise Constraint_Error with "new length is out of range";
122 Last : constant Index_Type := Index_Type (Last_As_Int);
123 LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
125 Capacity : constant Count_Type := Length (Left) + 1;
128 return (Capacity, LE & Right, Last => Last, others => <>);
132 function "&" (Left : Element_Type; Right : Vector) return Vector is
133 RN : constant Count_Type := Length (Right);
134 Last_As_Int : Int'Base;
138 return (1, (1 .. 1 => Left),
139 Index_Type'First, others => <>);
142 if Int (Index_Type'First) > Int'Last - Int (RN) then
143 raise Constraint_Error with "new length is out of range";
146 Last_As_Int := Int (Index_Type'First) + Int (RN);
148 if Last_As_Int > Int (Index_Type'Last) then
149 raise Constraint_Error with "new length is out of range";
153 Last : constant Index_Type := Index_Type (Last_As_Int);
154 RE : Elements_Array renames Right.Elements (1 .. RN);
155 Capacity : constant Count_Type := 1 + Length (Right);
157 return (Capacity, Left & RE, Last => Last, others => <>);
161 function "&" (Left, Right : Element_Type) return Vector is
163 if Index_Type'First >= Index_Type'Last then
164 raise Constraint_Error with "new length is out of range";
168 Last : constant Index_Type := Index_Type'First + 1;
170 return (2, (Left, Right), Last => Last, others => <>);
178 function "=" (Left, Right : Vector) return Boolean is
180 if Left'Address = Right'Address then
184 if Length (Left) /= Length (Right) then
188 for J in Count_Type range 1 .. Length (Left) loop
189 if Get_Element (Left, J) /= Get_Element (Right, J) then
201 procedure Append (Container : in out Vector; New_Item : Vector) is
203 if Is_Empty (New_Item) then
207 if Container.Last = Index_Type'Last then
208 raise Constraint_Error with "vector is already at its maximum length";
211 Insert (Container, Container.Last + 1, New_Item);
215 (Container : in out Vector;
216 New_Item : Element_Type;
217 Count : Count_Type := 1)
224 if Container.Last = Index_Type'Last then
225 raise Constraint_Error with "vector is already at its maximum length";
228 -- TODO: should check whether length > max capacity (cnt_t'last) ???
230 Insert (Container, Container.Last + 1, New_Item, Count);
237 procedure Assign (Target : in out Vector; Source : Vector) is
238 LS : constant Count_Type := Length (Source);
241 if Target'Address = Source'Address then
245 if Target.Capacity < LS then
246 raise Constraint_Error;
251 Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
252 Target.Last := Source.Last;
259 function Capacity (Container : Vector) return Capacity_Subtype is
261 return Container.Elements'Length;
268 procedure Clear (Container : in out Vector) is
270 if Container.Busy > 0 then
271 raise Program_Error with
272 "attempt to tamper with elements (vector is busy)";
275 Container.Last := No_Index;
284 Item : Element_Type) return Boolean
287 return Find_Index (Container, Item) /= No_Index;
296 Capacity : Capacity_Subtype := 0) return Vector
298 LS : constant Count_Type := Length (Source);
299 C : Capacity_Subtype;
304 elsif Capacity >= LS then
307 raise Constraint_Error;
310 return Target : Vector (C) do
311 Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
312 Target.Last := Source.Last;
321 (Container : in out Vector;
322 Index : Extended_Index;
323 Count : Count_Type := 1)
326 if Index < Index_Type'First then
327 raise Constraint_Error with "Index is out of range (too small)";
330 if Index > Container.Last then
331 if Index > Container.Last + 1 then
332 raise Constraint_Error with "Index is out of range (too large)";
342 if Container.Busy > 0 then
343 raise Program_Error with
344 "attempt to tamper with elements (vector is busy)";
348 I_As_Int : constant Int := Int (Index);
349 Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
351 Count1 : constant Int'Base := Count_Type'Pos (Count);
352 Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
353 N : constant Int'Base := Int'Min (Count1, Count2);
355 J_As_Int : constant Int'Base := I_As_Int + N;
358 if J_As_Int > Old_Last_As_Int then
359 Container.Last := Index - 1;
363 EA : Elements_Array renames Container.Elements;
365 II : constant Int'Base := I_As_Int - Int (No_Index);
366 I : constant Count_Type := Count_Type (II);
368 JJ : constant Int'Base := J_As_Int - Int (No_Index);
369 J : constant Count_Type := Count_Type (JJ);
371 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N;
372 New_Last : constant Index_Type :=
373 Index_Type (New_Last_As_Int);
375 KK : constant Int := New_Last_As_Int - Int (No_Index);
376 K : constant Count_Type := Count_Type (KK);
379 EA (I .. K) := EA (J .. Length (Container));
380 Container.Last := New_Last;
387 (Container : in out Vector;
388 Position : in out Cursor;
389 Count : Count_Type := 1)
392 if not Position.Valid then
393 raise Constraint_Error with "Position cursor has no element";
396 if Position.Index > Container.Last then
397 raise Program_Error with "Position index is out of range";
400 Delete (Container, Position.Index, Count);
401 Position := No_Element;
408 procedure Delete_First
409 (Container : in out Vector;
410 Count : Count_Type := 1)
417 if Count >= Length (Container) then
422 Delete (Container, Index_Type'First, Count);
429 procedure Delete_Last
430 (Container : in out Vector;
431 Count : Count_Type := 1)
440 if Container.Busy > 0 then
441 raise Program_Error with
442 "attempt to tamper with elements (vector is busy)";
445 Index := Int'Base (Container.Last) - Int'Base (Count);
447 if Index < Index_Type'Pos (Index_Type'First) then
448 Container.Last := No_Index;
450 Container.Last := Index_Type (Index);
460 Index : Index_Type) return Element_Type
463 if Index > Container.Last then
464 raise Constraint_Error with "Index is out of range";
468 II : constant Int'Base := Int (Index) - Int (No_Index);
469 I : constant Count_Type := Count_Type (II);
471 return Get_Element (Container, I);
477 Position : Cursor) return Element_Type
479 Lst : constant Index_Type := Last_Index (Container);
482 if not Position.Valid then
483 raise Constraint_Error with "Position cursor has no element";
486 if Position.Index > Lst then
487 raise Constraint_Error with "Position cursor is out of range";
491 II : constant Int'Base := Int (Position.Index) - Int (No_Index);
492 I : constant Count_Type := Count_Type (II);
494 return Get_Element (Container, I);
505 Position : Cursor := No_Element) return Cursor
508 Last : constant Index_Type := Last_Index (Container);
511 if Position.Valid then
512 if Position.Index > Last_Index (Container) then
513 raise Program_Error with "Position index is out of range";
517 K := Count_Type (Int (Position.Index) - Int (No_Index));
519 for J in Position.Index .. Last loop
520 if Get_Element (Container, K) = Item then
521 return Cursor'(Index => J, others => <>);
537 Index : Index_Type := Index_Type'First) return Extended_Index
540 Last : constant Index_Type := Last_Index (Container);
543 K := Count_Type (Int (Index) - Int (No_Index));
544 for Indx in Index .. Last loop
545 if Get_Element (Container, K) = Item then
559 function First (Container : Vector) return Cursor is
561 if Is_Empty (Container) then
565 return (True, Index_Type'First);
572 function First_Element (Container : Vector) return Element_Type is
574 if Is_Empty (Container) then
575 raise Constraint_Error with "Container is empty";
578 return Get_Element (Container, 1);
585 function First_Index (Container : Vector) return Index_Type is
586 pragma Unreferenced (Container);
588 return Index_Type'First;
591 ---------------------
592 -- Generic_Sorting --
593 ---------------------
595 package body Generic_Sorting is
601 function Is_Sorted (Container : Vector) return Boolean is
602 Last : constant Index_Type := Last_Index (Container);
605 if Container.Last <= Last then
610 L : constant Capacity_Subtype := Length (Container);
612 for J in Count_Type range 1 .. L - 1 loop
613 if Get_Element (Container, J + 1) <
614 Get_Element (Container, J)
628 procedure Merge (Target, Source : in out Vector) is
631 TA : Elements_Array renames Target.Elements;
632 SA : Elements_Array renames Source.Elements;
638 -- if Target.Last < Index_Type'First then
639 -- Move (Target => Target, Source => Source);
643 if Target'Address = Source'Address then
647 if Source.Last < Index_Type'First then
651 -- I think we're missing this check in a-convec.adb... ???
653 if Target.Busy > 0 then
654 raise Program_Error with
655 "attempt to tamper with elements (vector is busy)";
658 if Source.Busy > 0 then
659 raise Program_Error with
660 "attempt to tamper with elements (vector is busy)";
663 I := Length (Target);
664 Target.Set_Length (I + Length (Source));
666 J := Length (Target);
667 while not Source.Is_Empty loop
668 pragma Assert (Length (Source) <= 1
669 or else not (SA (Length (Source)) <
670 SA (Length (Source) - 1)));
673 TA (1 .. J) := SA (1 .. Length (Source));
674 Source.Last := No_Index;
678 pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1)));
680 if SA (Length (Source)) < TA (I) then
685 TA (J) := SA (Length (Source));
686 Source.Last := Source.Last - 1;
698 procedure Sort (Container : in out Vector)
701 new Generic_Array_Sort
702 (Index_Type => Count_Type,
703 Element_Type => Element_Type,
704 Array_Type => Elements_Array,
708 if Container.Last <= Index_Type'First then
712 if Container.Lock > 0 then
713 raise Program_Error with
714 "attempt to tamper with cursors (vector is locked)";
717 Sort (Container.Elements (1 .. Length (Container)));
728 Position : Count_Type) return Element_Type
731 return Container.Elements (Position);
740 Position : Cursor) return Boolean
743 if not Position.Valid then
746 return Position.Index <= Last_Index (Container);
755 (Container : in out Vector;
756 Before : Extended_Index;
757 New_Item : Element_Type;
758 Count : Count_Type := 1)
760 N : constant Int := Count_Type'Pos (Count);
762 First : constant Int := Int (Index_Type'First);
763 New_Last_As_Int : Int'Base;
764 New_Last : Index_Type;
766 Max_Length : constant UInt := UInt (Container.Capacity);
769 if Before < Index_Type'First then
770 raise Constraint_Error with
771 "Before index is out of range (too small)";
774 if Before > Container.Last
775 and then Before > Container.Last + 1
777 raise Constraint_Error with
778 "Before index is out of range (too large)";
786 Old_Last_As_Int : constant Int := Int (Container.Last);
789 if Old_Last_As_Int > Int'Last - N then
790 raise Constraint_Error with "new length is out of range";
793 New_Last_As_Int := Old_Last_As_Int + N;
795 if New_Last_As_Int > Int (Index_Type'Last) then
796 raise Constraint_Error with "new length is out of range";
799 New_Length := UInt (New_Last_As_Int - First + Int'(1));
801 if New_Length > Max_Length then
802 raise Constraint_Error with "new length is out of range";
805 New_Last := Index_Type (New_Last_As_Int);
807 -- Resolve issue of capacity vs. max index ???
810 if Container.Busy > 0 then
811 raise Program_Error with
812 "attempt to tamper with elements (vector is busy)";
816 EA : Elements_Array renames Container.Elements;
818 BB : constant Int'Base := Int (Before) - Int (No_Index);
819 B : constant Count_Type := Count_Type (BB);
821 LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
822 L : constant Count_Type := Count_Type (LL);
825 if Before <= Container.Last then
827 II : constant Int'Base := BB + N;
828 I : constant Count_Type := Count_Type (II);
830 EA (I .. L) := EA (B .. Length (Container));
831 EA (B .. I - 1) := (others => New_Item);
835 EA (B .. L) := (others => New_Item);
839 Container.Last := New_Last;
843 (Container : in out Vector;
844 Before : Extended_Index;
847 N : constant Count_Type := Length (New_Item);
850 if Before < Index_Type'First then
851 raise Constraint_Error with
852 "Before index is out of range (too small)";
855 if Before > Container.Last
856 and then Before > Container.Last + 1
858 raise Constraint_Error with
859 "Before index is out of range (too large)";
866 Insert_Space (Container, Before, Count => N);
869 Dst_Last_As_Int : constant Int'Base :=
870 Int (Before) + Int (N) - 1 - Int (No_Index);
872 Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int);
874 BB : constant Int'Base := Int (Before) - Int (No_Index);
875 B : constant Count_Type := Count_Type (BB);
878 if Container'Address /= New_Item'Address then
879 Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N);
884 Src : Elements_Array renames Container.Elements (1 .. B - 1);
886 Index_As_Int : constant Int'Base := BB + Src'Length - 1;
888 Index : constant Count_Type := Count_Type (Index_As_Int);
890 Dst : Elements_Array renames Container.Elements (B .. Index);
896 if Dst_Last = Length (Container) then
901 Src : Elements_Array renames
902 Container.Elements (Dst_Last + 1 .. Length (Container));
904 Index_As_Int : constant Int'Base :=
905 Dst_Last_As_Int - Src'Length + 1;
907 Index : constant Count_Type := Count_Type (Index_As_Int);
909 Dst : Elements_Array renames
910 Container.Elements (Index .. Dst_Last);
919 (Container : in out Vector;
923 Index : Index_Type'Base;
926 if Is_Empty (New_Item) then
931 or else Before.Index > Container.Last
933 if Container.Last = Index_Type'Last then
934 raise Constraint_Error with
935 "vector is already at its maximum length";
938 Index := Container.Last + 1;
941 Index := Before.Index;
944 Insert (Container, Index, New_Item);
948 (Container : in out Vector;
951 Position : out Cursor)
953 Index : Index_Type'Base;
956 if Is_Empty (New_Item) then
958 or else Before.Index > Container.Last
960 Position := No_Element;
962 Position := (True, Before.Index);
969 or else Before.Index > Container.Last
971 if Container.Last = Index_Type'Last then
972 raise Constraint_Error with
973 "vector is already at its maximum length";
976 Index := Container.Last + 1;
979 Index := Before.Index;
982 Insert (Container, Index, New_Item);
984 Position := Cursor'(True, Index);
988 (Container : in out Vector;
990 New_Item : Element_Type;
991 Count : Count_Type := 1)
993 Index : Index_Type'Base;
1001 or else Before.Index > Container.Last
1003 if Container.Last = Index_Type'Last then
1004 raise Constraint_Error with
1005 "vector is already at its maximum length";
1008 Index := Container.Last + 1;
1011 Index := Before.Index;
1014 Insert (Container, Index, New_Item, Count);
1018 (Container : in out Vector;
1020 New_Item : Element_Type;
1021 Position : out Cursor;
1022 Count : Count_Type := 1)
1024 Index : Index_Type'Base;
1029 or else Before.Index > Container.Last
1031 Position := No_Element;
1033 Position := (True, Before.Index);
1040 or else Before.Index > Container.Last
1042 if Container.Last = Index_Type'Last then
1043 raise Constraint_Error with
1044 "vector is already at its maximum length";
1047 Index := Container.Last + 1;
1050 Index := Before.Index;
1053 Insert (Container, Index, New_Item, Count);
1055 Position := Cursor'(True, Index);
1059 (Container : in out Vector;
1060 Before : Extended_Index;
1061 Count : Count_Type := 1)
1063 New_Item : Element_Type; -- Default-initialized value
1064 pragma Warnings (Off, New_Item);
1067 Insert (Container, Before, New_Item, Count);
1071 (Container : in out Vector;
1073 Position : out Cursor;
1074 Count : Count_Type := 1)
1076 New_Item : Element_Type; -- Default-initialized value
1077 pragma Warnings (Off, New_Item);
1079 Insert (Container, Before, New_Item, Position, Count);
1086 procedure Insert_Space
1087 (Container : in out Vector;
1088 Before : Extended_Index;
1089 Count : Count_Type := 1)
1091 N : constant Int := Count_Type'Pos (Count);
1093 First : constant Int := Int (Index_Type'First);
1094 New_Last_As_Int : Int'Base;
1095 New_Last : Index_Type;
1097 Max_Length : constant UInt := UInt (Count_Type'Last);
1100 if Before < Index_Type'First then
1101 raise Constraint_Error with
1102 "Before index is out of range (too small)";
1105 if Before > Container.Last
1106 and then Before > Container.Last + 1
1108 raise Constraint_Error with
1109 "Before index is out of range (too large)";
1117 Old_Last_As_Int : constant Int := Int (Container.Last);
1120 if Old_Last_As_Int > Int'Last - N then
1121 raise Constraint_Error with "new length is out of range";
1124 New_Last_As_Int := Old_Last_As_Int + N;
1126 if New_Last_As_Int > Int (Index_Type'Last) then
1127 raise Constraint_Error with "new length is out of range";
1130 New_Length := UInt (New_Last_As_Int - First + Int'(1));
1132 if New_Length > Max_Length then
1133 raise Constraint_Error with "new length is out of range";
1136 New_Last := Index_Type (New_Last_As_Int);
1138 -- Resolve issue of capacity vs. max index ???
1141 if Container.Busy > 0 then
1142 raise Program_Error with
1143 "attempt to tamper with elements (vector is busy)";
1147 EA : Elements_Array renames Container.Elements;
1149 BB : constant Int'Base := Int (Before) - Int (No_Index);
1150 B : constant Count_Type := Count_Type (BB);
1152 LL : constant Int'Base := New_Last_As_Int - Int (No_Index);
1153 L : constant Count_Type := Count_Type (LL);
1156 if Before <= Container.Last then
1158 II : constant Int'Base := BB + N;
1159 I : constant Count_Type := Count_Type (II);
1161 EA (I .. L) := EA (B .. Length (Container));
1166 Container.Last := New_Last;
1169 procedure Insert_Space
1170 (Container : in out Vector;
1172 Position : out Cursor;
1173 Count : Count_Type := 1)
1175 Index : Index_Type'Base;
1180 or else Before.Index > Container.Last
1182 Position := No_Element;
1184 Position := (True, Before.Index);
1191 or else Before.Index > Container.Last
1193 if Container.Last = Index_Type'Last then
1194 raise Constraint_Error with
1195 "vector is already at its maximum length";
1198 Index := Container.Last + 1;
1201 Index := Before.Index;
1204 Insert_Space (Container, Index, Count => Count);
1206 Position := Cursor'(True, Index);
1213 function Is_Empty (Container : Vector) return Boolean is
1215 return Last_Index (Container) < Index_Type'First;
1223 (Container : Vector;
1225 not null access procedure (Container : Vector; Position : Cursor))
1227 V : Vector renames Container'Unrestricted_Access.all;
1228 B : Natural renames V.Busy;
1234 for Indx in Index_Type'First .. Last_Index (Container) loop
1235 Process (Container, Cursor'(True, Indx));
1250 function Last (Container : Vector) return Cursor is
1252 if Is_Empty (Container) then
1256 return (True, Last_Index (Container));
1263 function Last_Element (Container : Vector) return Element_Type is
1265 if Is_Empty (Container) then
1266 raise Constraint_Error with "Container is empty";
1269 return Get_Element (Container, Length (Container));
1276 function Last_Index (Container : Vector) return Extended_Index is
1278 return Container.Last;
1285 function Length (Container : Vector) return Capacity_Subtype is
1286 L : constant Int := Int (Last_Index (Container));
1287 F : constant Int := Int (Index_Type'First);
1288 N : constant Int'Base := L - F + 1;
1291 return Capacity_Subtype (N);
1298 function Left (Container : Vector; Position : Cursor) return Vector is
1299 C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
1302 if Position = No_Element then
1306 if not Has_Element (Container, Position) then
1307 raise Constraint_Error;
1310 while C.Last /= Position.Index - 1 loop
1321 (Target : in out Vector;
1322 Source : in out Vector)
1324 N : constant Count_Type := Length (Source);
1327 if Target'Address = Source'Address then
1331 if Target.Busy > 0 then
1332 raise Program_Error with
1333 "attempt to tamper with elements (Target is busy)";
1336 if Source.Busy > 0 then
1337 raise Program_Error with
1338 "attempt to tamper with elements (Source is busy)";
1341 if N > Target.Capacity then
1342 raise Constraint_Error with -- correct exception here???
1343 "length of Source is greater than capacity of Target";
1346 -- We could also write this as a loop, and incrementally
1347 -- copy elements from source to target.
1349 Target.Last := No_Index; -- in case array assignment files
1350 Target.Elements (1 .. N) := Source.Elements (1 .. N);
1352 Target.Last := Source.Last;
1353 Source.Last := No_Index;
1360 function Next (Container : Vector; Position : Cursor) return Cursor is
1362 if not Position.Valid then
1366 if Position.Index < Last_Index (Container) then
1367 return (True, Position.Index + 1);
1377 procedure Next (Container : Vector; Position : in out Cursor) is
1379 if not Position.Valid then
1383 if Position.Index < Last_Index (Container) then
1384 Position.Index := Position.Index + 1;
1386 Position := No_Element;
1394 procedure Prepend (Container : in out Vector; New_Item : Vector) is
1396 Insert (Container, Index_Type'First, New_Item);
1400 (Container : in out Vector;
1401 New_Item : Element_Type;
1402 Count : Count_Type := 1)
1415 procedure Previous (Container : Vector; Position : in out Cursor) is
1417 if not Position.Valid then
1421 if Position.Index > Index_Type'First and
1422 Position.Index <= Last_Index (Container) then
1423 Position.Index := Position.Index - 1;
1425 Position := No_Element;
1429 function Previous (Container : Vector; Position : Cursor) return Cursor is
1431 if not Position.Valid then
1435 if Position.Index > Index_Type'First and
1436 Position.Index <= Last_Index (Container) then
1437 return (True, Position.Index - 1);
1447 procedure Query_Element
1448 (Container : Vector;
1450 Process : not null access procedure (Element : Element_Type))
1452 V : Vector renames Container'Unrestricted_Access.all;
1453 B : Natural renames V.Busy;
1454 L : Natural renames V.Lock;
1457 if Index > Last_Index (Container) then
1458 raise Constraint_Error with "Index is out of range";
1465 II : constant Int'Base := Int (Index) - Int (No_Index);
1466 I : constant Count_Type := Count_Type (II);
1469 Process (Get_Element (V, I));
1481 procedure Query_Element
1482 (Container : Vector;
1484 Process : not null access procedure (Element : Element_Type))
1487 if not Position.Valid then
1488 raise Constraint_Error with "Position cursor has no element";
1491 Query_Element (Container, Position.Index, Process);
1499 (Stream : not null access Root_Stream_Type'Class;
1500 Container : out Vector)
1502 Length : Count_Type'Base;
1503 Last : Index_Type'Base := No_Index;
1508 Count_Type'Base'Read (Stream, Length);
1511 raise Program_Error with "stream appears to be corrupt";
1514 if Length > Container.Capacity then
1515 raise Storage_Error with "not enough capacity"; -- ???
1518 for J in Count_Type range 1 .. Length loop
1520 Element_Type'Read (Stream, Container.Elements (J));
1521 Container.Last := Last;
1526 (Stream : not null access Root_Stream_Type'Class;
1527 Position : out Cursor)
1530 raise Program_Error with "attempt to stream vector cursor";
1533 ---------------------
1534 -- Replace_Element --
1535 ---------------------
1537 procedure Replace_Element
1538 (Container : in out Vector;
1540 New_Item : Element_Type)
1543 if Index > Container.Last then
1544 raise Constraint_Error with "Index is out of range";
1547 if Container.Lock > 0 then
1548 raise Program_Error with
1549 "attempt to tamper with cursors (vector is locked)";
1553 II : constant Int'Base := Int (Index) - Int (No_Index);
1554 I : constant Count_Type := Count_Type (II);
1557 Container.Elements (I) := New_Item;
1559 end Replace_Element;
1561 procedure Replace_Element
1562 (Container : in out Vector;
1564 New_Item : Element_Type)
1567 if not Position.Valid then
1568 raise Constraint_Error with "Position cursor has no element";
1571 if Position.Index > Container.Last then
1572 raise Constraint_Error with "Position cursor is out of range";
1575 if Container.Lock > 0 then
1576 raise Program_Error with
1577 "attempt to tamper with cursors (vector is locked)";
1581 II : constant Int'Base := Int (Position.Index) - Int (No_Index);
1582 I : constant Count_Type := Count_Type (II);
1584 Container.Elements (I) := New_Item;
1586 end Replace_Element;
1588 ----------------------
1589 -- Reserve_Capacity --
1590 ----------------------
1592 procedure Reserve_Capacity
1593 (Container : in out Vector;
1594 Capacity : Capacity_Subtype)
1597 if Capacity > Container.Capacity then
1598 raise Constraint_Error; -- ???
1600 end Reserve_Capacity;
1602 ----------------------
1603 -- Reverse_Elements --
1604 ----------------------
1606 procedure Reverse_Elements (Container : in out Vector) is
1608 if Length (Container) <= 1 then
1612 if Container.Lock > 0 then
1613 raise Program_Error with
1614 "attempt to tamper with cursors (vector is locked)";
1619 E : Elements_Array renames Container.Elements;
1623 J := Length (Container);
1626 EI : constant Element_Type := E (I);
1636 end Reverse_Elements;
1642 function Reverse_Find
1643 (Container : Vector;
1644 Item : Element_Type;
1645 Position : Cursor := No_Element) return Cursor
1647 Last : Index_Type'Base;
1651 if not Position.Valid
1652 or else Position.Index > Last_Index (Container)
1654 Last := Last_Index (Container);
1656 Last := Position.Index;
1659 K := Count_Type (Int (Last) - Int (No_Index));
1660 for Indx in reverse Index_Type'First .. Last loop
1661 if Get_Element (Container, K) = Item then
1662 return (True, Indx);
1671 ------------------------
1672 -- Reverse_Find_Index --
1673 ------------------------
1675 function Reverse_Find_Index
1676 (Container : Vector;
1677 Item : Element_Type;
1678 Index : Index_Type := Index_Type'Last) return Extended_Index
1680 Last : Index_Type'Base;
1684 if Index > Last_Index (Container) then
1685 Last := Last_Index (Container);
1690 K := Count_Type (Int (Last) - Int (No_Index));
1691 for Indx in reverse Index_Type'First .. Last loop
1692 if Get_Element (Container, K) = Item then
1700 end Reverse_Find_Index;
1702 ---------------------
1703 -- Reverse_Iterate --
1704 ---------------------
1706 procedure Reverse_Iterate
1707 (Container : Vector;
1708 Process : not null access procedure (Container : Vector;
1711 V : Vector renames Container'Unrestricted_Access.all;
1712 B : Natural renames V.Busy;
1718 for Indx in reverse Index_Type'First .. Last_Index (Container) loop
1719 Process (Container, Cursor'(True, Indx));
1728 end Reverse_Iterate;
1734 function Right (Container : Vector; Position : Cursor) return Vector is
1735 C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
1738 if Position = No_Element then
1743 if not Has_Element (Container, Position) then
1744 raise Constraint_Error;
1747 while C.Last /= Container.Last - Position.Index + 1 loop
1758 procedure Set_Length
1759 (Container : in out Vector;
1760 Length : Capacity_Subtype)
1763 if Length = Formal_Vectors.Length (Container) then
1767 if Container.Busy > 0 then
1768 raise Program_Error with
1769 "attempt to tamper with elements (vector is busy)";
1772 if Length > Container.Capacity then
1773 raise Constraint_Error; -- ???
1777 Last_As_Int : constant Int'Base :=
1778 Int (Index_Type'First) + Int (Length) - 1;
1780 Container.Last := Index_Type'Base (Last_As_Int);
1788 procedure Swap (Container : in out Vector; I, J : Index_Type) is
1790 if I > Container.Last then
1791 raise Constraint_Error with "I index is out of range";
1794 if J > Container.Last then
1795 raise Constraint_Error with "J index is out of range";
1802 if Container.Lock > 0 then
1803 raise Program_Error with
1804 "attempt to tamper with cursors (vector is locked)";
1808 II : constant Int'Base := Int (I) - Int (No_Index);
1809 JJ : constant Int'Base := Int (J) - Int (No_Index);
1811 EI : Element_Type renames Container.Elements (Count_Type (II));
1812 EJ : Element_Type renames Container.Elements (Count_Type (JJ));
1814 EI_Copy : constant Element_Type := EI;
1822 procedure Swap (Container : in out Vector; I, J : Cursor) is
1825 raise Constraint_Error with "I cursor has no element";
1829 raise Constraint_Error with "J cursor has no element";
1832 Swap (Container, I.Index, J.Index);
1840 (Container : Vector;
1841 Index : Extended_Index) return Cursor
1844 if Index not in Index_Type'First .. Last_Index (Container) then
1848 return Cursor'(True, Index);
1855 function To_Index (Position : Cursor) return Extended_Index is
1857 if not Position.Valid then
1861 return Position.Index;
1868 function To_Vector (Length : Capacity_Subtype) return Vector is
1871 return Empty_Vector;
1875 First : constant Int := Int (Index_Type'First);
1876 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1880 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1881 raise Constraint_Error with "Length is out of range"; -- ???
1884 Last := Index_Type (Last_As_Int);
1886 return (Length, (others => <>), Last => Last,
1892 (New_Item : Element_Type;
1893 Length : Capacity_Subtype) return Vector
1897 return Empty_Vector;
1901 First : constant Int := Int (Index_Type'First);
1902 Last_As_Int : constant Int'Base := First + Int (Length) - 1;
1906 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
1907 raise Constraint_Error with "Length is out of range"; -- ???
1910 Last := Index_Type (Last_As_Int);
1912 return (Length, (others => New_Item), Last => Last,
1917 --------------------
1918 -- Update_Element --
1919 --------------------
1921 procedure Update_Element
1922 (Container : in out Vector;
1924 Process : not null access procedure (Element : in out Element_Type))
1926 B : Natural renames Container.Busy;
1927 L : Natural renames Container.Lock;
1930 if Index > Container.Last then
1931 raise Constraint_Error with "Index is out of range";
1938 II : constant Int'Base := Int (Index) - Int (No_Index);
1939 I : constant Count_Type := Count_Type (II);
1942 Process (Container.Elements (I));
1954 procedure Update_Element
1955 (Container : in out Vector;
1957 Process : not null access procedure (Element : in out Element_Type))
1960 if not Position.Valid then
1961 raise Constraint_Error with "Position cursor has no element";
1964 Update_Element (Container, Position.Index, Process);
1972 (Stream : not null access Root_Stream_Type'Class;
1976 Count_Type'Base'Write (Stream, Length (Container));
1978 for J in 1 .. Length (Container) loop
1979 Element_Type'Write (Stream, Container.Elements (J));
1984 (Stream : not null access Root_Stream_Type'Class;
1988 raise Program_Error with "attempt to stream vector cursor";
1991 end Ada.Containers.Formal_Vectors;