summaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2013-04-11 10:41:49 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2013-04-11 10:41:49 +0000
commitc504f070db1b70e627eaf2b7b3445eb34e097f6e (patch)
tree069c1a85b564c4049f489530114e91480b59b401 /gcc
parent4c2bf58d1efb4964570d7bed246e389a52095527 (diff)
downloadgcc-c504f070db1b70e627eaf2b7b3445eb34e097f6e.tar.gz
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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@197765 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/ChangeLog12
-rw-r--r--gcc/ada/a-cobove.adb376
-rw-r--r--gcc/ada/a-coinve.adb603
-rw-r--r--gcc/ada/a-convec.adb515
-rw-r--r--gcc/ada/stand.ads30
5 files changed, 1022 insertions, 514 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 238de707031..3582e9f35bb 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,17 @@
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_util.adb (Insert_Actions): Add entry for N_Raise_Expression.
* expander.adb: Add call to Expand_N_Raise_Expression.
diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb
index 8ca958f0b71..01755cfd80f 100644
--- a/gcc/ada/a-cobove.adb
+++ b/gcc/ada/a-cobove.adb
@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -112,8 +112,8 @@ package body Ada.Containers.Bounded_Vectors is
raise Constraint_Error with "new length is out of range";
end if;
- -- It is now safe compute the length of the new vector, without fear of
- -- overflow.
+ -- It is now safe to compute the length of the new vector, without fear
+ -- of overflow.
N := LN + RN;
@@ -122,6 +122,7 @@ package body Ada.Containers.Bounded_Vectors is
-- Count_Type'Base as the type for intermediate values.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
+
-- We perform a two-part test. First we determine whether the
-- 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.
@@ -150,6 +151,7 @@ package body Ada.Containers.Bounded_Vectors is
end if;
elsif Index_Type'First <= 0 then
+
-- 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
-- adding the (positive) value of length.
@@ -280,6 +282,14 @@ package body Ada.Containers.Bounded_Vectors 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
if Left'Address = Right'Address then
return True;
@@ -289,13 +299,40 @@ package body Ada.Containers.Bounded_Vectors is
return False;
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
if Left.Elements (J) /= Right.Elements (J) then
- return False;
+ Result := False;
+ exit;
end if;
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 "=";
------------
@@ -543,7 +580,6 @@ package body Ada.Containers.Bounded_Vectors is
if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
-
else
Count2 := Count_Type'Base (Old_Last - Index + 1);
end if;
@@ -567,7 +603,6 @@ package body Ada.Containers.Bounded_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Off := Count_Type'Base (Index - Index_Type'First);
New_Last := Old_Last - Index_Type'Base (Count);
-
else
Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
@@ -579,7 +614,6 @@ package body Ada.Containers.Bounded_Vectors is
declare
EA : Elements_Array renames Container.Elements;
Idx : constant Count_Type := EA'First + Off;
-
begin
EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
Container.Last := New_Last;
@@ -621,14 +655,14 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Count = 0 then
return;
- end if;
- if Count >= Length (Container) then
+ elsif Count >= Length (Container) then
Clear (Container);
return;
- end if;
- Delete (Container, Index_Type'First, Count);
+ else
+ Delete (Container, Index_Type'First, Count);
+ end if;
end Delete_First;
-----------------
@@ -738,13 +772,42 @@ package body Ada.Containers.Bounded_Vectors is
end if;
end if;
- for J in Position.Index .. Container.Last loop
- if Container.Elements (To_Array_Index (J)) = Item then
- return (Container'Unrestricted_Access, J);
+ -- 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
+ if Container.Elements (To_Array_Index (J)) = Item then
+ Result := J;
+ exit;
+ end if;
+ end loop;
+
+ B := B - 1;
+ L := L - 1;
+
+ if Result = No_Index then
+ return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Result);
end if;
- end loop;
- return No_Element;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Find;
----------------
@@ -756,14 +819,36 @@ package body Ada.Containers.Bounded_Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index
is
+ B : Natural renames Container'Unrestricted_Access.Busy;
+ L : Natural renames Container'Unrestricted_Access.Lock;
+
+ Result : Index_Type'Base;
+
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
if Container.Elements (To_Array_Index (Indx)) = Item then
- return Indx;
+ Result := Indx;
+ exit;
end if;
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;
-----------
@@ -841,17 +926,40 @@ package body Ada.Containers.Bounded_Vectors is
return True;
end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
declare
EA : Elements_Array renames Container.Elements;
+
+ B : Natural renames Container'Unrestricted_Access.Busy;
+ L : Natural renames Container'Unrestricted_Access.Lock;
+
+ Result : Boolean;
+
begin
+ B := B + 1;
+ L := L + 1;
+
+ Result := True;
for J in 1 .. Container.Length - 1 loop
if EA (J + 1) < EA (J) then
- return False;
+ Result := False;
+ exit;
end if;
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;
-----------
@@ -862,7 +970,6 @@ package body Ada.Containers.Bounded_Vectors is
I, J : Count_Type;
begin
-
-- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did
@@ -893,21 +1000,35 @@ package body Ada.Containers.Bounded_Vectors is
I := Target.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
TA : Elements_Array renames Target.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
+ TB := TB + 1;
+ TL := TL + 1;
+
+ SB := SB + 1;
+ SL := SL + 1;
+
J := Target.Length;
while not Source.Is_Empty loop
pragma Assert (Source.Length <= 1
- or else not (SA (Source.Length) <
- SA (Source.Length - 1)));
+ or else not (SA (Source.Length) < SA (Source.Length - 1)));
if I = 0 then
TA (1 .. J) := SA (1 .. Source.Length);
Source.Last := No_Index;
- return;
+ exit;
end if;
pragma Assert (I <= 1
@@ -924,6 +1045,22 @@ package body Ada.Containers.Bounded_Vectors is
J := J - 1;
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;
@@ -960,7 +1097,28 @@ package body Ada.Containers.Bounded_Vectors is
"attempt to tamper with cursors (vector is busy)";
end if;
- Sort (Container.Elements (1 .. Container.Length));
+ -- 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));
+
+ B := B - 1;
+ L := L - 1;
+
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Sort;
end Generic_Sorting;
@@ -1056,10 +1214,12 @@ package body Ada.Containers.Bounded_Vectors is
-- acceptable, then we compute the new last index from that.
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
-- range of Index_Type than in the range of Count_Type.
if Index_Type'First <= 0 then
+
-- 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 overflow.
@@ -1067,6 +1227,7 @@ package body Ada.Containers.Bounded_Vectors is
Index := No_Index + Index_Type'Base (Count_Type'Last);
if Index <= Index_Type'Last then
+
-- 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 number of items that are allowed.
@@ -1091,6 +1252,7 @@ package body Ada.Containers.Bounded_Vectors is
end if;
elsif Index_Type'First <= 0 then
+
-- 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
-- overflow.
@@ -1098,6 +1260,7 @@ package body Ada.Containers.Bounded_Vectors is
J := Count_Type'Base (No_Index) + Count_Type'Last;
if J <= Count_Type'Base (Index_Type'Last) then
+
-- 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
-- number of items that are allowed.
@@ -1151,6 +1314,7 @@ package body Ada.Containers.Bounded_Vectors is
J := To_Array_Index (Before);
if Before > Container.Last then
+
-- The new items are being appended to the vector, so no
-- sliding of existing elements is required.
@@ -1508,10 +1672,12 @@ package body Ada.Containers.Bounded_Vectors is
-- acceptable, then we compute the new last index from that.
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
-- range of Index_Type than in the range of Count_Type.
if Index_Type'First <= 0 then
+
-- 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 overflow.
@@ -1519,6 +1685,7 @@ package body Ada.Containers.Bounded_Vectors is
Index := No_Index + Index_Type'Base (Count_Type'Last);
if Index <= Index_Type'Last then
+
-- 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 number of items that are allowed.
@@ -1543,6 +1710,7 @@ package body Ada.Containers.Bounded_Vectors is
end if;
elsif Index_Type'First <= 0 then
+
-- 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
-- overflow.
@@ -1550,6 +1718,7 @@ package body Ada.Containers.Bounded_Vectors is
J := Count_Type'Base (No_Index) + Count_Type'Last;
if J <= Count_Type'Base (Index_Type'Last) then
+
-- 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
-- number of items that are allowed.
@@ -1608,6 +1777,7 @@ package body Ada.Containers.Bounded_Vectors is
-- unused storage for the new items.
if Before <= Container.Last then
+
-- The space is being inserted before some existing elements,
-- so we must slide the existing elements up to their new home.
@@ -1927,36 +2097,30 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Position.Container = null then
return No_Element;
- end if;
-
- if Position.Index < Position.Container.Last then
+ elsif Position.Index < Position.Container.Last then
return (Position.Container, Position.Index + 1);
+ else
+ return No_Element;
end if;
-
- return No_Element;
end Next;
function Next (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.Container = null then
return No_Element;
- end if;
-
- if Position.Container /= Object.Container then
+ elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong vector";
+ else
+ return Next (Position);
end if;
-
- return Next (Position);
end Next;
procedure Next (Position : in out Cursor) is
begin
if Position.Container = null then
return;
- end if;
-
- if Position.Index < Position.Container.Last then
+ elsif Position.Index < Position.Container.Last then
Position.Index := Position.Index + 1;
else
Position := No_Element;
@@ -1992,9 +2156,7 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Position.Container = null then
return;
- end if;
-
- if Position.Index > Index_Type'First then
+ elsif Position.Index > Index_Type'First then
Position.Index := Position.Index - 1;
else
Position := No_Element;
@@ -2005,27 +2167,23 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Position.Container = null then
return No_Element;
- end if;
-
- if Position.Index > Index_Type'First then
+ elsif Position.Index > Index_Type'First then
return (Position.Container, Position.Index - 1);
+ else
+ return No_Element;
end if;
-
- return No_Element;
end Previous;
function Previous (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.Container = null then
return No_Element;
- end if;
-
- if Position.Container /= Object.Container then
+ elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong vector";
+ else
+ return Previous (Position);
end if;
-
- return Previous (Position);
end Previous;
-------------------
@@ -2069,9 +2227,9 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
+ else
+ Query_Element (Position.Container.all, Position.Index, Process);
end if;
-
- Query_Element (Position.Container.all, Position.Index, Process);
end Query_Element;
----------
@@ -2146,9 +2304,9 @@ package body Ada.Containers.Bounded_Vectors is
declare
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
- return (Element => A (I)'Access);
+ return (Element => A (J)'Access);
end;
end Reference;
@@ -2163,9 +2321,9 @@ package body Ada.Containers.Bounded_Vectors is
declare
A : Elements_Array renames Container.Elements;
- I : constant Count_Type := To_Array_Index (Index);
+ J : constant Count_Type := To_Array_Index (Index);
begin
- return (Element => A (I)'Access);
+ return (Element => A (J)'Access);
end;
end Reference;
@@ -2181,14 +2339,12 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
- end if;
-
- if Container.Lock > 0 then
+ elsif Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
+ else
+ Container.Elements (To_Array_Index (Index)) := New_Item;
end if;
-
- Container.Elements (To_Array_Index (Index)) := New_Item;
end Replace_Element;
procedure Replace_Element
@@ -2199,22 +2355,20 @@ package body Ada.Containers.Bounded_Vectors is
begin
if Position.Container = null then
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";
- end if;
- if Position.Index > Container.Last then
+ elsif Position.Index > Container.Last then
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
"attempt to tamper with elements (vector is locked)";
- end if;
- Container.Elements (To_Array_Index (Position.Index)) := New_Item;
+ else
+ Container.Elements (To_Array_Index (Position.Index)) := New_Item;
+ end if;
end Replace_Element;
----------------------
@@ -2300,13 +2454,41 @@ package body Ada.Containers.Bounded_Vectors is
then Container.Last
else Position.Index);
- for Indx in reverse Index_Type'First .. Last loop
- if Container.Elements (To_Array_Index (Indx)) = Item then
- return (Container'Unrestricted_Access, Indx);
- end if;
- end loop;
+ -- 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
+ if Container.Elements (To_Array_Index (Indx)) = Item then
+ Result := Indx;
+ exit;
+ end if;
+ end loop;
+
+ B := B - 1;
+ L := L - 1;
- return No_Element;
+ if Result = No_Index then
+ 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;
------------------------
@@ -2318,17 +2500,39 @@ package body Ada.Containers.Bounded_Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index
is
+ B : Natural renames Container'Unrestricted_Access.Busy;
+ L : Natural renames Container'Unrestricted_Access.Lock;
+
Last : constant Index_Type'Base :=
Index_Type'Min (Container.Last, Index);
+ Result : Index_Type'Base;
+
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
if Container.Elements (To_Array_Index (Indx)) = Item then
- return Indx;
+ Result := Indx;
+ exit;
end if;
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;
---------------------
@@ -2375,10 +2579,8 @@ package body Ada.Containers.Bounded_Vectors is
if Count >= 0 then
Container.Delete_Last (Count);
-
elsif Container.Last >= Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
-
else
Container.Insert_Space (Container.Last + 1, -Count);
end if;
@@ -2451,11 +2653,11 @@ package body Ada.Containers.Bounded_Vectors is
-- hence we also know that
-- Index - Index_Type'First >= 0
- -- The issue is that even though 0 is guaranteed to be a value
- -- in the type Index_Type'Base, there's no guarantee that the
- -- difference is a value in that type. To prevent overflow we
- -- use the wider of Count_Type'Base and Index_Type'Base to
- -- perform intermediate calculations.
+ -- The issue is that even though 0 is guaranteed to be a value in
+ -- the type Index_Type'Base, there's no guarantee that the difference
+ -- is a value in that type. To prevent overflow we use the wider
+ -- of Count_Type'Base and Index_Type'Base to perform intermediate
+ -- calculations.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Offset := Count_Type'Base (Index - Index_Type'First);
diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb
index 5b59c019da5..d63ebc07500 100644
--- a/gcc/ada/a-coinve.adb
+++ b/gcc/ada/a-coinve.adb
@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -117,7 +117,6 @@ package body Ada.Containers.Indefinite_Vectors is
return (Controlled with Elements, Right.Last, 0, 0);
end;
-
end if;
if RN = 0 then
@@ -243,7 +242,6 @@ package body Ada.Containers.Indefinite_Vectors is
declare
LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last);
-
RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last);
@@ -514,6 +512,14 @@ package body Ada.Containers.Indefinite_Vectors 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
if Left'Address = Right'Address then
return True;
@@ -523,21 +529,49 @@ package body Ada.Containers.Indefinite_Vectors is
return False;
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
if Left.Elements.EA (J) = null then
if Right.Elements.EA (J) /= null then
- return False;
+ Result := False;
+ exit;
end if;
elsif Right.Elements.EA (J) = null then
- return False;
+ Result := False;
+ exit;
elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
- return False;
+ Result := False;
+ exit;
end if;
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 "=";
------------
@@ -564,12 +598,12 @@ package body Ada.Containers.Indefinite_Vectors is
Container.Elements := new Elements_Type (L);
- for I in E'Range loop
- if E (I) /= null then
- Container.Elements.EA (I) := new Element_Type'(E (I).all);
+ for J in E'Range loop
+ if E (J) /= null then
+ Container.Elements.EA (J) := new Element_Type'(E (J).all);
end if;
- Container.Last := I;
+ Container.Last := J;
end loop;
end;
end Adjust;
@@ -596,16 +630,11 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Is_Empty (New_Item) then
return;
- end if;
-
- if Container.Last = Index_Type'Last then
+ elsif Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
+ else
+ Insert (Container, Container.Last + 1, New_Item);
end if;
-
- Insert
- (Container,
- Container.Last + 1,
- New_Item);
end Append;
procedure Append
@@ -616,17 +645,11 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Count = 0 then
return;
- end if;
-
- if Container.Last = Index_Type'Last then
+ elsif Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
+ else
+ Insert (Container, Container.Last + 1, New_Item, Count);
end if;
-
- Insert
- (Container,
- Container.Last + 1,
- New_Item,
- Count);
end Append;
------------
@@ -637,10 +660,10 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Target'Address = Source'Address then
return;
+ else
+ Target.Clear;
+ Target.Append (Source);
end if;
-
- Target.Clear;
- Target.Append (Source);
end Assign;
--------------
@@ -651,9 +674,9 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Container.Elements = null then
return 0;
+ else
+ return Container.Elements.EA'Length;
end if;
-
- return Container.Elements.EA'Length;
end Capacity;
-----------
@@ -665,17 +688,18 @@ package body Ada.Containers.Indefinite_Vectors is
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
- end if;
- while Container.Last >= Index_Type'First loop
- declare
- X : Element_Access := Container.Elements.EA (Container.Last);
- begin
- Container.Elements.EA (Container.Last) := null;
- Container.Last := Container.Last - 1;
- Free (X);
- end;
- end loop;
+ else
+ while Container.Last >= Index_Type'First loop
+ declare
+ X : Element_Access := Container.Elements.EA (Container.Last);
+ begin
+ Container.Elements.EA (Container.Last) := null;
+ Container.Last := Container.Last - 1;
+ Free (X);
+ end;
+ end loop;
+ end if;
end Clear;
------------------------
@@ -840,9 +864,9 @@ package body Ada.Containers.Indefinite_Vectors is
if Index > Old_Last then
if Index > Old_Last + 1 then
raise Constraint_Error with "Index is out of range (too large)";
+ else
+ return;
end if;
-
- return;
end if;
-- Here and elsewhere we treat deleting 0 items from the container as a
@@ -934,7 +958,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := Old_Last - Index_Type'Base (Count);
J := Index + Index_Type'Base (Count);
-
else
New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
J := Index_Type'Base (Count_Type'Base (Index) + Count);
@@ -987,19 +1010,17 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
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";
- end if;
- if Position.Index > Container.Last then
+ elsif Position.Index > Container.Last then
raise Program_Error with "Position index is out of range";
- end if;
-
- Delete (Container, Position.Index, Count);
- Position := No_Element;
+ else
+ Delete (Container, Position.Index, Count);
+ Position := No_Element;
+ end if;
end Delete;
------------------
@@ -1013,14 +1034,14 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Count = 0 then
return;
- end if;
- if Count >= Length (Container) then
+ elsif Count >= Length (Container) then
Clear (Container);
return;
- end if;
- Delete (Container, Index_Type'First, Count);
+ else
+ Delete (Container, Index_Type'First, Count);
+ end if;
end Delete_First;
-----------------
@@ -1110,13 +1131,12 @@ package body Ada.Containers.Indefinite_Vectors is
declare
EA : constant Element_Access := Container.Elements.EA (Index);
-
begin
if EA = null then
raise Constraint_Error with "element is empty";
+ else
+ return EA.all;
end if;
-
- return EA.all;
end;
end Element;
@@ -1132,14 +1152,13 @@ package body Ada.Containers.Indefinite_Vectors is
declare
EA : constant Element_Access :=
- Position.Container.Elements.EA (Position.Index);
-
+ Position.Container.Elements.EA (Position.Index);
begin
if EA = null then
raise Constraint_Error with "element is empty";
+ else
+ return EA.all;
end if;
-
- return EA.all;
end;
end Element;
@@ -1201,15 +1220,44 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
end if;
- for J in Position.Index .. Container.Last loop
- if Container.Elements.EA (J) /= null
- and then Container.Elements.EA (J).all = Item
- then
- return (Container'Unrestricted_Access, J);
+ -- 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
+ if Container.Elements.EA (J) /= null
+ and then Container.Elements.EA (J).all = Item
+ then
+ Result := J;
+ exit;
+ end if;
+ end loop;
+
+ B := B - 1;
+ L := L - 1;
+
+ if Result = No_Index then
+ return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Result);
end if;
- end loop;
- return No_Element;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Find;
----------------
@@ -1221,16 +1269,38 @@ package body Ada.Containers.Indefinite_Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index
is
+ B : Natural renames Container'Unrestricted_Access.Busy;
+ L : Natural renames Container'Unrestricted_Access.Lock;
+
+ Result : Index_Type'Base;
+
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
if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item
then
- return Indx;
+ Result := Indx;
+ exit;
end if;
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;
-----------
@@ -1281,14 +1351,13 @@ package body Ada.Containers.Indefinite_Vectors is
declare
EA : constant Element_Access :=
- Container.Elements.EA (Index_Type'First);
-
+ Container.Elements.EA (Index_Type'First);
begin
if EA = null then
raise Constraint_Error with "first element is empty";
+ else
+ return EA.all;
end if;
-
- return EA.all;
end;
end First_Element;
@@ -1340,17 +1409,40 @@ package body Ada.Containers.Indefinite_Vectors is
return True;
end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
declare
E : Elements_Array renames Container.Elements.EA;
+
+ B : Natural renames Container'Unrestricted_Access.Busy;
+ L : Natural renames Container'Unrestricted_Access.Lock;
+
+ Result : Boolean;
+
begin
+ B := B + 1;
+ L := L + 1;
+
+ Result := True;
for I in Index_Type'First .. Container.Last - 1 loop
if Is_Less (E (I + 1), E (I)) then
- return False;
+ Result := False;
+ exit;
end if;
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;
-----------
@@ -1361,7 +1453,6 @@ package body Ada.Containers.Indefinite_Vectors is
I, J : Index_Type'Base;
begin
-
-- The semantics of Merge changed slightly per AI05-0021. It was
-- originally the case that if Target and Source denoted the same
-- container object, then the GNAT implementation of Merge did
@@ -1392,53 +1483,86 @@ package body Ada.Containers.Indefinite_Vectors is
I := Target.Last; -- original value (before Set_Length)
Target.Set_Length (Length (Target) + Length (Source));
- J := Target.Last; -- new value (after Set_Length)
- while Source.Last >= Index_Type'First loop
- pragma Assert
- (Source.Last <= Index_Type'First
- or else not (Is_Less
- (Source.Elements.EA (Source.Last),
- Source.Elements.EA (Source.Last - 1))));
+ -- 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)
+ while Source.Last >= Index_Type'First loop
+ pragma Assert
+ (Source.Last <= Index_Type'First
+ or else not (Is_Less (SA (Source.Last),
+ SA (Source.Last - 1))));
+
+ if I < Index_Type'First then
+ declare
+ Src : Elements_Array renames
+ SA (Index_Type'First .. Source.Last);
+ begin
+ TA (Index_Type'First .. J) := Src;
+ Src := (others => null);
+ end;
+
+ Source.Last := No_Index;
+ exit;
+ end if;
+
+ pragma Assert
+ (I <= Index_Type'First
+ or else not (Is_Less (TA (I), TA (I - 1))));
- if I < Index_Type'First then
declare
- Src : Elements_Array renames
- Source.Elements.EA (Index_Type'First .. Source.Last);
+ Src : Element_Access renames SA (Source.Last);
+ Tgt : Element_Access renames TA (I);
begin
- Target.Elements.EA (Index_Type'First .. J) := Src;
- Src := (others => null);
+ if Is_Less (Src, Tgt) then
+ Target.Elements.EA (J) := Tgt;
+ Tgt := null;
+ I := I - 1;
+
+ else
+ Target.Elements.EA (J) := Src;
+ Src := null;
+ Source.Last := Source.Last - 1;
+ end if;
end;
- Source.Last := No_Index;
- return;
- end if;
+ J := J - 1;
+ end loop;
- pragma Assert
- (I <= Index_Type'First
- or else not (Is_Less
- (Target.Elements.EA (I),
- Target.Elements.EA (I - 1))));
+ TB := TB - 1;
+ TL := TL - 1;
- declare
- Src : Element_Access renames Source.Elements.EA (Source.Last);
- Tgt : Element_Access renames Target.Elements.EA (I);
+ SB := SB - 1;
+ SL := SL - 1;
- begin
- if Is_Less (Src, Tgt) then
- Target.Elements.EA (J) := Tgt;
- Tgt := null;
- I := I - 1;
+ exception
+ when others =>
+ TB := TB - 1;
+ TL := TL - 1;
- else
- Target.Elements.EA (J) := Src;
- Src := null;
- Source.Last := Source.Last - 1;
- end if;
- end;
+ SB := SB - 1;
+ SL := SL - 1;
- J := J - 1;
- end loop;
+ raise;
+ end;
end Merge;
----------
@@ -1475,7 +1599,28 @@ package body Ada.Containers.Indefinite_Vectors is
"attempt to tamper with cursors (vector is busy)";
end if;
- Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
+ -- 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));
+
+ B := B - 1;
+ L := L - 1;
+
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Sort;
end Generic_Sorting;
@@ -1488,9 +1633,9 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return False;
+ else
+ return Position.Index <= Position.Container.Last;
end if;
-
- return Position.Index <= Position.Container.Last;
end Has_Element;
------------
@@ -1663,7 +1808,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := No_Index + Index_Type'Base (New_Length);
-
else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
end if;
@@ -1859,7 +2003,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity);
-
else
Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
@@ -1888,9 +2031,8 @@ package body Ada.Containers.Indefinite_Vectors is
-- The new items are being appended to the vector, so no
-- sliding of existing elements is required.
- -- We have copied the elements from to the old, source array to
- -- the new, destination array, so we can now deallocate the old
- -- array.
+ -- We have copied the elements from to the old source array to the
+ -- new destination array, so we can now deallocate the old array.
Container.Elements := Dst;
Free (Src);
@@ -1899,11 +2041,11 @@ package body Ada.Containers.Indefinite_Vectors is
for Idx in Before .. New_Last loop
- -- In order to preserve container invariants, we always
- -- attempt the element allocation first, before setting the
- -- Last index value, in case the allocation fails (either
- -- because there is no storage available, or because element
- -- initialization fails).
+ -- In order to preserve container invariants, we always attempt
+ -- the element allocation first, before setting the Last index
+ -- value, in case the allocation fails (either because there
+ -- is no storage available, or because element initialization
+ -- fails).
declare
-- The element allocator may need an accessibility check in
@@ -1928,24 +2070,21 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
-
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
- -- We have copied the elements from to the old, source array to
- -- the new, destination array, so we can now deallocate the old
- -- array.
+ -- We have copied the elements from to the old source array to the
+ -- new destination array, so we can now deallocate the old array.
Container.Elements := Dst;
Container.Last := New_Last;
Free (Src);
-- 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
- -- items.
+ -- values. Fill in that partition of the array with the new items.
for Idx in Before .. Index - 1 loop
@@ -2081,7 +2220,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
J := Before + Index_Type'Base (N);
-
else
J := Index_Type'Base (Count_Type'Base (Before) + N);
end if;
@@ -2105,7 +2243,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Index := J - Index_Type'Base (Src'Length);
-
else
Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length);
end if;
@@ -2138,9 +2275,7 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
@@ -2172,9 +2307,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
if Is_Empty (New_Item) then
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
Position := No_Element;
else
Position := (Container'Unrestricted_Access, Before.Index);
@@ -2183,9 +2316,7 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
@@ -2221,9 +2352,7 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
@@ -2266,9 +2395,7 @@ package body Ada.Containers.Indefinite_Vectors is
return;
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
@@ -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
-- proper error.)
- if Before > Container.Last
- and then Before > Container.Last + 1
- then
+ if Before > Container.Last and then Before > Container.Last + 1 then
raise Constraint_Error with
"Before index is out of range (too large)";
end if;
@@ -2453,7 +2578,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := No_Index + Index_Type'Base (New_Length);
-
else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
end if;
@@ -2490,7 +2614,8 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
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
-- enough unused storage for the new items.
@@ -2501,13 +2626,12 @@ package body Ada.Containers.Indefinite_Vectors is
if Before <= Container.Last then
-- The new space is being inserted before some existing
- -- elements, so we must slide the existing elements up to their
- -- new home. We use the wider of Index_Type'Base and
+ -- elements, so we must slide the existing elements up to
+ -- their new home. We use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate index values.
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
-
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
@@ -2554,7 +2678,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity);
-
else
Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
@@ -2585,7 +2708,6 @@ package body Ada.Containers.Indefinite_Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
-
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
@@ -2619,9 +2741,7 @@ package body Ada.Containers.Indefinite_Vectors is
end if;
if Count = 0 then
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
Position := No_Element;
else
Position := (Container'Unrestricted_Access, Before.Index);
@@ -2810,14 +2930,13 @@ package body Ada.Containers.Indefinite_Vectors is
declare
EA : constant Element_Access :=
- Container.Elements.EA (Container.Last);
-
+ Container.Elements.EA (Container.Last);
begin
if EA = null then
raise Constraint_Error with "last element is empty";
+ else
+ return EA.all;
end if;
-
- return EA.all;
end;
end Last_Element;
@@ -2903,36 +3022,30 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return No_Element;
- end if;
-
- if Position.Index < Position.Container.Last then
+ elsif Position.Index < Position.Container.Last then
return (Position.Container, Position.Index + 1);
+ else
+ return No_Element;
end if;
-
- return No_Element;
end Next;
function Next (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.Container = null then
return No_Element;
- end if;
-
- if Position.Container /= Object.Container then
+ elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong vector";
+ else
+ return Next (Position);
end if;
-
- return Next (Position);
end Next;
procedure Next (Position : in out Cursor) is
begin
if Position.Container = null then
return;
- end if;
-
- if Position.Index < Position.Container.Last then
+ elsif Position.Index < Position.Container.Last then
Position.Index := Position.Index + 1;
else
Position := No_Element;
@@ -2954,10 +3067,7 @@ package body Ada.Containers.Indefinite_Vectors is
Count : Count_Type := 1)
is
begin
- Insert (Container,
- Index_Type'First,
- New_Item,
- Count);
+ Insert (Container, Index_Type'First, New_Item, Count);
end Prepend;
--------------
@@ -2968,9 +3078,7 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return;
- end if;
-
- if Position.Index > Index_Type'First then
+ elsif Position.Index > Index_Type'First then
Position.Index := Position.Index - 1;
else
Position := No_Element;
@@ -2981,27 +3089,23 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return No_Element;
- end if;
-
- if Position.Index > Index_Type'First then
+ elsif Position.Index > Index_Type'First then
return (Position.Container, Position.Index - 1);
+ else
+ return No_Element;
end if;
-
- return No_Element;
end Previous;
function Previous (Object : Iterator; Position : Cursor) return Cursor is
begin
if Position.Container = null then
return No_Element;
- end if;
-
- if Position.Container /= Object.Container then
+ elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong vector";
+ else
+ return Previous (Position);
end if;
-
- return Previous (Position);
end Previous;
-------------------
@@ -3049,9 +3153,9 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
+ else
+ Query_Element (Position.Container.all, Position.Index, Process);
end if;
-
- Query_Element (Position.Container.all, Position.Index, Process);
end Query_Element;
----------
@@ -3064,8 +3168,7 @@ package body Ada.Containers.Indefinite_Vectors is
is
Length : Count_Type'Base;
Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
-
- B : Boolean;
+ B : Boolean;
begin
Clear (Container);
@@ -3616,23 +3719,50 @@ package body Ada.Containers.Indefinite_Vectors is
raise Program_Error with "Position cursor denotes wrong container";
end if;
- if Position.Container = null
- or else Position.Index > Container.Last
- then
+ if Position.Container = null or else Position.Index > Container.Last then
Last := Container.Last;
else
Last := Position.Index;
end if;
- for Indx in reverse Index_Type'First .. Last loop
- if Container.Elements.EA (Indx) /= null
- and then Container.Elements.EA (Indx).all = Item
- then
- return (Container'Unrestricted_Access, Indx);
+ -- 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
+ if Container.Elements.EA (Indx) /= null
+ and then Container.Elements.EA (Indx).all = Item
+ then
+ Result := Indx;
+ exit;
+ end if;
+ end loop;
+
+ B := B - 1;
+ L := L - 1;
+
+ if Result = No_Index then
+ return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Result);
end if;
- end loop;
- return No_Element;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Reverse_Find;
------------------------
@@ -3644,18 +3774,41 @@ package body Ada.Containers.Indefinite_Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index
is
+ B : Natural renames Container'Unrestricted_Access.Busy;
+ L : Natural renames Container'Unrestricted_Access.Lock;
+
Last : constant Index_Type'Base :=
(if Index > Container.Last then Container.Last else Index);
+
+ Result : Index_Type'Base;
+
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
if Container.Elements.EA (Indx) /= null
and then Container.Elements.EA (Indx).all = Item
then
- return Indx;
+ Result := Indx;
+ exit;
end if;
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;
---------------------
@@ -3800,13 +3953,11 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
return No_Index;
- end if;
-
- if Position.Index <= Position.Container.Last then
+ elsif Position.Index <= Position.Container.Last then
return Position.Index;
+ else
+ return No_Index;
end if;
-
- return No_Index;
end To_Index;
---------------
@@ -4072,13 +4223,13 @@ package body Ada.Containers.Indefinite_Vectors is
begin
if Position.Container = null then
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";
- end if;
- Update_Element (Container, Position.Index, Process);
+ else
+ Update_Element (Container, Position.Index, Process);
+ end if;
end Update_Element;
-----------
diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb
index a67c156c2bc..5b722fe8a72 100644
--- a/gcc/ada/a-convec.adb
+++ b/gcc/ada/a-convec.adb
@@ -84,12 +84,10 @@ package body Ada.Containers.Vectors is
end if;
declare
- RE : Elements_Array renames
- Right.Elements.EA (Index_Type'First .. Right.Last);
-
+ RE : Elements_Array renames
+ Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access :=
- new Elements_Type'(Right.Last, RE);
-
+ new Elements_Type'(Right.Last, RE);
begin
return (Controlled with Elements, Right.Last, 0, 0);
end;
@@ -97,12 +95,10 @@ package body Ada.Containers.Vectors is
if RN = 0 then
declare
- LE : Elements_Array renames
- Left.Elements.EA (Index_Type'First .. Left.Last);
-
+ LE : Elements_Array renames
+ Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : constant Elements_Access :=
- new Elements_Type'(Left.Last, LE);
-
+ new Elements_Type'(Left.Last, LE);
begin
return (Controlled with Elements, Left.Last, 0, 0);
end;
@@ -197,15 +193,12 @@ package body Ada.Containers.Vectors is
end if;
declare
- LE : Elements_Array renames
- Left.Elements.EA (Index_Type'First .. Left.Last);
-
- RE : Elements_Array renames
- Right.Elements.EA (Index_Type'First .. Right.Last);
-
+ LE : Elements_Array renames
+ Left.Elements.EA (Index_Type'First .. Left.Last);
+ RE : Elements_Array renames
+ Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access :=
- new Elements_Type'(Last, LE & RE);
-
+ new Elements_Type'(Last, LE & RE);
begin
return (Controlled with Elements, Last, 0, 0);
end;
@@ -247,14 +240,11 @@ package body Ada.Containers.Vectors is
end if;
declare
- Last : constant Index_Type := Left.Last + 1;
-
- LE : Elements_Array renames
- Left.Elements.EA (Index_Type'First .. Left.Last);
-
+ Last : constant Index_Type := Left.Last + 1;
+ LE : Elements_Array renames
+ Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : constant Elements_Access :=
- new Elements_Type'(Last => Last, EA => LE & Right);
-
+ new Elements_Type'(Last => Last, EA => LE & Right);
begin
return (Controlled with Elements, Last, 0, 0);
end;
@@ -275,7 +265,6 @@ package body Ada.Containers.Vectors is
new Elements_Type'
(Last => Index_Type'First,
EA => (others => Left));
-
begin
return (Controlled with Elements, Index_Type'First, 0, 0);
end;
@@ -346,6 +335,14 @@ package body Ada.Containers.Vectors 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
if Left'Address = Right'Address then
return True;
@@ -355,13 +352,40 @@ package body Ada.Containers.Vectors is
return False;
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
if Left.Elements.EA (J) /= Right.Elements.EA (J) then
- return False;
+ Result := False;
+ exit;
end if;
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 "=";
------------
@@ -418,16 +442,11 @@ package body Ada.Containers.Vectors is
begin
if Is_Empty (New_Item) then
return;
- end if;
-
- if Container.Last = Index_Type'Last then
+ elsif Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
+ else
+ Insert (Container, Container.Last + 1, New_Item);
end if;
-
- Insert
- (Container,
- Container.Last + 1,
- New_Item);
end Append;
procedure Append
@@ -438,17 +457,11 @@ package body Ada.Containers.Vectors is
begin
if Count = 0 then
return;
- end if;
-
- if Container.Last = Index_Type'Last then
+ elsif Container.Last = Index_Type'Last then
raise Constraint_Error with "vector is already at its maximum length";
+ else
+ Insert (Container, Container.Last + 1, New_Item, Count);
end if;
-
- Insert
- (Container,
- Container.Last + 1,
- New_Item,
- Count);
end Append;
------------
@@ -459,10 +472,10 @@ package body Ada.Containers.Vectors is
begin
if Target'Address = Source'Address then
return;
+ else
+ Target.Clear;
+ Target.Append (Source);
end if;
-
- Target.Clear;
- Target.Append (Source);
end Assign;
--------------
@@ -638,9 +651,9 @@ package body Ada.Containers.Vectors is
if Index > Old_Last then
if Index > Old_Last + 1 then
raise Constraint_Error with "Index is out of range (too large)";
+ else
+ return;
end if;
-
- return;
end if;
-- Here and elsewhere we treat deleting 0 items from the container as a
@@ -668,7 +681,6 @@ package body Ada.Containers.Vectors is
if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
-
else
Count2 := Count_Type'Base (Old_Last - Index + 1);
end if;
@@ -694,7 +706,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := Old_Last - Index_Type'Base (Count);
J := Index + Index_Type'Base (Count);
-
else
New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
J := Index_Type'Base (Count_Type'Base (Index) + Count);
@@ -708,7 +719,6 @@ package body Ada.Containers.Vectors is
declare
EA : Elements_Array renames Container.Elements.EA;
-
begin
EA (Index .. New_Last) := EA (J .. Old_Last);
Container.Last := New_Last;
@@ -725,18 +735,17 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
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";
- end if;
- if Position.Index > Container.Last then
+ elsif Position.Index > Container.Last then
raise Program_Error with "Position index is out of range";
- end if;
- Delete (Container, Position.Index, Count);
- Position := No_Element;
+ else
+ Delete (Container, Position.Index, Count);
+ Position := No_Element;
+ end if;
end Delete;
------------------
@@ -750,14 +759,14 @@ package body Ada.Containers.Vectors is
begin
if Count = 0 then
return;
- end if;
- if Count >= Length (Container) then
+ elsif Count >= Length (Container) then
Clear (Container);
return;
- end if;
- Delete (Container, Index_Type'First, Count);
+ else
+ Delete (Container, Index_Type'First, Count);
+ end if;
end Delete_First;
-----------------
@@ -823,9 +832,9 @@ package body Ada.Containers.Vectors is
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
+ else
+ return Container.Elements.EA (Index);
end if;
-
- return Container.Elements.EA (Index);
end Element;
function Element (Position : Cursor) return Element_Type is
@@ -850,11 +859,12 @@ package body Ada.Containers.Vectors is
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
- end if;
- Container.Elements := null;
- Container.Last := No_Index;
- Free (X);
+ else
+ Container.Elements := null;
+ Container.Last := No_Index;
+ Free (X);
+ end if;
end Finalize;
procedure Finalize (Object : in out Iterator) is
@@ -899,13 +909,42 @@ package body Ada.Containers.Vectors is
end if;
end if;
- for J in Position.Index .. Container.Last loop
- if Container.Elements.EA (J) = Item then
- return (Container'Unrestricted_Access, J);
+ -- 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
+ if Container.Elements.EA (J) = Item then
+ Result := J;
+ exit;
+ end if;
+ end loop;
+
+ B := B - 1;
+ L := L - 1;
+
+ if Result = No_Index then
+ return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Result);
end if;
- end loop;
- return No_Element;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Find;
----------------
@@ -917,14 +956,36 @@ package body Ada.Containers.Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index
is
+ B : Natural renames Container'Unrestricted_Access.Busy;
+ L : Natural renames Container'Unrestricted_Access.Lock;
+
+ Result : Index_Type'Base;
+
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
if Container.Elements.EA (Indx) = Item then
- return Indx;
+ Result := Indx;
+ exit;
end if;
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;
-----------
@@ -1002,17 +1063,40 @@ package body Ada.Containers.Vectors is
return True;
end if;
+ -- Per AI05-0022, the container implementation is required to detect
+ -- element tampering by a generic actual subprogram.
+
declare
EA : Elements_Array renames Container.Elements.EA;
+
+ B : Natural renames Container'Unrestricted_Access.Busy;
+ L : Natural renames Container'Unrestricted_Access.Lock;
+
+ Result : Boolean;
+
begin
+ B := B + 1;
+ L := L + 1;
+
+ Result := True;
for J in Index_Type'First .. Container.Last - 1 loop
if EA (J + 1) < EA (J) then
- return False;
+ Result := False;
+ exit;
end if;
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;
-----------
@@ -1053,23 +1137,38 @@ package body Ada.Containers.Vectors is
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;
while Source.Last >= Index_Type'First loop
pragma Assert (Source.Last <= Index_Type'First
- or else not (SA (Source.Last) <
- SA (Source.Last - 1)));
+ or else not (SA (Source.Last) <
+ SA (Source.Last - 1)));
if I < Index_Type'First then
TA (Index_Type'First .. J) :=
SA (Index_Type'First .. Source.Last);
Source.Last := No_Index;
- return;
+ exit;
end if;
pragma Assert (I <= Index_Type'First
@@ -1086,6 +1185,22 @@ package body Ada.Containers.Vectors is
J := J - 1;
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;
@@ -1122,7 +1237,28 @@ package body Ada.Containers.Vectors is
"attempt to tamper with cursors (vector is busy)";
end if;
- Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
+ -- 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));
+
+ B := B - 1;
+ L := L - 1;
+
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Sort;
end Generic_Sorting;
@@ -1182,9 +1318,7 @@ package body Ada.Containers.Vectors is
-- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.)
- if Before > Container.Last
- and then Before > Container.Last + 1
- then
+ if Before > Container.Last and then Before > Container.Last + 1 then
raise Constraint_Error with
"Before index is out of range (too large)";
end if;
@@ -1374,7 +1508,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
-
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
@@ -1402,9 +1535,9 @@ package body Ada.Containers.Vectors is
if New_Capacity > Count_Type'Last / 2 then
New_Capacity := Count_Type'Last;
exit;
+ else
+ New_Capacity := 2 * New_Capacity;
end if;
-
- New_Capacity := 2 * New_Capacity;
end loop;
if New_Capacity > Max_Length then
@@ -1421,7 +1554,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity);
-
else
Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
@@ -1455,7 +1587,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
-
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
@@ -1475,6 +1606,7 @@ package body Ada.Containers.Vectors is
declare
X : Elements_Access := Container.Elements;
+
begin
-- We first isolate the old internal array, removing it from the
-- container and replacing it with the new internal array, before we
@@ -1518,7 +1650,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
J := (Before - 1) + Index_Type'Base (N);
-
else
J := Index_Type'Base (Count_Type'Base (Before - 1) + N);
end if;
@@ -1549,7 +1680,7 @@ package body Ada.Containers.Vectors is
Index_Type'First .. L;
Src : Elements_Array renames
- Container.Elements.EA (Src_Index_Subtype);
+ Container.Elements.EA (Src_Index_Subtype);
K : Index_Type'Base;
@@ -1562,7 +1693,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
K := L + Index_Type'Base (Src'Length);
-
else
K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
end if;
@@ -1594,7 +1724,7 @@ package body Ada.Containers.Vectors is
F .. Container.Last;
Src : Elements_Array renames
- Container.Elements.EA (Src_Index_Subtype);
+ Container.Elements.EA (Src_Index_Subtype);
K : Index_Type'Base;
@@ -1606,7 +1736,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
K := F - Index_Type'Base (Src'Length);
-
else
K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
end if;
@@ -1633,9 +1762,7 @@ package body Ada.Containers.Vectors is
return;
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
@@ -1666,9 +1793,7 @@ package body Ada.Containers.Vectors is
end if;
if Is_Empty (New_Item) then
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
Position := No_Element;
else
Position := (Container'Unrestricted_Access, Before.Index);
@@ -1677,9 +1802,7 @@ package body Ada.Containers.Vectors is
return;
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
@@ -1715,9 +1838,7 @@ package body Ada.Containers.Vectors is
return;
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
@@ -1749,9 +1870,7 @@ package body Ada.Containers.Vectors is
end if;
if Count = 0 then
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
Position := No_Element;
else
Position := (Container'Unrestricted_Access, Before.Index);
@@ -1760,9 +1879,7 @@ package body Ada.Containers.Vectors is
return;
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
@@ -1799,7 +1916,6 @@ package body Ada.Containers.Vectors is
is
New_Item : Element_Type; -- Default-initialized value
pragma Warnings (Off, New_Item);
-
begin
Insert (Container, Before, New_Item, Position, Count);
end Insert;
@@ -1849,9 +1965,7 @@ package body Ada.Containers.Vectors is
-- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.)
- if Before > Container.Last
- and then Before > Container.Last + 1
- then
+ if Before > Container.Last and then Before > Container.Last + 1 then
raise Constraint_Error with
"Before index is out of range (too large)";
end if;
@@ -1973,7 +2087,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
New_Last := No_Index + Index_Type'Base (New_Length);
-
else
New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
end if;
@@ -2081,7 +2194,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Dst_Last := No_Index + Index_Type'Base (New_Capacity);
-
else
Dst_Last :=
Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
@@ -2113,7 +2225,6 @@ package body Ada.Containers.Vectors is
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
Index := Before + Index_Type'Base (Count);
-
else
Index := Index_Type'Base (Count_Type'Base (Before) + Count);
end if;
@@ -2166,9 +2277,7 @@ package body Ada.Containers.Vectors is
end if;
if Count = 0 then
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
Position := No_Element;
else
Position := (Container'Unrestricted_Access, Before.Index);
@@ -2177,9 +2286,7 @@ package body Ada.Containers.Vectors is
return;
end if;
- if Before.Container = null
- or else Before.Index > Container.Last
- then
+ if Before.Container = null or else Before.Index > Container.Last then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
@@ -2250,9 +2357,9 @@ package body Ada.Containers.Vectors is
-- for a reverse iterator, Container.Last is the beginning.
return It : constant Iterator :=
- (Limited_Controlled with
- Container => V,
- Index => No_Index)
+ (Limited_Controlled with
+ Container => V,
+ Index => No_Index)
do
B := B + 1;
end return;
@@ -2303,9 +2410,9 @@ package body Ada.Containers.Vectors is
-- is a forward or reverse iteration.
return It : constant Iterator :=
- (Limited_Controlled with
- Container => V,
- Index => Start.Index)
+ (Limited_Controlled with
+ Container => V,
+ Index => Start.Index)
do
B := B + 1;
end return;
@@ -2455,14 +2562,12 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
return No_Element;
- end if;
-
- if Position.Container /= Object.Container then
+ elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong vector";
+ else
+ return Next (Position);
end if;
-
- return Next (Position);
end Next;
procedure Next (Position : in out Cursor) is
@@ -2491,10 +2596,7 @@ package body Ada.Containers.Vectors is
Count : Count_Type := 1)
is
begin
- Insert (Container,
- Index_Type'First,
- New_Item,
- Count);
+ Insert (Container, Index_Type'First, New_Item, Count);
end Prepend;
--------------
@@ -2516,14 +2618,12 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
return No_Element;
- end if;
-
- if Position.Container /= Object.Container then
+ elsif Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong vector";
+ else
+ return Previous (Position);
end if;
-
- return Previous (Position);
end Previous;
procedure Previous (Position : in out Cursor) is
@@ -2578,9 +2678,9 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
+ else
+ Query_Element (Position.Container.all, Position.Index, Process);
end if;
-
- Query_Element (Position.Container.all, Position.Index, Process);
end Query_Element;
----------
@@ -2677,6 +2777,7 @@ package body Ada.Containers.Vectors is
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
+
else
declare
C : Vector renames Container'Unrestricted_Access.all;
@@ -2706,14 +2807,12 @@ package body Ada.Containers.Vectors is
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
- end if;
-
- if Container.Lock > 0 then
+ elsif Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
+ else
+ Container.Elements.EA (Index) := New_Item;
end if;
-
- Container.Elements.EA (Index) := New_Item;
end Replace_Element;
procedure Replace_Element
@@ -2724,22 +2823,21 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
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";
- end if;
- if Position.Index > Container.Last then
+ elsif Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range";
- end if;
- if Container.Lock > 0 then
- raise Program_Error with
- "attempt to tamper with elements (vector is locked)";
- end if;
+ else
+ if Container.Lock > 0 then
+ raise Program_Error with
+ "attempt to tamper with elements (vector is locked)";
+ end if;
- Container.Elements.EA (Position.Index) := New_Item;
+ Container.Elements.EA (Position.Index) := New_Item;
+ end if;
end Replace_Element;
----------------------
@@ -3126,13 +3224,42 @@ package body Ada.Containers.Vectors is
then Container.Last
else Position.Index);
- for Indx in reverse Index_Type'First .. Last loop
- if Container.Elements.EA (Indx) = Item then
- return (Container'Unrestricted_Access, Indx);
+ -- 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
+ if Container.Elements.EA (Indx) = Item then
+ Result := Indx;
+ exit;
+ end if;
+ end loop;
+
+ B := B - 1;
+ L := L - 1;
+
+ if Result = No_Index then
+ return No_Element;
+ else
+ return Cursor'(Container'Unrestricted_Access, Result);
end if;
- end loop;
- return No_Element;
+ exception
+ when others =>
+ B := B - 1;
+ L := L - 1;
+ raise;
+ end;
end Reverse_Find;
------------------------
@@ -3144,17 +3271,39 @@ package body Ada.Containers.Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index
is
+ B : Natural renames Container'Unrestricted_Access.Busy;
+ L : Natural renames Container'Unrestricted_Access.Lock;
+
Last : constant Index_Type'Base :=
Index_Type'Min (Container.Last, Index);
+ Result : Index_Type'Base;
+
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
if Container.Elements.EA (Indx) = Item then
- return Indx;
+ Result := Indx;
+ exit;
end if;
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;
---------------------
@@ -3245,21 +3394,19 @@ package body Ada.Containers.Vectors is
begin
if I.Container = null then
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";
- 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";
- 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";
- end if;
- Swap (Container, I.Index, J.Index);
+ else
+ Swap (Container, I.Index, J.Index);
+ end if;
end Swap;
---------------
@@ -3286,13 +3433,11 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
return No_Index;
- end if;
-
- if Position.Index <= Position.Container.Last then
+ elsif Position.Index <= Position.Container.Last then
return Position.Index;
+ else
+ return No_Index;
end if;
-
- return No_Index;
end To_Index;
---------------
diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads
index 0eeeed6cbb9..33a184ccfbc 100644
--- a/gcc/ada/stand.ads
+++ b/gcc/ada/stand.ads
@@ -364,23 +364,21 @@ package Stand is
Any_Type : Entity_Id;
-- 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
- -- has been detected. Any_Type plays an important role in avoiding
- -- cascaded errors, because it is compatible with all other types, and is
- -- propagated to any expression that has a subexpression of Any_Type.
- -- When resolving operators, Any_Type is the initial type of the node
- -- before any of its candidate interpretations has been examined. If after
- -- examining all of them the type is still Any_Type, the node has no
- -- possible interpretation and an error can be emitted (and Any_Type will
- -- be propagated upwards).
-
+ -- has been detected. Any_Type plays an important role in avoiding cascaded
+ -- errors, because it is compatible with all other types, and is propagated
+ -- to any expression that has a subexpression of Any_Type. When resolving
+ -- operators, Any_Type is the initial type of the node before any of its
+ -- candidate interpretations has been examined. If after examining all of
+ -- them the type is still Any_Type, the node has no possible interpretation
+ -- and an error can be emitted (and Any_Type will be propagated upwards).
+ --
-- There is one situation in which Any_Type is used to legitimately
- -- represent a case where the type is not known pre-resolution, and
- -- that is for the N_Raise_Expression node. In this case, the Etype
- -- being set to Any_Type is normal and does not represent an error.
- -- In particular, it is compatible with the type of any constituend of
- -- the enclosing expression, if any. The type is eventually replaced
- -- with the type of the context, which plays no role in the resolution
- -- of the Raise_Expression.
+ -- represent a case where the type is not known pre-resolution, and that
+ -- is for the N_Raise_Expression node. In this case, the Etype being set to
+ -- Any_Type is normal and does not represent an error. In particular, it is
+ -- compatible with the type of any constituent of the enclosing expression,
+ -- if any. The type is eventually replaced with the type of the context,
+ -- which plays no role in the resolution of the Raise_Expression.
Any_Access : Entity_Id;
-- Used to resolve the overloaded literal NULL