Skip to content

R
riscv-gcc-1
Commit 2602b64e by Arnaud Charlet
Options

[multiple changes] 

2013-04-11  Robert Dewar  <dewar@adacore.com>

	* stand.ads: Minor reformatting.

2013-04-11  Matthew Heaney  <heaney@adacore.com>

	* a-convec.adb, a-coinve.adb, a-cobove.adb ("="): Increment lock
	counts before entering loop.
	(Find, Find_Index): Ditto.
	(Is_Sorted, Merge, Sort): Ditto.
	(Reverse_Find, Reverse_Find_Index): Ditto.

From-SVN: r197765
parent c8d63650
Showing with 908 additions and 400 deletions
gcc/ada/ChangeLog
2013-04-11 Robert Dewar <dewar@adacore.com> 2013-04-11 Robert Dewar <dewar@adacore.com>
* stand.ads: Minor reformatting.
2013-04-11 Matthew Heaney <heaney@adacore.com>
* a-convec.adb, a-coinve.adb, a-cobove.adb ("="): Increment lock
counts before entering loop.
(Find, Find_Index): Ditto.
(Is_Sorted, Merge, Sort): Ditto.
(Reverse_Find, Reverse_Find_Index): Ditto.
2013-04-11 Robert Dewar <dewar@adacore.com>
* exp_ch11.ads, exp_ch11.adb (Expand_N_Raise_Expression): New procedure. * exp_ch11.ads, exp_ch11.adb (Expand_N_Raise_Expression): New procedure.
* exp_util.adb (Insert_Actions): Add entry for N_Raise_Expression. * exp_util.adb (Insert_Actions): Add entry for N_Raise_Expression.
* expander.adb: Add call to Expand_N_Raise_Expression. * expander.adb: Add call to Expand_N_Raise_Expression.
......
gcc/ada/a-cobove.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -112,8 +112,8 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -112,8 +112,8 @@ package body Ada.Containers.Bounded_Vectors is
raise Constraint_Error with "new length is out of range"; raise Constraint_Error with "new length is out of range";
end if; end if;
-- It is now safe compute the length of the new vector, without fear of -- It is now safe to compute the length of the new vector, without fear
-- overflow. -- of overflow.
N := LN + RN; N := LN + RN;
...@@ -122,6 +122,7 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -122,6 +122,7 @@ package body Ada.Containers.Bounded_Vectors is
-- Count_Type'Base as the type for intermediate values. -- Count_Type'Base as the type for intermediate values.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-- We perform a two-part test. First we determine whether the -- We perform a two-part test. First we determine whether the
-- computed Last value lies in the base range of the type, and then -- computed Last value lies in the base range of the type, and then
-- determine whether it lies in the range of the index (sub)type. -- determine whether it lies in the range of the index (sub)type.
...@@ -150,6 +151,7 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -150,6 +151,7 @@ package body Ada.Containers.Bounded_Vectors is
end if; end if;
elsif Index_Type'First <= 0 then elsif Index_Type'First <= 0 then
-- Here we can compute Last directly, in the normal way. We know that -- Here we can compute Last directly, in the normal way. We know that
-- No_Index is less than 0, so there is no danger of overflow when -- No_Index is less than 0, so there is no danger of overflow when
-- adding the (positive) value of length. -- adding the (positive) value of length.
...@@ -280,6 +282,14 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -280,6 +282,14 @@ package body Ada.Containers.Bounded_Vectors is
--------- ---------
overriding function "=" (Left, Right : Vector) return Boolean is overriding function "=" (Left, Right : Vector) return Boolean is
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Result : Boolean;
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return True; return True;
...@@ -289,13 +299,40 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -289,13 +299,40 @@ package body Ada.Containers.Bounded_Vectors is
return False; return False;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
Result := True;
for J in Count_Type range 1 .. Left.Length loop for J in Count_Type range 1 .. Left.Length loop
if Left.Elements (J) /= Right.Elements (J) then if Left.Elements (J) /= Right.Elements (J) then
return False; Result := False;
exit;
end if; end if;
end loop; end loop;
return True; BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Result;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end "="; end "=";
------------ ------------
...@@ -543,7 +580,6 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -543,7 +580,6 @@ package body Ada.Containers.Bounded_Vectors is
if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
else else
Count2 := Count_Type'Base (Old_Last - Index + 1); Count2 := Count_Type'Base (Old_Last - Index + 1);
end if; end if;
...@@ -567,7 +603,6 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -567,7 +603,6 @@ package body Ada.Containers.Bounded_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Off := Count_Type'Base (Index - Index_Type'First); Off := Count_Type'Base (Index - Index_Type'First);
New_Last := Old_Last - Index_Type'Base (Count); New_Last := Old_Last - Index_Type'Base (Count);
else else
Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
...@@ -579,7 +614,6 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -579,7 +614,6 @@ package body Ada.Containers.Bounded_Vectors is
declare declare
EA : Elements_Array renames Container.Elements; EA : Elements_Array renames Container.Elements;
Idx : constant Count_Type := EA'First + Off; Idx : constant Count_Type := EA'First + Off;
begin begin
EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
Container.Last := New_Last; Container.Last := New_Last;
...@@ -621,14 +655,14 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -621,14 +655,14 @@ package body Ada.Containers.Bounded_Vectors is
begin begin
if Count = 0 then if Count = 0 then
return; return;
end if;
if Count >= Length (Container) then elsif Count >= Length (Container) then
Clear (Container); Clear (Container);
return; return;
end if;
else
Delete (Container, Index_Type'First, Count); Delete (Container, Index_Type'First, Count);
end if;
end Delete_First; end Delete_First;
----------------- -----------------
...@@ -738,13 +772,42 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -738,13 +772,42 @@ package body Ada.Containers.Bounded_Vectors is
end if; end if;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for J in Position.Index .. Container.Last loop for J in Position.Index .. Container.Last loop
if Container.Elements (To_Array_Index (J)) = Item then if Container.Elements (To_Array_Index (J)) = Item then
return (Container'Unrestricted_Access, J); Result := J;
exit;
end if; end if;
end loop; end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Find; end Find;
---------------- ----------------
...@@ -756,14 +819,36 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -756,14 +819,36 @@ package body Ada.Containers.Bounded_Vectors is
Item : Element_Type; Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index Index : Index_Type := Index_Type'First) return Extended_Index
is is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in Index .. Container.Last loop for Indx in Index .. Container.Last loop
if Container.Elements (To_Array_Index (Indx)) = Item then if Container.Elements (To_Array_Index (Indx)) = Item then
return Indx; Result := Indx;
exit;
end if; end if;
end loop; end loop;
return No_Index; B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Find_Index; end Find_Index;
----------- -----------
...@@ -841,17 +926,40 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -841,17 +926,40 @@ package body Ada.Containers.Bounded_Vectors is
return True; return True;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare declare
EA : Elements_Array renames Container.Elements; EA : Elements_Array renames Container.Elements;
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Boolean;
begin begin
B := B + 1;
L := L + 1;
Result := True;
for J in 1 .. Container.Length - 1 loop for J in 1 .. Container.Length - 1 loop
if EA (J + 1) < EA (J) then if EA (J + 1) < EA (J) then
return False; Result := False;
exit;
end if; end if;
end loop; end loop;
end;
return True; B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Is_Sorted; end Is_Sorted;
----------- -----------
...@@ -862,7 +970,6 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -862,7 +970,6 @@ package body Ada.Containers.Bounded_Vectors is
I, J : Count_Type; I, J : Count_Type;
begin begin
-- The semantics of Merge changed slightly per AI05-0021. It was -- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same -- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did -- container object, then the GNAT implementation of Merge did
...@@ -893,21 +1000,35 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -893,21 +1000,35 @@ package body Ada.Containers.Bounded_Vectors is
I := Target.Length; I := Target.Length;
Target.Set_Length (I + Source.Length); Target.Set_Length (I + Source.Length);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare declare
TA : Elements_Array renames Target.Elements; TA : Elements_Array renames Target.Elements;
SA : Elements_Array renames Source.Elements; SA : Elements_Array renames Source.Elements;
TB : Natural renames Target.Busy;
TL : Natural renames Target.Lock;
SB : Natural renames Source.Busy;
SL : Natural renames Source.Lock;
begin begin
TB := TB + 1;
TL := TL + 1;
SB := SB + 1;
SL := SL + 1;
J := Target.Length; J := Target.Length;
while not Source.Is_Empty loop while not Source.Is_Empty loop
pragma Assert (Source.Length <= 1 pragma Assert (Source.Length <= 1
or else not (SA (Source.Length) < or else not (SA (Source.Length) < SA (Source.Length - 1)));
SA (Source.Length - 1)));
if I = 0 then if I = 0 then
TA (1 .. J) := SA (1 .. Source.Length); TA (1 .. J) := SA (1 .. Source.Length);
Source.Last := No_Index; Source.Last := No_Index;
return; exit;
end if; end if;
pragma Assert (I <= 1 pragma Assert (I <= 1
...@@ -924,6 +1045,22 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -924,6 +1045,22 @@ package body Ada.Containers.Bounded_Vectors is
J := J - 1; J := J - 1;
end loop; end loop;
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
exception
when others =>
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
raise;
end; end;
end Merge; end Merge;
...@@ -960,7 +1097,28 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -960,7 +1097,28 @@ package body Ada.Containers.Bounded_Vectors is
"attempt to tamper with cursors (vector is busy)"; "attempt to tamper with cursors (vector is busy)";
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
Sort (Container.Elements (1 .. Container.Length)); Sort (Container.Elements (1 .. Container.Length));
B := B - 1;
L := L - 1;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Sort; end Sort;
end Generic_Sorting; end Generic_Sorting;
...@@ -1056,10 +1214,12 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1056,10 +1214,12 @@ package body Ada.Containers.Bounded_Vectors is
-- acceptable, then we compute the new last index from that. -- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-- We have to handle the case when there might be more values in the -- We have to handle the case when there might be more values in the
-- range of Index_Type than in the range of Count_Type. -- range of Index_Type than in the range of Count_Type.
if Index_Type'First <= 0 then if Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is -- We know that No_Index (the same as Index_Type'First - 1) is
-- less than 0, so it is safe to compute the following sum without -- less than 0, so it is safe to compute the following sum without
-- fear of overflow. -- fear of overflow.
...@@ -1067,6 +1227,7 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1067,6 +1227,7 @@ package body Ada.Containers.Bounded_Vectors is
Index := No_Index + Index_Type'Base (Count_Type'Last); Index := No_Index + Index_Type'Base (Count_Type'Last);
if Index <= Index_Type'Last then if Index <= Index_Type'Last then
-- We have determined that range of Index_Type has at least as -- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the -- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed. -- maximum number of items that are allowed.
...@@ -1091,6 +1252,7 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1091,6 +1252,7 @@ package body Ada.Containers.Bounded_Vectors is
end if; end if;
elsif Index_Type'First <= 0 then elsif Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is less -- We know that No_Index (the same as Index_Type'First - 1) is less
-- than 0, so it is safe to compute the following sum without fear of -- than 0, so it is safe to compute the following sum without fear of
-- overflow. -- overflow.
...@@ -1098,6 +1260,7 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1098,6 +1260,7 @@ package body Ada.Containers.Bounded_Vectors is
J := Count_Type'Base (No_Index) + Count_Type'Last; J := Count_Type'Base (No_Index) + Count_Type'Last;
if J <= Count_Type'Base (Index_Type'Last) then if J <= Count_Type'Base (Index_Type'Last) then
-- We have determined that range of Index_Type has at least as -- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the maximum -- many values as in Count_Type, so Count_Type'Last is the maximum
-- number of items that are allowed. -- number of items that are allowed.
...@@ -1151,6 +1314,7 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1151,6 +1314,7 @@ package body Ada.Containers.Bounded_Vectors is
J := To_Array_Index (Before); J := To_Array_Index (Before);
if Before > Container.Last then if Before > Container.Last then
-- The new items are being appended to the vector, so no -- The new items are being appended to the vector, so no
-- sliding of existing elements is required. -- sliding of existing elements is required.
...@@ -1508,10 +1672,12 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1508,10 +1672,12 @@ package body Ada.Containers.Bounded_Vectors is
-- acceptable, then we compute the new last index from that. -- acceptable, then we compute the new last index from that.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
-- We have to handle the case when there might be more values in the -- We have to handle the case when there might be more values in the
-- range of Index_Type than in the range of Count_Type. -- range of Index_Type than in the range of Count_Type.
if Index_Type'First <= 0 then if Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is -- We know that No_Index (the same as Index_Type'First - 1) is
-- less than 0, so it is safe to compute the following sum without -- less than 0, so it is safe to compute the following sum without
-- fear of overflow. -- fear of overflow.
...@@ -1519,6 +1685,7 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1519,6 +1685,7 @@ package body Ada.Containers.Bounded_Vectors is
Index := No_Index + Index_Type'Base (Count_Type'Last); Index := No_Index + Index_Type'Base (Count_Type'Last);
if Index <= Index_Type'Last then if Index <= Index_Type'Last then
-- We have determined that range of Index_Type has at least as -- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the -- many values as in Count_Type, so Count_Type'Last is the
-- maximum number of items that are allowed. -- maximum number of items that are allowed.
...@@ -1543,6 +1710,7 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1543,6 +1710,7 @@ package body Ada.Containers.Bounded_Vectors is
end if; end if;
elsif Index_Type'First <= 0 then elsif Index_Type'First <= 0 then
-- We know that No_Index (the same as Index_Type'First - 1) is less -- We know that No_Index (the same as Index_Type'First - 1) is less
-- than 0, so it is safe to compute the following sum without fear of -- than 0, so it is safe to compute the following sum without fear of
-- overflow. -- overflow.
...@@ -1550,6 +1718,7 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1550,6 +1718,7 @@ package body Ada.Containers.Bounded_Vectors is
J := Count_Type'Base (No_Index) + Count_Type'Last; J := Count_Type'Base (No_Index) + Count_Type'Last;
if J <= Count_Type'Base (Index_Type'Last) then if J <= Count_Type'Base (Index_Type'Last) then
-- We have determined that range of Index_Type has at least as -- We have determined that range of Index_Type has at least as
-- many values as in Count_Type, so Count_Type'Last is the maximum -- many values as in Count_Type, so Count_Type'Last is the maximum
-- number of items that are allowed. -- number of items that are allowed.
...@@ -1608,6 +1777,7 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1608,6 +1777,7 @@ package body Ada.Containers.Bounded_Vectors is
-- unused storage for the new items. -- unused storage for the new items.
if Before <= Container.Last then if Before <= Container.Last then
-- The space is being inserted before some existing elements, -- The space is being inserted before some existing elements,
-- so we must slide the existing elements up to their new home. -- so we must slide the existing elements up to their new home.
...@@ -1927,36 +2097,30 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1927,36 +2097,30 @@ package body Ada.Containers.Bounded_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Index < Position.Container.Last then
if Position.Index < Position.Container.Last then
return (Position.Container, Position.Index + 1); return (Position.Container, Position.Index + 1);
end if; else
return No_Element; return No_Element;
end if;
end Next; end Next;
function Next (Object : Iterator; Position : Cursor) return Cursor is function Next (Object : Iterator; Position : Cursor) return Cursor is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Next designates wrong vector"; "Position cursor of Next designates wrong vector";
end if; else
return Next (Position); return Next (Position);
end if;
end Next; end Next;
procedure Next (Position : in out Cursor) is procedure Next (Position : in out Cursor) is
begin begin
if Position.Container = null then if Position.Container = null then
return; return;
end if; elsif Position.Index < Position.Container.Last then
if Position.Index < Position.Container.Last then
Position.Index := Position.Index + 1; Position.Index := Position.Index + 1;
else else
Position := No_Element; Position := No_Element;
...@@ -1992,9 +2156,7 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -1992,9 +2156,7 @@ package body Ada.Containers.Bounded_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return; return;
end if; elsif Position.Index > Index_Type'First then
if Position.Index > Index_Type'First then
Position.Index := Position.Index - 1; Position.Index := Position.Index - 1;
else else
Position := No_Element; Position := No_Element;
...@@ -2005,27 +2167,23 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -2005,27 +2167,23 @@ package body Ada.Containers.Bounded_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Index > Index_Type'First then
if Position.Index > Index_Type'First then
return (Position.Container, Position.Index - 1); return (Position.Container, Position.Index - 1);
end if; else
return No_Element; return No_Element;
end if;
end Previous; end Previous;
function Previous (Object : Iterator; Position : Cursor) return Cursor is function Previous (Object : Iterator; Position : Cursor) return Cursor is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Previous designates wrong vector"; "Position cursor of Previous designates wrong vector";
end if; else
return Previous (Position); return Previous (Position);
end if;
end Previous; end Previous;
------------------- -------------------
...@@ -2069,9 +2227,9 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -2069,9 +2227,9 @@ package body Ada.Containers.Bounded_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if; else
Query_Element (Position.Container.all, Position.Index, Process); Query_Element (Position.Container.all, Position.Index, Process);
end if;
end Query_Element; end Query_Element;
---------- ----------
...@@ -2146,9 +2304,9 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -2146,9 +2304,9 @@ package body Ada.Containers.Bounded_Vectors is
declare declare
A : Elements_Array renames Container.Elements; A : Elements_Array renames Container.Elements;
I : constant Count_Type := To_Array_Index (Position.Index); J : constant Count_Type := To_Array_Index (Position.Index);
begin begin
return (Element => A (I)'Access); return (Element => A (J)'Access);
end; end;
end Reference; end Reference;
...@@ -2163,9 +2321,9 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -2163,9 +2321,9 @@ package body Ada.Containers.Bounded_Vectors is
declare declare
A : Elements_Array renames Container.Elements; A : Elements_Array renames Container.Elements;
I : constant Count_Type := To_Array_Index (Index); J : constant Count_Type := To_Array_Index (Index);
begin begin
return (Element => A (I)'Access); return (Element => A (J)'Access);
end; end;
end Reference; end Reference;
...@@ -2181,14 +2339,12 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -2181,14 +2339,12 @@ package body Ada.Containers.Bounded_Vectors is
begin begin
if Index > Container.Last then if Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
end if; elsif Container.Lock > 0 then
if Container.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (vector is locked)"; "attempt to tamper with elements (vector is locked)";
end if; else
Container.Elements (To_Array_Index (Index)) := New_Item; Container.Elements (To_Array_Index (Index)) := New_Item;
end if;
end Replace_Element; end Replace_Element;
procedure Replace_Element procedure Replace_Element
...@@ -2199,22 +2355,20 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -2199,22 +2355,20 @@ package body Ada.Containers.Bounded_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container"; raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Container.Last then elsif Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range"; raise Constraint_Error with "Position cursor is out of range";
end if;
if Container.Lock > 0 then elsif Container.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (vector is locked)"; "attempt to tamper with elements (vector is locked)";
end if;
else
Container.Elements (To_Array_Index (Position.Index)) := New_Item; Container.Elements (To_Array_Index (Position.Index)) := New_Item;
end if;
end Replace_Element; end Replace_Element;
---------------------- ----------------------
...@@ -2300,13 +2454,41 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -2300,13 +2454,41 @@ package body Ada.Containers.Bounded_Vectors is
then Container.Last then Container.Last
else Position.Index); else Position.Index);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop for Indx in reverse Index_Type'First .. Last loop
if Container.Elements (To_Array_Index (Indx)) = Item then if Container.Elements (To_Array_Index (Indx)) = Item then
return (Container'Unrestricted_Access, Indx); Result := Indx;
exit;
end if; end if;
end loop; end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Reverse_Find; end Reverse_Find;
------------------------ ------------------------
...@@ -2318,17 +2500,39 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -2318,17 +2500,39 @@ package body Ada.Containers.Bounded_Vectors is
Item : Element_Type; Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index Index : Index_Type := Index_Type'Last) return Extended_Index
is is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Last : constant Index_Type'Base := Last : constant Index_Type'Base :=
Index_Type'Min (Container.Last, Index); Index_Type'Min (Container.Last, Index);
Result : Index_Type'Base;
begin begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop for Indx in reverse Index_Type'First .. Last loop
if Container.Elements (To_Array_Index (Indx)) = Item then if Container.Elements (To_Array_Index (Indx)) = Item then
return Indx; Result := Indx;
exit;
end if; end if;
end loop; end loop;
return No_Index; B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Reverse_Find_Index; end Reverse_Find_Index;
--------------------- ---------------------
...@@ -2375,10 +2579,8 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -2375,10 +2579,8 @@ package body Ada.Containers.Bounded_Vectors is
if Count >= 0 then if Count >= 0 then
Container.Delete_Last (Count); Container.Delete_Last (Count);
elsif Container.Last >= Index_Type'Last then elsif Container.Last >= Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length"; raise Constraint_Error with "vector is already at its maximum length";
else else
Container.Insert_Space (Container.Last + 1, -Count); Container.Insert_Space (Container.Last + 1, -Count);
end if; end if;
...@@ -2451,11 +2653,11 @@ package body Ada.Containers.Bounded_Vectors is ...@@ -2451,11 +2653,11 @@ package body Ada.Containers.Bounded_Vectors is
-- hence we also know that -- hence we also know that
-- Index - Index_Type'First >= 0 -- Index - Index_Type'First >= 0
-- The issue is that even though 0 is guaranteed to be a value -- The issue is that even though 0 is guaranteed to be a value in
-- in the type Index_Type'Base, there's no guarantee that the -- the type Index_Type'Base, there's no guarantee that the difference
-- difference is a value in that type. To prevent overflow we -- is a value in that type. To prevent overflow we use the wider
-- use the wider of Count_Type'Base and Index_Type'Base to -- of Count_Type'Base and Index_Type'Base to perform intermediate
-- perform intermediate calculations. -- calculations.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Offset := Count_Type'Base (Index - Index_Type'First); Offset := Count_Type'Base (Index - Index_Type'First);
......
gcc/ada/a-coinve.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -117,7 +117,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -117,7 +117,6 @@ package body Ada.Containers.Indefinite_Vectors is
return (Controlled with Elements, Right.Last, 0, 0); return (Controlled with Elements, Right.Last, 0, 0);
end; end;
end if; end if;
if RN = 0 then if RN = 0 then
...@@ -243,7 +242,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -243,7 +242,6 @@ package body Ada.Containers.Indefinite_Vectors is
declare declare
LE : Elements_Array renames LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last); Left.Elements.EA (Index_Type'First .. Left.Last);
RE : Elements_Array renames RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last); Right.Elements.EA (Index_Type'First .. Right.Last);
...@@ -514,6 +512,14 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -514,6 +512,14 @@ package body Ada.Containers.Indefinite_Vectors is
--------- ---------
overriding function "=" (Left, Right : Vector) return Boolean is overriding function "=" (Left, Right : Vector) return Boolean is
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Result : Boolean;
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return True; return True;
...@@ -523,21 +529,49 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -523,21 +529,49 @@ package body Ada.Containers.Indefinite_Vectors is
return False; return False;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
Result := True;
for J in Index_Type'First .. Left.Last loop for J in Index_Type'First .. Left.Last loop
if Left.Elements.EA (J) = null then if Left.Elements.EA (J) = null then
if Right.Elements.EA (J) /= null then if Right.Elements.EA (J) /= null then
return False; Result := False;
exit;
end if; end if;
elsif Right.Elements.EA (J) = null then elsif Right.Elements.EA (J) = null then
return False; Result := False;
exit;
elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
return False; Result := False;
exit;
end if; end if;
end loop; end loop;
return True; BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Result;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end "="; end "=";
------------ ------------
...@@ -564,12 +598,12 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -564,12 +598,12 @@ package body Ada.Containers.Indefinite_Vectors is
Container.Elements := new Elements_Type (L); Container.Elements := new Elements_Type (L);
for I in E'Range loop for J in E'Range loop
if E (I) /= null then if E (J) /= null then
Container.Elements.EA (I) := new Element_Type'(E (I).all); Container.Elements.EA (J) := new Element_Type'(E (J).all);
end if; end if;
Container.Last := I; Container.Last := J;
end loop; end loop;
end; end;
end Adjust; end Adjust;
...@@ -596,16 +630,11 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -596,16 +630,11 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Is_Empty (New_Item) then if Is_Empty (New_Item) then
return; return;
end if; elsif Container.Last = Index_Type'Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length"; raise Constraint_Error with "vector is already at its maximum length";
else
Insert (Container, Container.Last + 1, New_Item);
end if; end if;
Insert
(Container,
Container.Last + 1,
New_Item);
end Append; end Append;
procedure Append procedure Append
...@@ -616,17 +645,11 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -616,17 +645,11 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Count = 0 then if Count = 0 then
return; return;
end if; elsif Container.Last = Index_Type'Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length"; raise Constraint_Error with "vector is already at its maximum length";
else
Insert (Container, Container.Last + 1, New_Item, Count);
end if; end if;
Insert
(Container,
Container.Last + 1,
New_Item,
Count);
end Append; end Append;
------------ ------------
...@@ -637,10 +660,10 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -637,10 +660,10 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
return; return;
end if; else
Target.Clear; Target.Clear;
Target.Append (Source); Target.Append (Source);
end if;
end Assign; end Assign;
-------------- --------------
...@@ -651,9 +674,9 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -651,9 +674,9 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Container.Elements = null then if Container.Elements = null then
return 0; return 0;
end if; else
return Container.Elements.EA'Length; return Container.Elements.EA'Length;
end if;
end Capacity; end Capacity;
----------- -----------
...@@ -665,8 +688,8 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -665,8 +688,8 @@ package body Ada.Containers.Indefinite_Vectors is
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors (vector is busy)"; "attempt to tamper with cursors (vector is busy)";
end if;
else
while Container.Last >= Index_Type'First loop while Container.Last >= Index_Type'First loop
declare declare
X : Element_Access := Container.Elements.EA (Container.Last); X : Element_Access := Container.Elements.EA (Container.Last);
...@@ -676,6 +699,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -676,6 +699,7 @@ package body Ada.Containers.Indefinite_Vectors is
Free (X); Free (X);
end; end;
end loop; end loop;
end if;
end Clear; end Clear;
------------------------ ------------------------
...@@ -840,10 +864,10 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -840,10 +864,10 @@ package body Ada.Containers.Indefinite_Vectors is
if Index > Old_Last then if Index > Old_Last then
if Index > Old_Last + 1 then if Index > Old_Last + 1 then
raise Constraint_Error with "Index is out of range (too large)"; raise Constraint_Error with "Index is out of range (too large)";
end if; else
return; return;
end if; end if;
end if;
-- Here and elsewhere we treat deleting 0 items from the container as a -- Here and elsewhere we treat deleting 0 items from the container as a
-- no-op, even when the container is busy, so we simply return. -- no-op, even when the container is busy, so we simply return.
...@@ -934,7 +958,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -934,7 +958,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := Old_Last - Index_Type'Base (Count); New_Last := Old_Last - Index_Type'Base (Count);
J := Index + Index_Type'Base (Count); J := Index + Index_Type'Base (Count);
else else
New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
J := Index_Type'Base (Count_Type'Base (Index) + Count); J := Index_Type'Base (Count_Type'Base (Index) + Count);
...@@ -987,19 +1010,17 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -987,19 +1010,17 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container"; raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Container.Last then elsif Position.Index > Container.Last then
raise Program_Error with "Position index is out of range"; raise Program_Error with "Position index is out of range";
end if;
else
Delete (Container, Position.Index, Count); Delete (Container, Position.Index, Count);
Position := No_Element; Position := No_Element;
end if;
end Delete; end Delete;
------------------ ------------------
...@@ -1013,14 +1034,14 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1013,14 +1034,14 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Count = 0 then if Count = 0 then
return; return;
end if;
if Count >= Length (Container) then elsif Count >= Length (Container) then
Clear (Container); Clear (Container);
return; return;
end if;
else
Delete (Container, Index_Type'First, Count); Delete (Container, Index_Type'First, Count);
end if;
end Delete_First; end Delete_First;
----------------- -----------------
...@@ -1110,13 +1131,12 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1110,13 +1131,12 @@ package body Ada.Containers.Indefinite_Vectors is
declare declare
EA : constant Element_Access := Container.Elements.EA (Index); EA : constant Element_Access := Container.Elements.EA (Index);
begin begin
if EA = null then if EA = null then
raise Constraint_Error with "element is empty"; raise Constraint_Error with "element is empty";
end if; else
return EA.all; return EA.all;
end if;
end; end;
end Element; end Element;
...@@ -1133,13 +1153,12 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1133,13 +1153,12 @@ package body Ada.Containers.Indefinite_Vectors is
declare declare
EA : constant Element_Access := EA : constant Element_Access :=
Position.Container.Elements.EA (Position.Index); Position.Container.Elements.EA (Position.Index);
begin begin
if EA = null then if EA = null then
raise Constraint_Error with "element is empty"; raise Constraint_Error with "element is empty";
end if; else
return EA.all; return EA.all;
end if;
end; end;
end Element; end Element;
...@@ -1201,15 +1220,44 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1201,15 +1220,44 @@ package body Ada.Containers.Indefinite_Vectors is
end if; end if;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for J in Position.Index .. Container.Last loop for J in Position.Index .. Container.Last loop
if Container.Elements.EA (J) /= null if Container.Elements.EA (J) /= null
and then Container.Elements.EA (J).all = Item and then Container.Elements.EA (J).all = Item
then then
return (Container'Unrestricted_Access, J); Result := J;
exit;
end if; end if;
end loop; end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Find; end Find;
---------------- ----------------
...@@ -1221,16 +1269,38 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1221,16 +1269,38 @@ package body Ada.Containers.Indefinite_Vectors is
Item : Element_Type; Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index Index : Index_Type := Index_Type'First) return Extended_Index
is is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in Index .. Container.Last loop for Indx in Index .. Container.Last loop
if Container.Elements.EA (Indx) /= null if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item and then Container.Elements.EA (Indx).all = Item
then then
return Indx; Result := Indx;
exit;
end if; end if;
end loop; end loop;
return No_Index; B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Find_Index; end Find_Index;
----------- -----------
...@@ -1282,13 +1352,12 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1282,13 +1352,12 @@ package body Ada.Containers.Indefinite_Vectors is
declare declare
EA : constant Element_Access := EA : constant Element_Access :=
Container.Elements.EA (Index_Type'First); Container.Elements.EA (Index_Type'First);
begin begin
if EA = null then if EA = null then
raise Constraint_Error with "first element is empty"; raise Constraint_Error with "first element is empty";
end if; else
return EA.all; return EA.all;
end if;
end; end;
end First_Element; end First_Element;
...@@ -1340,17 +1409,40 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1340,17 +1409,40 @@ package body Ada.Containers.Indefinite_Vectors is
return True; return True;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare declare
E : Elements_Array renames Container.Elements.EA; E : Elements_Array renames Container.Elements.EA;
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Boolean;
begin begin
B := B + 1;
L := L + 1;
Result := True;
for I in Index_Type'First .. Container.Last - 1 loop for I in Index_Type'First .. Container.Last - 1 loop
if Is_Less (E (I + 1), E (I)) then if Is_Less (E (I + 1), E (I)) then
return False; Result := False;
exit;
end if; end if;
end loop; end loop;
end;
return True; B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Is_Sorted; end Is_Sorted;
----------- -----------
...@@ -1361,7 +1453,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1361,7 +1453,6 @@ package body Ada.Containers.Indefinite_Vectors is
I, J : Index_Type'Base; I, J : Index_Type'Base;
begin begin
-- The semantics of Merge changed slightly per AI05-0021. It was -- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same -- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did -- container object, then the GNAT implementation of Merge did
...@@ -1392,37 +1483,53 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1392,37 +1483,53 @@ package body Ada.Containers.Indefinite_Vectors is
I := Target.Last; -- original value (before Set_Length) I := Target.Last; -- original value (before Set_Length)
Target.Set_Length (Length (Target) + Length (Source)); Target.Set_Length (Length (Target) + Length (Source));
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
TA : Elements_Array renames Target.Elements.EA;
SA : Elements_Array renames Source.Elements.EA;
TB : Natural renames Target.Busy;
TL : Natural renames Target.Lock;
SB : Natural renames Source.Busy;
SL : Natural renames Source.Lock;
begin
TB := TB + 1;
TL := TL + 1;
SB := SB + 1;
SL := SL + 1;
J := Target.Last; -- new value (after Set_Length) J := Target.Last; -- new value (after Set_Length)
while Source.Last >= Index_Type'First loop while Source.Last >= Index_Type'First loop
pragma Assert pragma Assert
(Source.Last <= Index_Type'First (Source.Last <= Index_Type'First
or else not (Is_Less or else not (Is_Less (SA (Source.Last),
(Source.Elements.EA (Source.Last), SA (Source.Last - 1))));
Source.Elements.EA (Source.Last - 1))));
if I < Index_Type'First then if I < Index_Type'First then
declare declare
Src : Elements_Array renames Src : Elements_Array renames
Source.Elements.EA (Index_Type'First .. Source.Last); SA (Index_Type'First .. Source.Last);
begin begin
Target.Elements.EA (Index_Type'First .. J) := Src; TA (Index_Type'First .. J) := Src;
Src := (others => null); Src := (others => null);
end; end;
Source.Last := No_Index; Source.Last := No_Index;
return; exit;
end if; end if;
pragma Assert pragma Assert
(I <= Index_Type'First (I <= Index_Type'First
or else not (Is_Less or else not (Is_Less (TA (I), TA (I - 1))));
(Target.Elements.EA (I),
Target.Elements.EA (I - 1))));
declare declare
Src : Element_Access renames Source.Elements.EA (Source.Last); Src : Element_Access renames SA (Source.Last);
Tgt : Element_Access renames Target.Elements.EA (I); Tgt : Element_Access renames TA (I);
begin begin
if Is_Less (Src, Tgt) then if Is_Less (Src, Tgt) then
...@@ -1439,6 +1546,23 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1439,6 +1546,23 @@ package body Ada.Containers.Indefinite_Vectors is
J := J - 1; J := J - 1;
end loop; end loop;
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
exception
when others =>
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
raise;
end;
end Merge; end Merge;
---------- ----------
...@@ -1475,7 +1599,28 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1475,7 +1599,28 @@ package body Ada.Containers.Indefinite_Vectors is
"attempt to tamper with cursors (vector is busy)"; "attempt to tamper with cursors (vector is busy)";
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
B := B - 1;
L := L - 1;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Sort; end Sort;
end Generic_Sorting; end Generic_Sorting;
...@@ -1488,9 +1633,9 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1488,9 +1633,9 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return False; return False;
end if; else
return Position.Index <= Position.Container.Last; return Position.Index <= Position.Container.Last;
end if;
end Has_Element; end Has_Element;
------------ ------------
...@@ -1663,7 +1808,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1663,7 +1808,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := No_Index + Index_Type'Base (New_Length); New_Last := No_Index + Index_Type'Base (New_Length);
else else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
end if; end if;
...@@ -1859,7 +2003,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1859,7 +2003,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity); Dst_Last := No_Index + Index_Type'Base (New_Capacity);
else else
Dst_Last := Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
...@@ -1888,9 +2031,8 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1888,9 +2031,8 @@ package body Ada.Containers.Indefinite_Vectors is
-- The new items are being appended to the vector, so no -- The new items are being appended to the vector, so no
-- sliding of existing elements is required. -- sliding of existing elements is required.
-- We have copied the elements from to the old, source array to -- We have copied the elements from to the old source array to the
-- the new, destination array, so we can now deallocate the old -- new destination array, so we can now deallocate the old array.
-- array.
Container.Elements := Dst; Container.Elements := Dst;
Free (Src); Free (Src);
...@@ -1899,11 +2041,11 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1899,11 +2041,11 @@ package body Ada.Containers.Indefinite_Vectors is
for Idx in Before .. New_Last loop for Idx in Before .. New_Last loop
-- In order to preserve container invariants, we always -- In order to preserve container invariants, we always attempt
-- attempt the element allocation first, before setting the -- the element allocation first, before setting the Last index
-- Last index value, in case the allocation fails (either -- value, in case the allocation fails (either because there
-- because there is no storage available, or because element -- is no storage available, or because element initialization
-- initialization fails). -- fails).
declare declare
-- The element allocator may need an accessibility check in -- The element allocator may need an accessibility check in
...@@ -1928,24 +2070,21 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -1928,24 +2070,21 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count); Index := Before + Index_Type'Base (Count);
else else
Index := Index_Type'Base (Count_Type'Base (Before) + Count); Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if; end if;
Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
-- We have copied the elements from to the old, source array to -- We have copied the elements from to the old source array to the
-- the new, destination array, so we can now deallocate the old -- new destination array, so we can now deallocate the old array.
-- array.
Container.Elements := Dst; Container.Elements := Dst;
Container.Last := New_Last; Container.Last := New_Last;
Free (Src); Free (Src);
-- The new array has a range in the middle containing null access -- The new array has a range in the middle containing null access
-- values. We now fill in that partition of the array with the new -- values. Fill in that partition of the array with the new items.
-- items.
for Idx in Before .. Index - 1 loop for Idx in Before .. Index - 1 loop
...@@ -2081,7 +2220,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2081,7 +2220,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
J := Before + Index_Type'Base (N); J := Before + Index_Type'Base (N);
else else
J := Index_Type'Base (Count_Type'Base (Before) + N); J := Index_Type'Base (Count_Type'Base (Before) + N);
end if; end if;
...@@ -2105,7 +2243,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2105,7 +2243,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Index := J - Index_Type'Base (Src'Length); Dst_Index := J - Index_Type'Base (Src'Length);
else else
Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length); Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length);
end if; end if;
...@@ -2138,9 +2275,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2138,9 +2275,7 @@ package body Ada.Containers.Indefinite_Vectors is
return; return;
end if; end if;
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
if Container.Last = Index_Type'Last then if Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
...@@ -2172,9 +2307,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2172,9 +2307,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if; end if;
if Is_Empty (New_Item) then if Is_Empty (New_Item) then
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
Position := No_Element; Position := No_Element;
else else
Position := (Container'Unrestricted_Access, Before.Index); Position := (Container'Unrestricted_Access, Before.Index);
...@@ -2183,9 +2316,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2183,9 +2316,7 @@ package body Ada.Containers.Indefinite_Vectors is
return; return;
end if; end if;
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
if Container.Last = Index_Type'Last then if Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
...@@ -2221,9 +2352,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2221,9 +2352,7 @@ package body Ada.Containers.Indefinite_Vectors is
return; return;
end if; end if;
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
if Container.Last = Index_Type'Last then if Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
...@@ -2266,9 +2395,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2266,9 +2395,7 @@ package body Ada.Containers.Indefinite_Vectors is
return; return;
end if; end if;
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
if Container.Last = Index_Type'Last then if Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
...@@ -2330,9 +2457,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2330,9 +2457,7 @@ package body Ada.Containers.Indefinite_Vectors is
-- deeper flaw in the caller's algorithm, so that case is treated as a -- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.) -- proper error.)
if Before > Container.Last if Before > Container.Last and then Before > Container.Last + 1 then
and then Before > Container.Last + 1
then
raise Constraint_Error with raise Constraint_Error with
"Before index is out of range (too large)"; "Before index is out of range (too large)";
end if; end if;
...@@ -2453,7 +2578,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2453,7 +2578,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := No_Index + Index_Type'Base (New_Length); New_Last := No_Index + Index_Type'Base (New_Length);
else else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
end if; end if;
...@@ -2490,7 +2614,8 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2490,7 +2614,8 @@ package body Ada.Containers.Indefinite_Vectors is
end if; end if;
if New_Length <= Container.Elements.EA'Length then if New_Length <= Container.Elements.EA'Length then
-- In this case, we're inserting elements into a vector that has
-- In this case, we are inserting elements into a vector that has
-- already allocated an internal array, and the existing array has -- already allocated an internal array, and the existing array has
-- enough unused storage for the new items. -- enough unused storage for the new items.
...@@ -2501,13 +2626,12 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2501,13 +2626,12 @@ package body Ada.Containers.Indefinite_Vectors is
if Before <= Container.Last then if Before <= Container.Last then
-- The new space is being inserted before some existing -- The new space is being inserted before some existing
-- elements, so we must slide the existing elements up to their -- elements, so we must slide the existing elements up to
-- new home. We use the wider of Index_Type'Base and -- their new home. We use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate index values. -- Count_Type'Base as the type for intermediate index values.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count); Index := Before + Index_Type'Base (Count);
else else
Index := Index_Type'Base (Count_Type'Base (Before) + Count); Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if; end if;
...@@ -2554,7 +2678,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2554,7 +2678,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity); Dst_Last := No_Index + Index_Type'Base (New_Capacity);
else else
Dst_Last := Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
...@@ -2585,7 +2708,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2585,7 +2708,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count); Index := Before + Index_Type'Base (Count);
else else
Index := Index_Type'Base (Count_Type'Base (Before) + Count); Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if; end if;
...@@ -2619,9 +2741,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2619,9 +2741,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if; end if;
if Count = 0 then if Count = 0 then
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
Position := No_Element; Position := No_Element;
else else
Position := (Container'Unrestricted_Access, Before.Index); Position := (Container'Unrestricted_Access, Before.Index);
...@@ -2811,13 +2931,12 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2811,13 +2931,12 @@ package body Ada.Containers.Indefinite_Vectors is
declare declare
EA : constant Element_Access := EA : constant Element_Access :=
Container.Elements.EA (Container.Last); Container.Elements.EA (Container.Last);
begin begin
if EA = null then if EA = null then
raise Constraint_Error with "last element is empty"; raise Constraint_Error with "last element is empty";
end if; else
return EA.all; return EA.all;
end if;
end; end;
end Last_Element; end Last_Element;
...@@ -2903,36 +3022,30 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2903,36 +3022,30 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Index < Position.Container.Last then
if Position.Index < Position.Container.Last then
return (Position.Container, Position.Index + 1); return (Position.Container, Position.Index + 1);
end if; else
return No_Element; return No_Element;
end if;
end Next; end Next;
function Next (Object : Iterator; Position : Cursor) return Cursor is function Next (Object : Iterator; Position : Cursor) return Cursor is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Next designates wrong vector"; "Position cursor of Next designates wrong vector";
end if; else
return Next (Position); return Next (Position);
end if;
end Next; end Next;
procedure Next (Position : in out Cursor) is procedure Next (Position : in out Cursor) is
begin begin
if Position.Container = null then if Position.Container = null then
return; return;
end if; elsif Position.Index < Position.Container.Last then
if Position.Index < Position.Container.Last then
Position.Index := Position.Index + 1; Position.Index := Position.Index + 1;
else else
Position := No_Element; Position := No_Element;
...@@ -2954,10 +3067,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2954,10 +3067,7 @@ package body Ada.Containers.Indefinite_Vectors is
Count : Count_Type := 1) Count : Count_Type := 1)
is is
begin begin
Insert (Container, Insert (Container, Index_Type'First, New_Item, Count);
Index_Type'First,
New_Item,
Count);
end Prepend; end Prepend;
-------------- --------------
...@@ -2968,9 +3078,7 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2968,9 +3078,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return; return;
end if; elsif Position.Index > Index_Type'First then
if Position.Index > Index_Type'First then
Position.Index := Position.Index - 1; Position.Index := Position.Index - 1;
else else
Position := No_Element; Position := No_Element;
...@@ -2981,27 +3089,23 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2981,27 +3089,23 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Index > Index_Type'First then
if Position.Index > Index_Type'First then
return (Position.Container, Position.Index - 1); return (Position.Container, Position.Index - 1);
end if; else
return No_Element; return No_Element;
end if;
end Previous; end Previous;
function Previous (Object : Iterator; Position : Cursor) return Cursor is function Previous (Object : Iterator; Position : Cursor) return Cursor is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Previous designates wrong vector"; "Position cursor of Previous designates wrong vector";
end if; else
return Previous (Position); return Previous (Position);
end if;
end Previous; end Previous;
------------------- -------------------
...@@ -3049,9 +3153,9 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3049,9 +3153,9 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if; else
Query_Element (Position.Container.all, Position.Index, Process); Query_Element (Position.Container.all, Position.Index, Process);
end if;
end Query_Element; end Query_Element;
---------- ----------
...@@ -3064,7 +3168,6 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3064,7 +3168,6 @@ package body Ada.Containers.Indefinite_Vectors is
is is
Length : Count_Type'Base; Length : Count_Type'Base;
Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
B : Boolean; B : Boolean;
begin begin
...@@ -3616,23 +3719,50 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3616,23 +3719,50 @@ package body Ada.Containers.Indefinite_Vectors is
raise Program_Error with "Position cursor denotes wrong container"; raise Program_Error with "Position cursor denotes wrong container";
end if; end if;
if Position.Container = null if Position.Container = null or else Position.Index > Container.Last then
or else Position.Index > Container.Last
then
Last := Container.Last; Last := Container.Last;
else else
Last := Position.Index; Last := Position.Index;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) /= null if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item and then Container.Elements.EA (Indx).all = Item
then then
return (Container'Unrestricted_Access, Indx); Result := Indx;
exit;
end if; end if;
end loop; end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Reverse_Find; end Reverse_Find;
------------------------ ------------------------
...@@ -3644,18 +3774,41 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3644,18 +3774,41 @@ package body Ada.Containers.Indefinite_Vectors is
Item : Element_Type; Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index Index : Index_Type := Index_Type'Last) return Extended_Index
is is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Last : constant Index_Type'Base := Last : constant Index_Type'Base :=
(if Index > Container.Last then Container.Last else Index); (if Index > Container.Last then Container.Last else Index);
Result : Index_Type'Base;
begin begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) /= null if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item and then Container.Elements.EA (Indx).all = Item
then then
return Indx; Result := Indx;
exit;
end if; end if;
end loop; end loop;
return No_Index; B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Reverse_Find_Index; end Reverse_Find_Index;
--------------------- ---------------------
...@@ -3800,13 +3953,11 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -3800,13 +3953,11 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Index; return No_Index;
end if; elsif Position.Index <= Position.Container.Last then
if Position.Index <= Position.Container.Last then
return Position.Index; return Position.Index;
end if; else
return No_Index; return No_Index;
end if;
end To_Index; end To_Index;
--------------- ---------------
...@@ -4072,13 +4223,13 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -4072,13 +4223,13 @@ package body Ada.Containers.Indefinite_Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container"; raise Program_Error with "Position cursor denotes wrong container";
end if;
else
Update_Element (Container, Position.Index, Process); Update_Element (Container, Position.Index, Process);
end if;
end Update_Element; end Update_Element;
----------- -----------
......
gcc/ada/a-convec.adb
...@@ -86,10 +86,8 @@ package body Ada.Containers.Vectors is ...@@ -86,10 +86,8 @@ package body Ada.Containers.Vectors is
declare declare
RE : Elements_Array renames RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last); Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access := Elements : constant Elements_Access :=
new Elements_Type'(Right.Last, RE); new Elements_Type'(Right.Last, RE);
begin begin
return (Controlled with Elements, Right.Last, 0, 0); return (Controlled with Elements, Right.Last, 0, 0);
end; end;
...@@ -99,10 +97,8 @@ package body Ada.Containers.Vectors is ...@@ -99,10 +97,8 @@ package body Ada.Containers.Vectors is
declare declare
LE : Elements_Array renames LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last); Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : constant Elements_Access := Elements : constant Elements_Access :=
new Elements_Type'(Left.Last, LE); new Elements_Type'(Left.Last, LE);
begin begin
return (Controlled with Elements, Left.Last, 0, 0); return (Controlled with Elements, Left.Last, 0, 0);
end; end;
...@@ -199,13 +195,10 @@ package body Ada.Containers.Vectors is ...@@ -199,13 +195,10 @@ package body Ada.Containers.Vectors is
declare declare
LE : Elements_Array renames LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last); Left.Elements.EA (Index_Type'First .. Left.Last);
RE : Elements_Array renames RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last); Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access := Elements : constant Elements_Access :=
new Elements_Type'(Last, LE & RE); new Elements_Type'(Last, LE & RE);
begin begin
return (Controlled with Elements, Last, 0, 0); return (Controlled with Elements, Last, 0, 0);
end; end;
...@@ -248,13 +241,10 @@ package body Ada.Containers.Vectors is ...@@ -248,13 +241,10 @@ package body Ada.Containers.Vectors is
declare declare
Last : constant Index_Type := Left.Last + 1; Last : constant Index_Type := Left.Last + 1;
LE : Elements_Array renames LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last); Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : constant Elements_Access := Elements : constant Elements_Access :=
new Elements_Type'(Last => Last, EA => LE & Right); new Elements_Type'(Last => Last, EA => LE & Right);
begin begin
return (Controlled with Elements, Last, 0, 0); return (Controlled with Elements, Last, 0, 0);
end; end;
...@@ -275,7 +265,6 @@ package body Ada.Containers.Vectors is ...@@ -275,7 +265,6 @@ package body Ada.Containers.Vectors is
new Elements_Type' new Elements_Type'
(Last => Index_Type'First, (Last => Index_Type'First,
EA => (others => Left)); EA => (others => Left));
begin begin
return (Controlled with Elements, Index_Type'First, 0, 0); return (Controlled with Elements, Index_Type'First, 0, 0);
end; end;
...@@ -346,6 +335,14 @@ package body Ada.Containers.Vectors is ...@@ -346,6 +335,14 @@ package body Ada.Containers.Vectors is
--------- ---------
overriding function "=" (Left, Right : Vector) return Boolean is overriding function "=" (Left, Right : Vector) return Boolean is
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Result : Boolean;
begin begin
if Left'Address = Right'Address then if Left'Address = Right'Address then
return True; return True;
...@@ -355,13 +352,40 @@ package body Ada.Containers.Vectors is ...@@ -355,13 +352,40 @@ package body Ada.Containers.Vectors is
return False; return False;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
Result := True;
for J in Index_Type range Index_Type'First .. Left.Last loop for J in Index_Type range Index_Type'First .. Left.Last loop
if Left.Elements.EA (J) /= Right.Elements.EA (J) then if Left.Elements.EA (J) /= Right.Elements.EA (J) then
return False; Result := False;
exit;
end if; end if;
end loop; end loop;
return True; BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
return Result;
exception
when others =>
BL := BL - 1;
LL := LL - 1;
BR := BR - 1;
LR := LR - 1;
raise;
end "="; end "=";
------------ ------------
...@@ -418,16 +442,11 @@ package body Ada.Containers.Vectors is ...@@ -418,16 +442,11 @@ package body Ada.Containers.Vectors is
begin begin
if Is_Empty (New_Item) then if Is_Empty (New_Item) then
return; return;
end if; elsif Container.Last = Index_Type'Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length"; raise Constraint_Error with "vector is already at its maximum length";
else
Insert (Container, Container.Last + 1, New_Item);
end if; end if;
Insert
(Container,
Container.Last + 1,
New_Item);
end Append; end Append;
procedure Append procedure Append
...@@ -438,17 +457,11 @@ package body Ada.Containers.Vectors is ...@@ -438,17 +457,11 @@ package body Ada.Containers.Vectors is
begin begin
if Count = 0 then if Count = 0 then
return; return;
end if; elsif Container.Last = Index_Type'Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length"; raise Constraint_Error with "vector is already at its maximum length";
else
Insert (Container, Container.Last + 1, New_Item, Count);
end if; end if;
Insert
(Container,
Container.Last + 1,
New_Item,
Count);
end Append; end Append;
------------ ------------
...@@ -459,10 +472,10 @@ package body Ada.Containers.Vectors is ...@@ -459,10 +472,10 @@ package body Ada.Containers.Vectors is
begin begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
return; return;
end if; else
Target.Clear; Target.Clear;
Target.Append (Source); Target.Append (Source);
end if;
end Assign; end Assign;
-------------- --------------
...@@ -638,10 +651,10 @@ package body Ada.Containers.Vectors is ...@@ -638,10 +651,10 @@ package body Ada.Containers.Vectors is
if Index > Old_Last then if Index > Old_Last then
if Index > Old_Last + 1 then if Index > Old_Last + 1 then
raise Constraint_Error with "Index is out of range (too large)"; raise Constraint_Error with "Index is out of range (too large)";
end if; else
return; return;
end if; end if;
end if;
-- Here and elsewhere we treat deleting 0 items from the container as a -- Here and elsewhere we treat deleting 0 items from the container as a
-- no-op, even when the container is busy, so we simply return. -- no-op, even when the container is busy, so we simply return.
...@@ -668,7 +681,6 @@ package body Ada.Containers.Vectors is ...@@ -668,7 +681,6 @@ package body Ada.Containers.Vectors is
if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
else else
Count2 := Count_Type'Base (Old_Last - Index + 1); Count2 := Count_Type'Base (Old_Last - Index + 1);
end if; end if;
...@@ -694,7 +706,6 @@ package body Ada.Containers.Vectors is ...@@ -694,7 +706,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := Old_Last - Index_Type'Base (Count); New_Last := Old_Last - Index_Type'Base (Count);
J := Index + Index_Type'Base (Count); J := Index + Index_Type'Base (Count);
else else
New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
J := Index_Type'Base (Count_Type'Base (Index) + Count); J := Index_Type'Base (Count_Type'Base (Index) + Count);
...@@ -708,7 +719,6 @@ package body Ada.Containers.Vectors is ...@@ -708,7 +719,6 @@ package body Ada.Containers.Vectors is
declare declare
EA : Elements_Array renames Container.Elements.EA; EA : Elements_Array renames Container.Elements.EA;
begin begin
EA (Index .. New_Last) := EA (J .. Old_Last); EA (Index .. New_Last) := EA (J .. Old_Last);
Container.Last := New_Last; Container.Last := New_Last;
...@@ -725,18 +735,17 @@ package body Ada.Containers.Vectors is ...@@ -725,18 +735,17 @@ package body Ada.Containers.Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container"; raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Container.Last then elsif Position.Index > Container.Last then
raise Program_Error with "Position index is out of range"; raise Program_Error with "Position index is out of range";
end if;
else
Delete (Container, Position.Index, Count); Delete (Container, Position.Index, Count);
Position := No_Element; Position := No_Element;
end if;
end Delete; end Delete;
------------------ ------------------
...@@ -750,14 +759,14 @@ package body Ada.Containers.Vectors is ...@@ -750,14 +759,14 @@ package body Ada.Containers.Vectors is
begin begin
if Count = 0 then if Count = 0 then
return; return;
end if;
if Count >= Length (Container) then elsif Count >= Length (Container) then
Clear (Container); Clear (Container);
return; return;
end if;
else
Delete (Container, Index_Type'First, Count); Delete (Container, Index_Type'First, Count);
end if;
end Delete_First; end Delete_First;
----------------- -----------------
...@@ -823,9 +832,9 @@ package body Ada.Containers.Vectors is ...@@ -823,9 +832,9 @@ package body Ada.Containers.Vectors is
begin begin
if Index > Container.Last then if Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
end if; else
return Container.Elements.EA (Index); return Container.Elements.EA (Index);
end if;
end Element; end Element;
function Element (Position : Cursor) return Element_Type is function Element (Position : Cursor) return Element_Type is
...@@ -850,11 +859,12 @@ package body Ada.Containers.Vectors is ...@@ -850,11 +859,12 @@ package body Ada.Containers.Vectors is
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with cursors (vector is busy)"; "attempt to tamper with cursors (vector is busy)";
end if;
else
Container.Elements := null; Container.Elements := null;
Container.Last := No_Index; Container.Last := No_Index;
Free (X); Free (X);
end if;
end Finalize; end Finalize;
procedure Finalize (Object : in out Iterator) is procedure Finalize (Object : in out Iterator) is
...@@ -899,13 +909,42 @@ package body Ada.Containers.Vectors is ...@@ -899,13 +909,42 @@ package body Ada.Containers.Vectors is
end if; end if;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for J in Position.Index .. Container.Last loop for J in Position.Index .. Container.Last loop
if Container.Elements.EA (J) = Item then if Container.Elements.EA (J) = Item then
return (Container'Unrestricted_Access, J); Result := J;
exit;
end if; end if;
end loop; end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Find; end Find;
---------------- ----------------
...@@ -917,14 +956,36 @@ package body Ada.Containers.Vectors is ...@@ -917,14 +956,36 @@ package body Ada.Containers.Vectors is
Item : Element_Type; Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index Index : Index_Type := Index_Type'First) return Extended_Index
is is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in Index .. Container.Last loop for Indx in Index .. Container.Last loop
if Container.Elements.EA (Indx) = Item then if Container.Elements.EA (Indx) = Item then
return Indx; Result := Indx;
exit;
end if; end if;
end loop; end loop;
return No_Index; B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Find_Index; end Find_Index;
----------- -----------
...@@ -1002,17 +1063,40 @@ package body Ada.Containers.Vectors is ...@@ -1002,17 +1063,40 @@ package body Ada.Containers.Vectors is
return True; return True;
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare declare
EA : Elements_Array renames Container.Elements.EA; EA : Elements_Array renames Container.Elements.EA;
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Boolean;
begin begin
B := B + 1;
L := L + 1;
Result := True;
for J in Index_Type'First .. Container.Last - 1 loop for J in Index_Type'First .. Container.Last - 1 loop
if EA (J + 1) < EA (J) then if EA (J + 1) < EA (J) then
return False; Result := False;
exit;
end if; end if;
end loop; end loop;
end;
return True; B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Is_Sorted; end Is_Sorted;
----------- -----------
...@@ -1053,11 +1137,26 @@ package body Ada.Containers.Vectors is ...@@ -1053,11 +1137,26 @@ package body Ada.Containers.Vectors is
Target.Set_Length (Length (Target) + Length (Source)); Target.Set_Length (Length (Target) + Length (Source));
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare declare
TA : Elements_Array renames Target.Elements.EA; TA : Elements_Array renames Target.Elements.EA;
SA : Elements_Array renames Source.Elements.EA; SA : Elements_Array renames Source.Elements.EA;
TB : Natural renames Target.Busy;
TL : Natural renames Target.Lock;
SB : Natural renames Source.Busy;
SL : Natural renames Source.Lock;
begin begin
TB := TB + 1;
TL := TL + 1;
SB := SB + 1;
SL := SL + 1;
J := Target.Last; J := Target.Last;
while Source.Last >= Index_Type'First loop while Source.Last >= Index_Type'First loop
pragma Assert (Source.Last <= Index_Type'First pragma Assert (Source.Last <= Index_Type'First
...@@ -1069,7 +1168,7 @@ package body Ada.Containers.Vectors is ...@@ -1069,7 +1168,7 @@ package body Ada.Containers.Vectors is
SA (Index_Type'First .. Source.Last); SA (Index_Type'First .. Source.Last);
Source.Last := No_Index; Source.Last := No_Index;
return; exit;
end if; end if;
pragma Assert (I <= Index_Type'First pragma Assert (I <= Index_Type'First
...@@ -1086,6 +1185,22 @@ package body Ada.Containers.Vectors is ...@@ -1086,6 +1185,22 @@ package body Ada.Containers.Vectors is
J := J - 1; J := J - 1;
end loop; end loop;
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
exception
when others =>
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
raise;
end; end;
end Merge; end Merge;
...@@ -1122,7 +1237,28 @@ package body Ada.Containers.Vectors is ...@@ -1122,7 +1237,28 @@ package body Ada.Containers.Vectors is
"attempt to tamper with cursors (vector is busy)"; "attempt to tamper with cursors (vector is busy)";
end if; end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
B := B - 1;
L := L - 1;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Sort; end Sort;
end Generic_Sorting; end Generic_Sorting;
...@@ -1182,9 +1318,7 @@ package body Ada.Containers.Vectors is ...@@ -1182,9 +1318,7 @@ package body Ada.Containers.Vectors is
-- deeper flaw in the caller's algorithm, so that case is treated as a -- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.) -- proper error.)
if Before > Container.Last if Before > Container.Last and then Before > Container.Last + 1 then
and then Before > Container.Last + 1
then
raise Constraint_Error with raise Constraint_Error with
"Before index is out of range (too large)"; "Before index is out of range (too large)";
end if; end if;
...@@ -1374,7 +1508,6 @@ package body Ada.Containers.Vectors is ...@@ -1374,7 +1508,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count); Index := Before + Index_Type'Base (Count);
else else
Index := Index_Type'Base (Count_Type'Base (Before) + Count); Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if; end if;
...@@ -1402,9 +1535,9 @@ package body Ada.Containers.Vectors is ...@@ -1402,9 +1535,9 @@ package body Ada.Containers.Vectors is
if New_Capacity > Count_Type'Last / 2 then if New_Capacity > Count_Type'Last / 2 then
New_Capacity := Count_Type'Last; New_Capacity := Count_Type'Last;
exit; exit;
end if; else
New_Capacity := 2 * New_Capacity; New_Capacity := 2 * New_Capacity;
end if;
end loop; end loop;
if New_Capacity > Max_Length then if New_Capacity > Max_Length then
...@@ -1421,7 +1554,6 @@ package body Ada.Containers.Vectors is ...@@ -1421,7 +1554,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity); Dst_Last := No_Index + Index_Type'Base (New_Capacity);
else else
Dst_Last := Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
...@@ -1455,7 +1587,6 @@ package body Ada.Containers.Vectors is ...@@ -1455,7 +1587,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count); Index := Before + Index_Type'Base (Count);
else else
Index := Index_Type'Base (Count_Type'Base (Before) + Count); Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if; end if;
...@@ -1475,6 +1606,7 @@ package body Ada.Containers.Vectors is ...@@ -1475,6 +1606,7 @@ package body Ada.Containers.Vectors is
declare declare
X : Elements_Access := Container.Elements; X : Elements_Access := Container.Elements;
begin begin
-- We first isolate the old internal array, removing it from the -- We first isolate the old internal array, removing it from the
-- container and replacing it with the new internal array, before we -- container and replacing it with the new internal array, before we
...@@ -1518,7 +1650,6 @@ package body Ada.Containers.Vectors is ...@@ -1518,7 +1650,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
J := (Before - 1) + Index_Type'Base (N); J := (Before - 1) + Index_Type'Base (N);
else else
J := Index_Type'Base (Count_Type'Base (Before - 1) + N); J := Index_Type'Base (Count_Type'Base (Before - 1) + N);
end if; end if;
...@@ -1562,7 +1693,6 @@ package body Ada.Containers.Vectors is ...@@ -1562,7 +1693,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
K := L + Index_Type'Base (Src'Length); K := L + Index_Type'Base (Src'Length);
else else
K := Index_Type'Base (Count_Type'Base (L) + Src'Length); K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
end if; end if;
...@@ -1606,7 +1736,6 @@ package body Ada.Containers.Vectors is ...@@ -1606,7 +1736,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
K := F - Index_Type'Base (Src'Length); K := F - Index_Type'Base (Src'Length);
else else
K := Index_Type'Base (Count_Type'Base (F) - Src'Length); K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
end if; end if;
...@@ -1633,9 +1762,7 @@ package body Ada.Containers.Vectors is ...@@ -1633,9 +1762,7 @@ package body Ada.Containers.Vectors is
return; return;
end if; end if;
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
if Container.Last = Index_Type'Last then if Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
...@@ -1666,9 +1793,7 @@ package body Ada.Containers.Vectors is ...@@ -1666,9 +1793,7 @@ package body Ada.Containers.Vectors is
end if; end if;
if Is_Empty (New_Item) then if Is_Empty (New_Item) then
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
Position := No_Element; Position := No_Element;
else else
Position := (Container'Unrestricted_Access, Before.Index); Position := (Container'Unrestricted_Access, Before.Index);
...@@ -1677,9 +1802,7 @@ package body Ada.Containers.Vectors is ...@@ -1677,9 +1802,7 @@ package body Ada.Containers.Vectors is
return; return;
end if; end if;
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
if Container.Last = Index_Type'Last then if Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
...@@ -1715,9 +1838,7 @@ package body Ada.Containers.Vectors is ...@@ -1715,9 +1838,7 @@ package body Ada.Containers.Vectors is
return; return;
end if; end if;
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
if Container.Last = Index_Type'Last then if Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
...@@ -1749,9 +1870,7 @@ package body Ada.Containers.Vectors is ...@@ -1749,9 +1870,7 @@ package body Ada.Containers.Vectors is
end if; end if;
if Count = 0 then if Count = 0 then
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
Position := No_Element; Position := No_Element;
else else
Position := (Container'Unrestricted_Access, Before.Index); Position := (Container'Unrestricted_Access, Before.Index);
...@@ -1760,9 +1879,7 @@ package body Ada.Containers.Vectors is ...@@ -1760,9 +1879,7 @@ package body Ada.Containers.Vectors is
return; return;
end if; end if;
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
if Container.Last = Index_Type'Last then if Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
...@@ -1799,7 +1916,6 @@ package body Ada.Containers.Vectors is ...@@ -1799,7 +1916,6 @@ package body Ada.Containers.Vectors is
is is
New_Item : Element_Type; -- Default-initialized value New_Item : Element_Type; -- Default-initialized value
pragma Warnings (Off, New_Item); pragma Warnings (Off, New_Item);
begin begin
Insert (Container, Before, New_Item, Position, Count); Insert (Container, Before, New_Item, Position, Count);
end Insert; end Insert;
...@@ -1849,9 +1965,7 @@ package body Ada.Containers.Vectors is ...@@ -1849,9 +1965,7 @@ package body Ada.Containers.Vectors is
-- deeper flaw in the caller's algorithm, so that case is treated as a -- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.) -- proper error.)
if Before > Container.Last if Before > Container.Last and then Before > Container.Last + 1 then
and then Before > Container.Last + 1
then
raise Constraint_Error with raise Constraint_Error with
"Before index is out of range (too large)"; "Before index is out of range (too large)";
end if; end if;
...@@ -1973,7 +2087,6 @@ package body Ada.Containers.Vectors is ...@@ -1973,7 +2087,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := No_Index + Index_Type'Base (New_Length); New_Last := No_Index + Index_Type'Base (New_Length);
else else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
end if; end if;
...@@ -2081,7 +2194,6 @@ package body Ada.Containers.Vectors is ...@@ -2081,7 +2194,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity); Dst_Last := No_Index + Index_Type'Base (New_Capacity);
else else
Dst_Last := Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
...@@ -2113,7 +2225,6 @@ package body Ada.Containers.Vectors is ...@@ -2113,7 +2225,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count); Index := Before + Index_Type'Base (Count);
else else
Index := Index_Type'Base (Count_Type'Base (Before) + Count); Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if; end if;
...@@ -2166,9 +2277,7 @@ package body Ada.Containers.Vectors is ...@@ -2166,9 +2277,7 @@ package body Ada.Containers.Vectors is
end if; end if;
if Count = 0 then if Count = 0 then
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
Position := No_Element; Position := No_Element;
else else
Position := (Container'Unrestricted_Access, Before.Index); Position := (Container'Unrestricted_Access, Before.Index);
...@@ -2177,9 +2286,7 @@ package body Ada.Containers.Vectors is ...@@ -2177,9 +2286,7 @@ package body Ada.Containers.Vectors is
return; return;
end if; end if;
if Before.Container = null if Before.Container = null or else Before.Index > Container.Last then
or else Before.Index > Container.Last
then
if Container.Last = Index_Type'Last then if Container.Last = Index_Type'Last then
raise Constraint_Error with raise Constraint_Error with
"vector is already at its maximum length"; "vector is already at its maximum length";
...@@ -2455,14 +2562,12 @@ package body Ada.Containers.Vectors is ...@@ -2455,14 +2562,12 @@ package body Ada.Containers.Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Next designates wrong vector"; "Position cursor of Next designates wrong vector";
end if; else
return Next (Position); return Next (Position);
end if;
end Next; end Next;
procedure Next (Position : in out Cursor) is procedure Next (Position : in out Cursor) is
...@@ -2491,10 +2596,7 @@ package body Ada.Containers.Vectors is ...@@ -2491,10 +2596,7 @@ package body Ada.Containers.Vectors is
Count : Count_Type := 1) Count : Count_Type := 1)
is is
begin begin
Insert (Container, Insert (Container, Index_Type'First, New_Item, Count);
Index_Type'First,
New_Item,
Count);
end Prepend; end Prepend;
-------------- --------------
...@@ -2516,14 +2618,12 @@ package body Ada.Containers.Vectors is ...@@ -2516,14 +2618,12 @@ package body Ada.Containers.Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
end if; elsif Position.Container /= Object.Container then
if Position.Container /= Object.Container then
raise Program_Error with raise Program_Error with
"Position cursor of Previous designates wrong vector"; "Position cursor of Previous designates wrong vector";
end if; else
return Previous (Position); return Previous (Position);
end if;
end Previous; end Previous;
procedure Previous (Position : in out Cursor) is procedure Previous (Position : in out Cursor) is
...@@ -2578,9 +2678,9 @@ package body Ada.Containers.Vectors is ...@@ -2578,9 +2678,9 @@ package body Ada.Containers.Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if; else
Query_Element (Position.Container.all, Position.Index, Process); Query_Element (Position.Container.all, Position.Index, Process);
end if;
end Query_Element; end Query_Element;
---------- ----------
...@@ -2677,6 +2777,7 @@ package body Ada.Containers.Vectors is ...@@ -2677,6 +2777,7 @@ package body Ada.Containers.Vectors is
begin begin
if Index > Container.Last then if Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
else else
declare declare
C : Vector renames Container'Unrestricted_Access.all; C : Vector renames Container'Unrestricted_Access.all;
...@@ -2706,14 +2807,12 @@ package body Ada.Containers.Vectors is ...@@ -2706,14 +2807,12 @@ package body Ada.Containers.Vectors is
begin begin
if Index > Container.Last then if Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
end if; elsif Container.Lock > 0 then
if Container.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (vector is locked)"; "attempt to tamper with elements (vector is locked)";
end if; else
Container.Elements.EA (Index) := New_Item; Container.Elements.EA (Index) := New_Item;
end if;
end Replace_Element; end Replace_Element;
procedure Replace_Element procedure Replace_Element
...@@ -2724,22 +2823,21 @@ package body Ada.Containers.Vectors is ...@@ -2724,22 +2823,21 @@ package body Ada.Containers.Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container"; raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Container.Last then elsif Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range"; raise Constraint_Error with "Position cursor is out of range";
end if;
else
if Container.Lock > 0 then if Container.Lock > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (vector is locked)"; "attempt to tamper with elements (vector is locked)";
end if; end if;
Container.Elements.EA (Position.Index) := New_Item; Container.Elements.EA (Position.Index) := New_Item;
end if;
end Replace_Element; end Replace_Element;
---------------------- ----------------------
...@@ -3126,13 +3224,42 @@ package body Ada.Containers.Vectors is ...@@ -3126,13 +3224,42 @@ package body Ada.Containers.Vectors is
then Container.Last then Container.Last
else Position.Index); else Position.Index);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) = Item then if Container.Elements.EA (Indx) = Item then
return (Container'Unrestricted_Access, Indx); Result := Indx;
exit;
end if; end if;
end loop; end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element; return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Reverse_Find; end Reverse_Find;
------------------------ ------------------------
...@@ -3144,17 +3271,39 @@ package body Ada.Containers.Vectors is ...@@ -3144,17 +3271,39 @@ package body Ada.Containers.Vectors is
Item : Element_Type; Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index Index : Index_Type := Index_Type'Last) return Extended_Index
is is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Last : constant Index_Type'Base := Last : constant Index_Type'Base :=
Index_Type'Min (Container.Last, Index); Index_Type'Min (Container.Last, Index);
Result : Index_Type'Base;
begin begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) = Item then if Container.Elements.EA (Indx) = Item then
return Indx; Result := Indx;
exit;
end if; end if;
end loop; end loop;
return No_Index; B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Reverse_Find_Index; end Reverse_Find_Index;
--------------------- ---------------------
...@@ -3245,21 +3394,19 @@ package body Ada.Containers.Vectors is ...@@ -3245,21 +3394,19 @@ package body Ada.Containers.Vectors is
begin begin
if I.Container = null then if I.Container = null then
raise Constraint_Error with "I cursor has no element"; raise Constraint_Error with "I cursor has no element";
end if;
if J.Container = null then elsif J.Container = null then
raise Constraint_Error with "J cursor has no element"; raise Constraint_Error with "J cursor has no element";
end if;
if I.Container /= Container'Unrestricted_Access then elsif I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor denotes wrong container"; raise Program_Error with "I cursor denotes wrong container";
end if;
if J.Container /= Container'Unrestricted_Access then elsif J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor denotes wrong container"; raise Program_Error with "J cursor denotes wrong container";
end if;
else
Swap (Container, I.Index, J.Index); Swap (Container, I.Index, J.Index);
end if;
end Swap; end Swap;
--------------- ---------------
...@@ -3286,13 +3433,11 @@ package body Ada.Containers.Vectors is ...@@ -3286,13 +3433,11 @@ package body Ada.Containers.Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Index; return No_Index;
end if; elsif Position.Index <= Position.Container.Last then
if Position.Index <= Position.Container.Last then
return Position.Index; return Position.Index;
end if; else
return No_Index; return No_Index;
end if;
end To_Index; end To_Index;
--------------- ---------------
......
gcc/ada/stand.ads
...@@ -364,23 +364,21 @@ package Stand is ...@@ -364,23 +364,21 @@ package Stand is
Any_Type : Entity_Id; Any_Type : Entity_Id;
-- Used to represent some unknown type. Any_Type is the type of an -- Used to represent some unknown type. Any_Type is the type of an
-- unresolved operator, and it is the type of a node where a type error -- unresolved operator, and it is the type of a node where a type error
-- has been detected. Any_Type plays an important role in avoiding -- has been detected. Any_Type plays an important role in avoiding cascaded
-- cascaded errors, because it is compatible with all other types, and is -- errors, because it is compatible with all other types, and is propagated
-- propagated to any expression that has a subexpression of Any_Type. -- to any expression that has a subexpression of Any_Type. When resolving
-- When resolving operators, Any_Type is the initial type of the node -- operators, Any_Type is the initial type of the node before any of its
-- before any of its candidate interpretations has been examined. If after -- candidate interpretations has been examined. If after examining all of
-- examining all of them the type is still Any_Type, the node has no -- them the type is still Any_Type, the node has no possible interpretation
-- possible interpretation and an error can be emitted (and Any_Type will -- and an error can be emitted (and Any_Type will be propagated upwards).
-- be propagated upwards). --
-- There is one situation in which Any_Type is used to legitimately -- There is one situation in which Any_Type is used to legitimately
-- represent a case where the type is not known pre-resolution, and -- represent a case where the type is not known pre-resolution, and that
-- that is for the N_Raise_Expression node. In this case, the Etype -- is for the N_Raise_Expression node. In this case, the Etype being set to
-- being set to Any_Type is normal and does not represent an error. -- Any_Type is normal and does not represent an error. In particular, it is
-- In particular, it is compatible with the type of any constituend of -- compatible with the type of any constituent of the enclosing expression,
-- the enclosing expression, if any. The type is eventually replaced -- if any. The type is eventually replaced with the type of the context,
-- with the type of the context, which plays no role in the resolution -- which plays no role in the resolution of the Raise_Expression.
-- of the Raise_Expression.
Any_Access : Entity_Id; Any_Access : Entity_Id;
-- Used to resolve the overloaded literal NULL -- Used to resolve the overloaded literal NULL
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment