Skip to content

R
riscv-gcc-1
Commit 2a738b34 by Arnaud Charlet
Options

[multiple changes] 

2015-10-16  Bob Duff  <duff@adacore.com>

	* a-contai.ads: Add two check names: Container_Checks and
	Tampering_Check.  Move the tampering check machinery from
	Ada.Containers.Vectors to Ada.Containers. Later we can share it
	with other containers.
	Disable the tampering machinery in the presence of
	Suppress(Tampering_Check).
	Simplify the implementation of tampering checks. E.g. use RAII
	to make incrementing/decrementing of the counts more concise.
	* a-contai.adb: New package body, implementing the above.
	* a-convec.ads, a-convec.adb: Use tampering check machinery
	in Ada.Containers.
	Disable all checking code when checks are suppressed.
	Simplify many of the operations. Implement "&" in terms of Append,
	rather than "by hand".
	Remove: function "=" (L, R : Elements_Array) return Boolean is
	abstract; so we can call the predefined "=" on Elements_Array.
	For "=" on Vectors: Previously, we returned True immediately if
	Left'Address = Right'Address.  That seems like a non-optimization
	("if X = X" is unusual), so removed that.  Simplify by using
	slice comparison ("=" on Element_Array will automatically call
	"=" on the components, even if user defined).

2015-10-16  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Chek_Record_Representation_Clause): When
	iterating over components, skip anonymous subtypes created for
	constrained array components.

From-SVN: r228896
parent 00c93ba2
Showing with 728 additions and 895 deletions
gcc/ada/ChangeLog
2015-10-16 Bob Duff <duff@adacore.com>
* a-contai.ads: Add two check names: Container_Checks and
Tampering_Check. Move the tampering check machinery from
Ada.Containers.Vectors to Ada.Containers. Later we can share it
with other containers.
Disable the tampering machinery in the presence of
Suppress(Tampering_Check).
Simplify the implementation of tampering checks. E.g. use RAII
to make incrementing/decrementing of the counts more concise.
* a-contai.adb: New package body, implementing the above.
* a-convec.ads, a-convec.adb: Use tampering check machinery
in Ada.Containers.
Disable all checking code when checks are suppressed.
Simplify many of the operations. Implement "&" in terms of Append,
rather than "by hand".
Remove: function "=" (L, R : Elements_Array) return Boolean is
abstract; so we can call the predefined "=" on Elements_Array.
For "=" on Vectors: Previously, we returned True immediately if
Left'Address = Right'Address. That seems like a non-optimization
("if X = X" is unusual), so removed that. Simplify by using
slice comparison ("=" on Element_Array will automatically call
"=" on the components, even if user defined).
2015-10-16 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Chek_Record_Representation_Clause): When
iterating over components, skip anonymous subtypes created for
constrained array components.
2015-10-16 Eric Botcazou <ebotcazou@adacore.com> 2015-10-16 Eric Botcazou <ebotcazou@adacore.com>
* a-tags.ads (Parent_Size): Remove obsolete pragma Export. * a-tags.ads (Parent_Size): Remove obsolete pragma Export.
......
gcc/ada/a-contai.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- A D A . C O N T A I N E R S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2015, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
package body Ada.Containers is
package body Generic_Implementation is
------------
-- Adjust --
------------
procedure Adjust (Control : in out Reference_Control_Type) is
pragma Assert (T_Check); -- not called if check suppressed
begin
if Control.T_Counts /= null then
Lock (Control.T_Counts.all);
end if;
end Adjust;
----------
-- Busy --
----------
procedure Busy (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
declare
B : Natural renames T_Counts.Busy;
begin
B := B + 1;
end;
end if;
end Busy;
--------------
-- Finalize --
--------------
procedure Finalize (Control : in out Reference_Control_Type) is
pragma Assert (T_Check); -- not called if check suppressed
begin
if Control.T_Counts /= null then
Unlock (Control.T_Counts.all);
Control.T_Counts := null;
end if;
end Finalize;
-- No need to protect against double Finalize here, because these types
-- are limited.
procedure Finalize (Busy : in out With_Busy) is
pragma Assert (T_Check); -- not called if check suppressed
begin
Unbusy (Busy.T_Counts.all);
end Finalize;
procedure Finalize (Lock : in out With_Lock) is
pragma Assert (T_Check); -- not called if check suppressed
begin
Unlock (Lock.T_Counts.all);
end Finalize;
----------------
-- Initialize --
----------------
procedure Initialize (Busy : in out With_Busy) is
pragma Assert (T_Check); -- not called if check suppressed
begin
Generic_Implementation.Busy (Busy.T_Counts.all);
end Initialize;
procedure Initialize (Lock : in out With_Lock) is
pragma Assert (T_Check); -- not called if check suppressed
begin
Generic_Implementation.Lock (Lock.T_Counts.all);
end Initialize;
----------
-- Lock --
----------
procedure Lock (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
declare
B : Natural renames T_Counts.Busy;
L : Natural renames T_Counts.Lock;
begin
L := L + 1;
B := B + 1;
end;
end if;
end Lock;
--------------
-- TC_Check --
--------------
procedure TC_Check (T_Counts : Tamper_Counts) is
begin
if T_Check and then T_Counts.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors";
end if;
end TC_Check;
--------------
-- TE_Check --
--------------
procedure TE_Check (T_Counts : Tamper_Counts) is
begin
if T_Check and then T_Counts.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements";
end if;
end TE_Check;
------------
-- Unbusy --
------------
procedure Unbusy (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
declare
B : Natural renames T_Counts.Busy;
begin
B := B - 1;
end;
end if;
end Unbusy;
------------
-- Unlock --
------------
procedure Unlock (T_Counts : in out Tamper_Counts) is
begin
if T_Check then
declare
B : Natural renames T_Counts.Busy;
L : Natural renames T_Counts.Lock;
begin
L := L - 1;
B := B - 1;
end;
end if;
end Unlock;
-----------------
-- Zero_Counts --
-----------------
procedure Zero_Counts (T_Counts : out Tamper_Counts) is
begin
if T_Check then
T_Counts := (others => <>);
end if;
end Zero_Counts;
end Generic_Implementation;
end Ada.Containers;
gcc/ada/a-contai.ads
...@@ -13,6 +13,17 @@ ...@@ -13,6 +13,17 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
pragma Check_Name (Container_Checks);
pragma Check_Name (Tampering_Check);
-- The above checks are not in the Ada RM. They are added in order to allow
-- suppression of checks within containers packages. Suppressing
-- Tampering_Check suppresses the tampering checks and associated machinery,
-- which is very expensive. Suppressing Container_Checks suppresses
-- Tampering_Check as well as all the other (not-so-expensive) containers
-- checks.
private with Ada.Finalization;
package Ada.Containers is package Ada.Containers is
pragma Pure; pragma Pure;
...@@ -21,4 +32,123 @@ package Ada.Containers is ...@@ -21,4 +32,123 @@ package Ada.Containers is
Capacity_Error : exception; Capacity_Error : exception;
private
type Tamper_Counts is record
Busy : Natural := 0;
Lock : Natural := 0;
end record;
-- Busy is positive when tampering with cursors is prohibited. Busy and
-- Lock are both positive when tampering with elements is prohibited.
type Tamper_Counts_Access is access all Tamper_Counts;
for Tamper_Counts_Access'Storage_Size use 0;
generic
package Generic_Implementation is
-- Generic package used in the implementation of containers.
-- ???Currently used by Vectors; not yet by all other containers.
-- This needs to be generic so that the 'Enabled attribute will return
-- the value that is relevant at the point where a container generic is
-- instantiated. For example:
--
-- pragma Suppress (Container_Checks);
-- package My_Vectors is new Ada.Containers.Vectors (...);
--
-- should suppress all container-related checks within the instance
-- My_Vectors.
-- Shorthands for "checks enabled" and "tampering checks enabled". Note
-- that suppressing either Container_Checks or Tampering_Check disables
-- tampering checks. Note that this code needs to be in a generic
-- package, because we want to take account of check suppressions at the
-- instance. We use these flags, along with pragma Inline, to ensure
-- that the compiler can optimize away the checks, as well as the
-- tampering check machinery, when checks are suppressed.
Checks : constant Boolean := Container_Checks'Enabled;
T_Check : constant Boolean :=
Container_Checks'Enabled and Tampering_Check'Enabled;
-- Reference_Control_Type is used as a component of reference types, to
-- prohibit tampering with elements so long as references exist.
type Reference_Control_Type is
new Finalization.Controlled with record
T_Counts : Tamper_Counts_Access;
end record
with Disable_Controlled => not T_Check;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
procedure Zero_Counts (T_Counts : out Tamper_Counts);
pragma Inline (Zero_Counts);
-- Set Busy and Lock to zero
procedure Busy (T_Counts : in out Tamper_Counts);
pragma Inline (Busy);
-- Prohibit tampering with cursors
procedure Unbusy (T_Counts : in out Tamper_Counts);
pragma Inline (Unbusy);
-- Allow tampering with cursors
procedure Lock (T_Counts : in out Tamper_Counts);
pragma Inline (Lock);
-- Prohibit tampering with elements
procedure Unlock (T_Counts : in out Tamper_Counts);
pragma Inline (Unlock);
-- Allow tampering with elements
procedure TC_Check (T_Counts : Tamper_Counts);
pragma Inline (TC_Check);
-- Tampering-with-cursors check
procedure TE_Check (T_Counts : Tamper_Counts);
pragma Inline (TE_Check);
-- Tampering-with-elements check
-----------------
-- RAII Types --
-----------------
-- Initialize of With_Busy increments the Busy count, and Finalize
-- decrements it. Thus, to prohibit tampering with elements within a
-- given scope, declare an object of type With_Busy. The Busy count
-- will be correctly decremented in case of exception or abort.
-- With_Lock is the same as With_Busy, except it increments/decrements
-- BOTH Busy and Lock, thus prohibiting tampering with cursors.
type With_Busy (T_Counts : not null access Tamper_Counts) is
new Finalization.Limited_Controlled with null record
with Disable_Controlled => not T_Check;
overriding procedure Initialize (Busy : in out With_Busy);
overriding procedure Finalize (Busy : in out With_Busy);
type With_Lock (T_Counts : not null access Tamper_Counts) is
new Finalization.Limited_Controlled with null record
with Disable_Controlled => not T_Check;
overriding procedure Initialize (Lock : in out With_Lock);
overriding procedure Finalize (Lock : in out With_Lock);
-- Variables of type With_Busy and With_Lock are declared only for the
-- effects of Initialize and Finalize, so they are not referenced;
-- disable warnings about that. Note that all variables of these types
-- have names starting with "Busy" or "Lock". These pragmas need to be
-- present wherever these types are used.
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
end Generic_Implementation;
end Ada.Containers; end Ada.Containers;
gcc/ada/a-convec.adb
...@@ -36,29 +36,13 @@ package body Ada.Containers.Vectors is ...@@ -36,29 +36,13 @@ package body Ada.Containers.Vectors is
pragma Annotate (CodePeer, Skip_Analysis); pragma Annotate (CodePeer, Skip_Analysis);
pragma Warnings (Off, "variable ""Busy*"" is not referenced");
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
-- See comment in Ada.Containers
procedure Free is procedure Free is
new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
type Iterator is new Limited_Controlled and
Vector_Iterator_Interfaces.Reversible_Iterator with
record
Container : Vector_Access;
Index : Index_Type'Base;
end record;
overriding procedure Finalize (Object : in out Iterator);
overriding function First (Object : Iterator) return Cursor;
overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
Position : Cursor) return Cursor;
overriding function Previous
(Object : Iterator;
Position : Cursor) return Cursor;
procedure Append_Slow_Path procedure Append_Slow_Path
(Container : in out Vector; (Container : in out Vector;
New_Item : Element_Type; New_Item : Element_Type;
...@@ -70,273 +54,45 @@ package body Ada.Containers.Vectors is ...@@ -70,273 +54,45 @@ package body Ada.Containers.Vectors is
-- "&" -- -- "&" --
--------- ---------
function "&" (Left, Right : Vector) return Vector is -- We decide that the capacity of the result of "&" is the minimum needed
LN : constant Count_Type := Length (Left); -- -- the sum of the lengths of the vector parameters. We could decide to
RN : constant Count_Type := Length (Right); -- make it larger, but we have no basis for knowing how much larger, so we
N : Count_Type'Base; -- length of result -- just allocate the minimum amount of storage.
J : Count_Type'Base; -- for computing intermediate index values
Last : Index_Type'Base; -- Last index of result
function "&" (Left, Right : Vector) return Vector is
begin begin
-- We decide that the capacity of the result is the sum of the lengths return Result : Vector do
-- of the vector parameters. We could decide to make it larger, but we Reserve_Capacity (Result, Length (Left) + Length (Right));
-- have no basis for knowing how much larger, so we just allocate the Append (Result, Left);
-- minimum amount of storage. Append (Result, Right);
end return;
-- Here we handle the easy cases first, when one of the vector
-- parameters is empty. (We say "easy" because there's nothing to
-- compute, that can potentially overflow.)
if LN = 0 then
if RN = 0 then
return Empty_Vector;
end if;
declare
RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access :=
new Elements_Type'(Right.Last, RE);
begin
return (Controlled with Elements, Right.Last, others => <>);
end;
end if;
if RN = 0 then
declare
LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : constant Elements_Access :=
new Elements_Type'(Left.Last, LE);
begin
return (Controlled with Elements, Left.Last, others => <>);
end;
end if;
-- Neither of the vector parameters is empty, so must compute the length
-- of the result vector and its last index. (This is the harder case,
-- because our computations must avoid overflow.)
-- There are two constraints we need to satisfy. The first constraint is
-- that a container cannot have more than Count_Type'Last elements, so
-- we must check the sum of the combined lengths. Note that we cannot
-- simply add the lengths, because of the possibility of overflow.
if LN > Count_Type'Last - RN then
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.
N := LN + RN;
-- The second constraint is that the new Last index value cannot
-- exceed Index_Type'Last. We use the wider of Index_Type'Base and
-- Count_Type'Base as the type for intermediate values.
if Index_Type'Base'Last >= 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.
-- Last must satisfy this relation:
-- First + Length - 1 <= Last
-- We regroup terms:
-- First - 1 <= Last - Length
-- Which can rewrite as:
-- No_Index <= Last - Length
if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
raise Constraint_Error with "new length is out of range";
end if;
-- We now know that the computed value of Last is within the base
-- range of the type, so it is safe to compute its value:
Last := No_Index + Index_Type'Base (N);
-- Finally we test whether the value is within the range of the
-- generic actual index subtype:
if Last > Index_Type'Last then
raise Constraint_Error with "new length is out of range";
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.
J := Count_Type'Base (No_Index) + N; -- Last
if J > Count_Type'Base (Index_Type'Last) then
raise Constraint_Error with "new length is out of range";
end if;
-- We know that the computed value (having type Count_Type) of Last
-- is within the range of the generic actual index subtype, so it is
-- safe to convert to Index_Type:
Last := Index_Type'Base (J);
else
-- Here Index_Type'First (and Index_Type'Last) is positive, so we
-- must test the length indirectly (by working backwards from the
-- largest possible value of Last), in order to prevent overflow.
J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
if J < Count_Type'Base (No_Index) then
raise Constraint_Error with "new length is out of range";
end if;
-- We have determined that the result length would not create a Last
-- index value outside of the range of Index_Type, so we can now
-- safely compute its value.
Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
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);
Elements : constant Elements_Access :=
new Elements_Type'(Last, LE & RE);
begin
return (Controlled with Elements, Last, others => <>);
end;
end "&"; end "&";
function "&" (Left : Vector; Right : Element_Type) return Vector is function "&" (Left : Vector; Right : Element_Type) return Vector is
begin begin
-- We decide that the capacity of the result is the sum of the lengths return Result : Vector do
-- of the parameters. We could decide to make it larger, but we have no Reserve_Capacity (Result, Length (Left) + 1);
-- basis for knowing how much larger, so we just allocate the minimum Append (Result, Left);
-- amount of storage. Append (Result, Right);
end return;
-- Handle easy case first, when the vector parameter (Left) is empty
if Left.Is_Empty then
declare
Elements : constant Elements_Access :=
new Elements_Type'
(Last => Index_Type'First,
EA => (others => Right));
begin
return (Controlled with Elements, Index_Type'First, others => <>);
end;
end if;
-- The vector parameter is not empty, so we must compute the length of
-- the result vector and its last index, but in such a way that overflow
-- is avoided. We must satisfy two constraints: the new length cannot
-- exceed Count_Type'Last, and the new Last index cannot exceed
-- Index_Type'Last.
if Left.Length = Count_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
if Left.Last >= Index_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
declare
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);
begin
return (Controlled with Elements, Last, others => <>);
end;
end "&"; end "&";
function "&" (Left : Element_Type; Right : Vector) return Vector is function "&" (Left : Element_Type; Right : Vector) return Vector is
begin begin
-- We decide that the capacity of the result is the sum of the lengths return Result : Vector do
-- of the parameters. We could decide to make it larger, but we have no Reserve_Capacity (Result, 1 + Length (Right));
-- basis for knowing how much larger, so we just allocate the minimum Append (Result, Left);
-- amount of storage. Append (Result, Right);
end return;
-- Handle easy case first, when the vector parameter (Right) is empty
if Right.Is_Empty then
declare
Elements : constant Elements_Access :=
new Elements_Type'
(Last => Index_Type'First,
EA => (others => Left));
begin
return (Controlled with Elements, Index_Type'First, others => <>);
end;
end if;
-- The vector parameter is not empty, so we must compute the length of
-- the result vector and its last index, but in such a way that overflow
-- is avoided. We must satisfy two constraints: the new length cannot
-- exceed Count_Type'Last, and the new Last index cannot exceed
-- Index_Type'Last.
if Right.Length = Count_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
if Right.Last >= Index_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
declare
Last : constant Index_Type := Right.Last + 1;
RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access :=
new Elements_Type'
(Last => Last,
EA => Left & RE);
begin
return (Controlled with Elements, Last, others => <>);
end;
end "&"; end "&";
function "&" (Left, Right : Element_Type) return Vector is function "&" (Left, Right : Element_Type) return Vector is
begin begin
-- We decide that the capacity of the result is the sum of the lengths return Result : Vector do
-- of the parameters. We could decide to make it larger, but we have no Reserve_Capacity (Result, 1 + 1);
-- basis for knowing how much larger, so we just allocate the minimum Append (Result, Left);
-- amount of storage. Append (Result, Right);
end return;
-- We must compute the length of the result vector and its last index,
-- but in such a way that overflow is avoided. We must satisfy two
-- constraints: the new length cannot exceed Count_Type'Last (here, we
-- know that that condition is satisfied), and the new Last index cannot
-- exceed Index_Type'Last.
if Index_Type'First >= Index_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
declare
Last : constant Index_Type := Index_Type'First + 1;
Elements : constant Elements_Access :=
new Elements_Type'
(Last => Last,
EA => (Left, Right));
begin
return (Controlled with Elements, Last, others => <>);
end;
end "&"; end "&";
--------- ---------
...@@ -344,57 +100,20 @@ package body Ada.Containers.Vectors is ...@@ -344,57 +100,20 @@ 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
return True;
end if;
if Left.Last /= Right.Last then
return False;
end if;
-- Per AI05-0022, the container implementation is required to detect -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
BL := BL + 1; declare
LL := LL + 1; Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
BR := BR + 1; Left_Valid : Elements_Array renames
LR := LR + 1; Left.Elements.EA (Index_Type'First .. Left.Last);
Right_Valid : Elements_Array renames
Result := True; Right.Elements.EA (Index_Type'First .. Right.Last);
for J in Index_Type range Index_Type'First .. Left.Last loop begin
if Left.Elements.EA (J) /= Right.Elements.EA (J) then return Left_Valid = Right_Valid;
Result := False; end;
exit;
end if;
end loop;
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 "=";
------------ ------------
...@@ -415,8 +134,7 @@ package body Ada.Containers.Vectors is ...@@ -415,8 +134,7 @@ package body Ada.Containers.Vectors is
begin begin
Container.Elements := null; Container.Elements := null;
Container.Busy := 0; Zero_Counts (Container.TC);
Container.Lock := 0;
-- Note: it may seem that the following assignment to Container.Last -- Note: it may seem that the following assignment to Container.Last
-- is useless, since we assign it to L below. However this code is -- is useless, since we assign it to L below. However this code is
...@@ -429,20 +147,6 @@ package body Ada.Containers.Vectors is ...@@ -429,20 +147,6 @@ package body Ada.Containers.Vectors is
end; end;
end Adjust; end Adjust;
procedure Adjust (Control : in out Reference_Control_Type) is
begin
if Control.Container /= null then
declare
C : Vector renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B + 1;
L := L + 1;
end;
end if;
end Adjust;
------------ ------------
-- Append -- -- Append --
------------ ------------
...@@ -451,7 +155,7 @@ package body Ada.Containers.Vectors is ...@@ -451,7 +155,7 @@ package body Ada.Containers.Vectors is
begin begin
if Is_Empty (New_Item) then if Is_Empty (New_Item) then
return; return;
elsif Container.Last = Index_Type'Last then elsif Checks and then 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
Insert (Container, Container.Last + 1, New_Item); Insert (Container, Container.Last + 1, New_Item);
...@@ -472,10 +176,7 @@ package body Ada.Containers.Vectors is ...@@ -472,10 +176,7 @@ package body Ada.Containers.Vectors is
and then Container.Elements /= null and then Container.Elements /= null
and then Container.Last /= Container.Elements.Last and then Container.Last /= Container.Elements.Last
then then
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
-- Increment Container.Last after assigning the New_Item, so we -- Increment Container.Last after assigning the New_Item, so we
-- leave the Container unmodified in case Finalize/Adjust raises -- leave the Container unmodified in case Finalize/Adjust raises
...@@ -505,7 +206,7 @@ package body Ada.Containers.Vectors is ...@@ -505,7 +206,7 @@ package body Ada.Containers.Vectors is
begin begin
if Count = 0 then if Count = 0 then
return; return;
elsif Container.Last = Index_Type'Last then elsif Checks and then 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
Insert (Container, Container.Last + 1, New_Item, Count); Insert (Container, Container.Last + 1, New_Item, Count);
...@@ -545,12 +246,8 @@ package body Ada.Containers.Vectors is ...@@ -545,12 +246,8 @@ package body Ada.Containers.Vectors is
procedure Clear (Container : in out Vector) is procedure Clear (Container : in out Vector) is
begin begin
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with Container.Last := No_Index;
"attempt to tamper with cursors (vector is busy)";
else
Container.Last := No_Index;
end if;
end Clear; end Clear;
------------------------ ------------------------
...@@ -562,31 +259,37 @@ package body Ada.Containers.Vectors is ...@@ -562,31 +259,37 @@ package body Ada.Containers.Vectors is
Position : Cursor) return Constant_Reference_Type Position : Cursor) return Constant_Reference_Type
is is
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
end if; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then if 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; end if;
if Position.Index > Position.Container.Last then if Position.Index > Position.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;
end if; end if;
declare if T_Check then
C : Vector renames Position.Container.all; declare
B : Natural renames C.Busy; TC : constant Tamper_Counts_Access :=
L : Natural renames C.Lock; Container.TC'Unrestricted_Access;
begin begin
return R : constant Constant_Reference_Type :=
(Element => Container.Elements.EA (Position.Index)'Access,
Control => (Controlled with TC))
do
Lock (TC.all);
end return;
end;
else
return R : constant Constant_Reference_Type := return R : constant Constant_Reference_Type :=
(Element => Container.Elements.EA (Position.Index)'Access, (Element => Container.Elements.EA (Position.Index)'Access,
Control => (Controlled with Container'Unrestricted_Access)) Control => (Controlled with null));
do end if;
B := B + 1;
L := L + 1;
end return;
end;
end Constant_Reference; end Constant_Reference;
function Constant_Reference function Constant_Reference
...@@ -594,22 +297,26 @@ package body Ada.Containers.Vectors is ...@@ -594,22 +297,26 @@ package body Ada.Containers.Vectors is
Index : Index_Type) return Constant_Reference_Type Index : Index_Type) return Constant_Reference_Type
is is
begin begin
if Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
else end if;
if T_Check then
declare declare
C : Vector renames Container'Unrestricted_Access.all; TC : constant Tamper_Counts_Access :=
B : Natural renames C.Busy; Container.TC'Unrestricted_Access;
L : Natural renames C.Lock;
begin begin
return R : constant Constant_Reference_Type := return R : constant Constant_Reference_Type :=
(Element => Container.Elements.EA (Index)'Access, (Element => Container.Elements.EA (Index)'Access,
Control => (Controlled with Container'Unrestricted_Access)) Control => (Controlled with TC))
do do
B := B + 1; Lock (TC.all);
L := L + 1;
end return; end return;
end; end;
else
return R : constant Constant_Reference_Type :=
(Element => Container.Elements.EA (Index)'Access,
Control => (Controlled with null));
end if; end if;
end Constant_Reference; end Constant_Reference;
...@@ -642,7 +349,7 @@ package body Ada.Containers.Vectors is ...@@ -642,7 +349,7 @@ package body Ada.Containers.Vectors is
elsif Capacity >= Source.Length then elsif Capacity >= Source.Length then
C := Capacity; C := Capacity;
else elsif Checks then
raise Capacity_Error with raise Capacity_Error with
"Requested capacity is less than Source length"; "Requested capacity is less than Source length";
end if; end if;
...@@ -685,7 +392,7 @@ package body Ada.Containers.Vectors is ...@@ -685,7 +392,7 @@ package body Ada.Containers.Vectors is
-- in the base range that immediately precede and immediately follow the -- in the base range that immediately precede and immediately follow the
-- values in the Index_Type.) -- values in the Index_Type.)
if Index < Index_Type'First then if Checks and then Index < Index_Type'First then
raise Constraint_Error with "Index is out of range (too small)"; raise Constraint_Error with "Index is out of range (too small)";
end if; end if;
...@@ -697,7 +404,7 @@ package body Ada.Containers.Vectors is ...@@ -697,7 +404,7 @@ package body Ada.Containers.Vectors is
-- algorithm, so that case is treated as a proper error.) -- algorithm, so that case is treated as a proper error.)
if Index > Old_Last then if Index > Old_Last then
if Index > Old_Last + 1 then if Checks and then 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)";
else else
return; return;
...@@ -717,10 +424,7 @@ package body Ada.Containers.Vectors is ...@@ -717,10 +424,7 @@ package body Ada.Containers.Vectors is
-- the count on exit. Delete checks the count to determine whether it is -- the count on exit. Delete checks the count to determine whether it is
-- being called while the associated callback procedure is executing. -- being called while the associated callback procedure is executing.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
-- We first calculate what's available for deletion starting at -- We first calculate what's available for deletion starting at
-- Index. Here and elsewhere we use the wider of Index_Type'Base and -- Index. Here and elsewhere we use the wider of Index_Type'Base and
...@@ -778,22 +482,21 @@ package body Ada.Containers.Vectors is ...@@ -778,22 +482,21 @@ package body Ada.Containers.Vectors is
Position : in out Cursor; Position : in out Cursor;
Count : Count_Type := 1) Count : Count_Type := 1)
is is
pragma Warnings (Off, Position);
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
elsif Position.Index > Container.Last then elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position index is out of range"; raise Program_Error with "Position cursor denotes wrong container";
else elsif Position.Index > Container.Last then
Delete (Container, Position.Index, Count); raise Program_Error with "Position index is out of range";
Position := No_Element; end if;
end if; end if;
Delete (Container, Position.Index, Count);
Position := No_Element;
end Delete; end Delete;
------------------ ------------------
...@@ -842,10 +545,7 @@ package body Ada.Containers.Vectors is ...@@ -842,10 +545,7 @@ package body Ada.Containers.Vectors is
-- it is being called while the associated callback procedure is -- it is being called while the associated callback procedure is
-- executing. -- executing.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
-- There is no restriction on how large Count can be when deleting -- There is no restriction on how large Count can be when deleting
-- items. If it is equal or greater than the current length, then this -- items. If it is equal or greater than the current length, then this
...@@ -878,7 +578,7 @@ package body Ada.Containers.Vectors is ...@@ -878,7 +578,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type) return Element_Type Index : Index_Type) return Element_Type
is is
begin begin
if Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
else else
return Container.Elements.EA (Index); return Container.Elements.EA (Index);
...@@ -887,13 +587,15 @@ package body Ada.Containers.Vectors is ...@@ -887,13 +587,15 @@ package body Ada.Containers.Vectors is
function Element (Position : Cursor) return Element_Type is function Element (Position : Cursor) return Element_Type is
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
elsif Position.Index > Position.Container.Last then raise Constraint_Error with "Position cursor has no element";
raise Constraint_Error with "Position cursor is out of range"; elsif Position.Index > Position.Container.Last then
else raise Constraint_Error with "Position cursor is out of range";
return Position.Container.Elements.EA (Position.Index); end if;
end if; end if;
return Position.Container.Elements.EA (Position.Index);
end Element; end Element;
-------------- --------------
...@@ -909,32 +611,13 @@ package body Ada.Containers.Vectors is ...@@ -909,32 +611,13 @@ package body Ada.Containers.Vectors is
Free (X); Free (X);
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
end Finalize; end Finalize;
procedure Finalize (Object : in out Iterator) is procedure Finalize (Object : in out Iterator) is
B : Natural renames Object.Container.Busy; pragma Assert (T_Check); -- not called if check suppressed
begin
B := B - 1;
end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
begin begin
if Control.Container /= null then Unbusy (Object.Container.TC);
declare
C : Vector renames Control.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
B := B - 1;
L := L - 1;
end;
Control.Container := null;
end if;
end Finalize; end Finalize;
---------- ----------
...@@ -947,7 +630,7 @@ package body Ada.Containers.Vectors is ...@@ -947,7 +630,7 @@ package body Ada.Containers.Vectors is
Position : Cursor := No_Element) return Cursor Position : Cursor := No_Element) return Cursor
is is
begin begin
if Position.Container /= null then if Checks and then Position.Container /= null then
if Position.Container /= Container'Unrestricted_Access then if 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; end if;
...@@ -961,38 +644,15 @@ package body Ada.Containers.Vectors is ...@@ -961,38 +644,15 @@ package body Ada.Containers.Vectors is
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
declare declare
B : Natural renames Container'Unrestricted_Access.Busy; Lock : With_Lock (Container.TC'Unrestricted_Access);
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin 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
Result := J; return Cursor'(Container'Unrestricted_Access, J);
exit;
end if; end if;
end loop; end loop;
B := B - 1; return No_Element;
L := L - 1;
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;
end Find; end Find;
...@@ -1005,37 +665,18 @@ package body Ada.Containers.Vectors is ...@@ -1005,37 +665,18 @@ 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
-- Per AI05-0022, the container implementation is required to detect -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
B := B + 1; Lock : With_Lock (Container.TC'Unrestricted_Access);
L := L + 1; begin
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
Result := Indx; return Indx;
exit;
end if; end if;
end loop; end loop;
B := B - 1; return No_Index;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Find_Index; end Find_Index;
----------- -----------
...@@ -1080,7 +721,7 @@ package body Ada.Containers.Vectors is ...@@ -1080,7 +721,7 @@ package body Ada.Containers.Vectors is
function First_Element (Container : Vector) return Element_Type is function First_Element (Container : Vector) return Element_Type is
begin begin
if Container.Last = No_Index then if Checks and then Container.Last = No_Index then
raise Constraint_Error with "Container is empty"; raise Constraint_Error with "Container is empty";
else else
return Container.Elements.EA (Index_Type'First); return Container.Elements.EA (Index_Type'First);
...@@ -1117,36 +758,16 @@ package body Ada.Containers.Vectors is ...@@ -1117,36 +758,16 @@ package body Ada.Containers.Vectors is
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
declare declare
EA : Elements_Array renames Container.Elements.EA; Lock : With_Lock (Container.TC'Unrestricted_Access);
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
Result := False; return False;
exit;
end if; end if;
end loop; end loop;
B := B - 1; return True;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end; end;
end Is_Sorted; end Is_Sorted;
...@@ -1171,7 +792,7 @@ package body Ada.Containers.Vectors is ...@@ -1171,7 +792,7 @@ package body Ada.Containers.Vectors is
return; return;
end if; end if;
if Target'Address = Source'Address then if Checks and then Target'Address = Source'Address then
raise Program_Error with raise Program_Error with
"Target and Source denote same non-empty container"; "Target and Source denote same non-empty container";
end if; end if;
...@@ -1181,10 +802,7 @@ package body Ada.Containers.Vectors is ...@@ -1181,10 +802,7 @@ package body Ada.Containers.Vectors is
return; return;
end if; end if;
if Source.Busy > 0 then TC_Check (Source.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
Target.Set_Length (Length (Target) + Length (Source)); Target.Set_Length (Length (Target) + Length (Source));
...@@ -1195,19 +813,9 @@ package body Ada.Containers.Vectors is ...@@ -1195,19 +813,9 @@ package body Ada.Containers.Vectors is
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; Lock_Target : With_Lock (Target.TC'Unchecked_Access);
TL : Natural renames Target.Lock; Lock_Source : With_Lock (Source.TC'Unchecked_Access);
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
...@@ -1236,22 +844,6 @@ package body Ada.Containers.Vectors is ...@@ -1236,22 +844,6 @@ 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;
...@@ -1283,33 +875,15 @@ package body Ada.Containers.Vectors is ...@@ -1283,33 +875,15 @@ package body Ada.Containers.Vectors is
-- an artifact of our array-based implementation. Logically Sort -- an artifact of our array-based implementation. Logically Sort
-- requires a check for cursor tampering. -- requires a check for cursor tampering.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
-- Per AI05-0022, the container implementation is required to detect -- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
declare declare
B : Natural renames Container.Busy; Lock : With_Lock (Container.TC'Unchecked_Access);
L : Natural renames Container.Lock;
begin 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;
end Sort; end Sort;
...@@ -1358,31 +932,33 @@ package body Ada.Containers.Vectors is ...@@ -1358,31 +932,33 @@ package body Ada.Containers.Vectors is
Dst : Elements_Access; -- new, expanded internal array Dst : Elements_Access; -- new, expanded internal array
begin begin
-- As a precondition on the generic actual Index_Type, the base type if Checks then
-- must include Index_Type'Pred (Index_Type'First); this is the value -- As a precondition on the generic actual Index_Type, the base type
-- that Container.Last assumes when the vector is empty. However, we do -- must include Index_Type'Pred (Index_Type'First); this is the value
-- not allow that as the value for Index when specifying where the new -- that Container.Last assumes when the vector is empty. However, we
-- items should be inserted, so we must manually check. (That the user -- do not allow that as the value for Index when specifying where the
-- is allowed to specify the value at all here is a consequence of the -- new items should be inserted, so we must manually check. (That the
-- declaration of the Extended_Index subtype, which includes the values -- user is allowed to specify the value at all here is a consequence
-- in the base range that immediately precede and immediately follow the -- of the declaration of the Extended_Index subtype, which includes
-- values in the Index_Type.) -- the values in the base range that immediately precede and
-- immediately follow the values in the Index_Type.)
if Before < Index_Type'First then if Before < Index_Type'First then
raise Constraint_Error with raise Constraint_Error with
"Before index is out of range (too small)"; "Before index is out of range (too small)";
end if; end if;
-- We do allow a value greater than Container.Last to be specified as -- We do allow a value greater than Container.Last to be specified as
-- the Index, but only if it's immediately greater. This allows for the -- the Index, but only if it's immediately greater. This allows for
-- case of appending items to the back end of the vector. (It is assumed -- the case of appending items to the back end of the vector. (It is
-- that specifying an index value greater than Last + 1 indicates some -- assumed that specifying an index value greater than Last + 1
-- deeper flaw in the caller's algorithm, so that case is treated as a -- indicates some deeper flaw in the caller's algorithm, so that case
-- proper error.) -- is treated as a proper error.)
if Before > Container.Last + 1 then if 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; end if;
-- We treat inserting 0 items into the container as a no-op, even when -- We treat inserting 0 items into the container as a no-op, even when
...@@ -1398,7 +974,7 @@ package body Ada.Containers.Vectors is ...@@ -1398,7 +974,7 @@ package body Ada.Containers.Vectors is
-- Note: we cannot simply add these values, because of the possibility -- Note: we cannot simply add these values, because of the possibility
-- of overflow. -- of overflow.
if Old_Length > Count_Type'Last - Count then if Checks and then Old_Length > Count_Type'Last - Count then
raise Constraint_Error with "Count is out of range"; raise Constraint_Error with "Count is out of range";
end if; end if;
...@@ -1506,7 +1082,7 @@ package body Ada.Containers.Vectors is ...@@ -1506,7 +1082,7 @@ package body Ada.Containers.Vectors is
-- an internal array with a last index value greater than -- an internal array with a last index value greater than
-- Index_Type'Last, with no way to index those elements). -- Index_Type'Last, with no way to index those elements).
if New_Length > Max_Length then if Checks and then New_Length > Max_Length then
raise Constraint_Error with "Count is out of range"; raise Constraint_Error with "Count is out of range";
end if; end if;
...@@ -1551,10 +1127,7 @@ package body Ada.Containers.Vectors is ...@@ -1551,10 +1127,7 @@ package body Ada.Containers.Vectors is
-- exit. Insert checks the count to determine whether it is being called -- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing. -- while the associated callback procedure is executing.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
-- An internal array has already been allocated, so we must determine -- An internal array has already been allocated, so we must determine
-- whether there is enough unused storage for the new items. -- whether there is enough unused storage for the new items.
...@@ -1828,7 +1401,7 @@ package body Ada.Containers.Vectors is ...@@ -1828,7 +1401,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Before.Container /= null if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access and then Before.Container /= Container'Unrestricted_Access
then then
raise Program_Error with "Before cursor denotes wrong container"; raise Program_Error with "Before cursor denotes wrong container";
...@@ -1839,7 +1412,7 @@ package body Ada.Containers.Vectors is ...@@ -1839,7 +1412,7 @@ package body Ada.Containers.Vectors is
end if; 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 if Checks and then 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";
end if; end if;
...@@ -1862,7 +1435,7 @@ package body Ada.Containers.Vectors is ...@@ -1862,7 +1435,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Before.Container /= null if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access and then Before.Container /= Container'Unrestricted_Access
then then
raise Program_Error with "Before cursor denotes wrong container"; raise Program_Error with "Before cursor denotes wrong container";
...@@ -1879,7 +1452,7 @@ package body Ada.Containers.Vectors is ...@@ -1879,7 +1452,7 @@ package body Ada.Containers.Vectors is
end if; 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 if Checks and then 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";
end if; end if;
...@@ -1904,7 +1477,7 @@ package body Ada.Containers.Vectors is ...@@ -1904,7 +1477,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Before.Container /= null if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access and then Before.Container /= Container'Unrestricted_Access
then then
raise Program_Error with "Before cursor denotes wrong container"; raise Program_Error with "Before cursor denotes wrong container";
...@@ -1915,7 +1488,7 @@ package body Ada.Containers.Vectors is ...@@ -1915,7 +1488,7 @@ package body Ada.Containers.Vectors is
end if; 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 if Checks and then 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";
else else
...@@ -1939,7 +1512,7 @@ package body Ada.Containers.Vectors is ...@@ -1939,7 +1512,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Before.Container /= null if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access and then Before.Container /= Container'Unrestricted_Access
then then
raise Program_Error with "Before cursor denotes wrong container"; raise Program_Error with "Before cursor denotes wrong container";
...@@ -1956,7 +1529,7 @@ package body Ada.Containers.Vectors is ...@@ -1956,7 +1529,7 @@ package body Ada.Containers.Vectors is
end if; 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 if Checks and then 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";
end if; end if;
...@@ -2019,31 +1592,33 @@ package body Ada.Containers.Vectors is ...@@ -2019,31 +1592,33 @@ package body Ada.Containers.Vectors is
Dst : Elements_Access; -- new, expanded internal array Dst : Elements_Access; -- new, expanded internal array
begin begin
-- As a precondition on the generic actual Index_Type, the base type if Checks then
-- must include Index_Type'Pred (Index_Type'First); this is the value -- As a precondition on the generic actual Index_Type, the base type
-- that Container.Last assumes when the vector is empty. However, we do -- must include Index_Type'Pred (Index_Type'First); this is the value
-- not allow that as the value for Index when specifying where the new -- that Container.Last assumes when the vector is empty. However, we
-- items should be inserted, so we must manually check. (That the user -- do not allow that as the value for Index when specifying where the
-- is allowed to specify the value at all here is a consequence of the -- new items should be inserted, so we must manually check. (That the
-- declaration of the Extended_Index subtype, which includes the values -- user is allowed to specify the value at all here is a consequence
-- in the base range that immediately precede and immediately follow the -- of the declaration of the Extended_Index subtype, which includes
-- values in the Index_Type.) -- the values in the base range that immediately precede and
-- immediately follow the values in the Index_Type.)
if Before < Index_Type'First then if Before < Index_Type'First then
raise Constraint_Error with raise Constraint_Error with
"Before index is out of range (too small)"; "Before index is out of range (too small)";
end if; end if;
-- We do allow a value greater than Container.Last to be specified as -- We do allow a value greater than Container.Last to be specified as
-- the Index, but only if it's immediately greater. This allows for the -- the Index, but only if it's immediately greater. This allows for
-- case of appending items to the back end of the vector. (It is assumed -- the case of appending items to the back end of the vector. (It is
-- that specifying an index value greater than Last + 1 indicates some -- assumed that specifying an index value greater than Last + 1
-- deeper flaw in the caller's algorithm, so that case is treated as a -- indicates some deeper flaw in the caller's algorithm, so that case
-- proper error.) -- is treated as a proper error.)
if Before > Container.Last + 1 then if 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; end if;
-- We treat inserting 0 items into the container as a no-op, even when -- We treat inserting 0 items into the container as a no-op, even when
...@@ -2059,7 +1634,7 @@ package body Ada.Containers.Vectors is ...@@ -2059,7 +1634,7 @@ package body Ada.Containers.Vectors is
-- Note: we cannot simply add these values, because of the possibility -- Note: we cannot simply add these values, because of the possibility
-- of overflow. -- of overflow.
if Old_Length > Count_Type'Last - Count then if Checks and then Old_Length > Count_Type'Last - Count then
raise Constraint_Error with "Count is out of range"; raise Constraint_Error with "Count is out of range";
end if; end if;
...@@ -2167,7 +1742,7 @@ package body Ada.Containers.Vectors is ...@@ -2167,7 +1742,7 @@ package body Ada.Containers.Vectors is
-- an internal array with a last index value greater than -- an internal array with a last index value greater than
-- Index_Type'Last, with no way to index those elements). -- Index_Type'Last, with no way to index those elements).
if New_Length > Max_Length then if Checks and then New_Length > Max_Length then
raise Constraint_Error with "Count is out of range"; raise Constraint_Error with "Count is out of range";
end if; end if;
...@@ -2211,10 +1786,7 @@ package body Ada.Containers.Vectors is ...@@ -2211,10 +1786,7 @@ package body Ada.Containers.Vectors is
-- exit. Insert checks the count to determine whether it is being called -- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing. -- while the associated callback procedure is executing.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
-- An internal array has already been allocated, so we must determine -- An internal array has already been allocated, so we must determine
-- whether there is enough unused storage for the new items. -- whether there is enough unused storage for the new items.
...@@ -2360,7 +1932,7 @@ package body Ada.Containers.Vectors is ...@@ -2360,7 +1932,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Before.Container /= null if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access and then Before.Container /= Container'Unrestricted_Access
then then
raise Program_Error with "Before cursor denotes wrong container"; raise Program_Error with "Before cursor denotes wrong container";
...@@ -2377,7 +1949,7 @@ package body Ada.Containers.Vectors is ...@@ -2377,7 +1949,7 @@ package body Ada.Containers.Vectors is
end if; 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 if Checks and then 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";
else else
...@@ -2410,22 +1982,11 @@ package body Ada.Containers.Vectors is ...@@ -2410,22 +1982,11 @@ package body Ada.Containers.Vectors is
(Container : Vector; (Container : Vector;
Process : not null access procedure (Position : Cursor)) Process : not null access procedure (Position : Cursor))
is is
B : Natural renames Container'Unrestricted_Access.all.Busy; Busy : With_Busy (Container.TC'Unrestricted_Access);
begin begin
B := B + 1; for Indx in Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
begin end loop;
for Indx in Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Iterate; end Iterate;
function Iterate function Iterate
...@@ -2433,8 +1994,6 @@ package body Ada.Containers.Vectors is ...@@ -2433,8 +1994,6 @@ package body Ada.Containers.Vectors is
return Vector_Iterator_Interfaces.Reversible_Iterator'Class return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is is
V : constant Vector_Access := Container'Unrestricted_Access; V : constant Vector_Access := Container'Unrestricted_Access;
B : Natural renames V.Busy;
begin begin
-- The value of its Index component influences the behavior of the First -- The value of its Index component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Index -- and Last selector functions of the iterator object. When the Index
...@@ -2451,7 +2010,7 @@ package body Ada.Containers.Vectors is ...@@ -2451,7 +2010,7 @@ package body Ada.Containers.Vectors is
Container => V, Container => V,
Index => No_Index) Index => No_Index)
do do
B := B + 1; Busy (Container.TC'Unrestricted_Access.all);
end return; end return;
end Iterate; end Iterate;
...@@ -2461,8 +2020,6 @@ package body Ada.Containers.Vectors is ...@@ -2461,8 +2020,6 @@ package body Ada.Containers.Vectors is
return Vector_Iterator_Interfaces.Reversible_Iterator'class return Vector_Iterator_Interfaces.Reversible_Iterator'class
is is
V : constant Vector_Access := Container'Unrestricted_Access; V : constant Vector_Access := Container'Unrestricted_Access;
B : Natural renames V.Busy;
begin begin
-- It was formerly the case that when Start = No_Element, the partial -- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator, -- iterator was defined to behave the same as for a complete iterator,
...@@ -2475,19 +2032,21 @@ package body Ada.Containers.Vectors is ...@@ -2475,19 +2032,21 @@ package body Ada.Containers.Vectors is
-- however, that it is not possible to use a partial iterator to specify -- however, that it is not possible to use a partial iterator to specify
-- an empty sequence of items. -- an empty sequence of items.
if Start.Container = null then if Checks then
raise Constraint_Error with if Start.Container = null then
"Start position for iterator equals No_Element"; raise Constraint_Error with
end if; "Start position for iterator equals No_Element";
end if;
if Start.Container /= V then if Start.Container /= V then
raise Program_Error with raise Program_Error with
"Start cursor of Iterate designates wrong vector"; "Start cursor of Iterate designates wrong vector";
end if; end if;
if Start.Index > V.Last then if Start.Index > V.Last then
raise Constraint_Error with raise Constraint_Error with
"Start position for iterator equals No_Element"; "Start position for iterator equals No_Element";
end if;
end if; end if;
-- The value of its Index component influences the behavior of the First -- The value of its Index component influences the behavior of the First
...@@ -2504,7 +2063,7 @@ package body Ada.Containers.Vectors is ...@@ -2504,7 +2063,7 @@ package body Ada.Containers.Vectors is
Container => V, Container => V,
Index => Start.Index) Index => Start.Index)
do do
B := B + 1; Busy (Container.TC'Unrestricted_Access.all);
end return; end return;
end Iterate; end Iterate;
...@@ -2549,7 +2108,7 @@ package body Ada.Containers.Vectors is ...@@ -2549,7 +2108,7 @@ package body Ada.Containers.Vectors is
function Last_Element (Container : Vector) return Element_Type is function Last_Element (Container : Vector) return Element_Type is
begin begin
if Container.Last = No_Index then if Checks and then Container.Last = No_Index then
raise Constraint_Error with "Container is empty"; raise Constraint_Error with "Container is empty";
else else
return Container.Elements.EA (Container.Last); return Container.Elements.EA (Container.Last);
...@@ -2612,15 +2171,8 @@ package body Ada.Containers.Vectors is ...@@ -2612,15 +2171,8 @@ package body Ada.Containers.Vectors is
return; return;
end if; end if;
if Target.Busy > 0 then TC_Check (Target.TC);
raise Program_Error with TC_Check (Source.TC);
"attempt to tamper with cursors (Target is busy)";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (Source is busy)";
end if;
declare declare
Target_Elements : constant Elements_Access := Target.Elements; Target_Elements : constant Elements_Access := Target.Elements;
...@@ -2652,7 +2204,7 @@ package body Ada.Containers.Vectors is ...@@ -2652,7 +2204,7 @@ package body Ada.Containers.Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
elsif Position.Container /= Object.Container then elsif Checks and then 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";
else else
...@@ -2708,7 +2260,7 @@ package body Ada.Containers.Vectors is ...@@ -2708,7 +2260,7 @@ package body Ada.Containers.Vectors is
begin begin
if Position.Container = null then if Position.Container = null then
return No_Element; return No_Element;
elsif Position.Container /= Object.Container then elsif Checks and then 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";
else else
...@@ -2734,15 +2286,10 @@ package body Ada.Containers.Vectors is ...@@ -2734,15 +2286,10 @@ package body Ada.Containers.Vectors is
function Pseudo_Reference function Pseudo_Reference
(Container : aliased Vector'Class) return Reference_Control_Type (Container : aliased Vector'Class) return Reference_Control_Type
is is
C : constant Vector_Access := Container'Unrestricted_Access; TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin begin
return R : constant Reference_Control_Type := return R : constant Reference_Control_Type := (Controlled with TC) do
(Controlled with C) Lock (TC.all);
do
B := B + 1;
L := L + 1;
end return; end return;
end Pseudo_Reference; end Pseudo_Reference;
...@@ -2755,29 +2302,15 @@ package body Ada.Containers.Vectors is ...@@ -2755,29 +2302,15 @@ package body Ada.Containers.Vectors is
Index : Index_Type; Index : Index_Type;
Process : not null access procedure (Element : Element_Type)) Process : not null access procedure (Element : Element_Type))
is is
Lock : With_Lock (Container.TC'Unrestricted_Access);
V : Vector renames Container'Unrestricted_Access.all; V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
L : Natural renames V.Lock;
begin begin
if Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
end if; end if;
B := B + 1; Process (V.Elements.EA (Index));
L := L + 1;
begin
Process (V.Elements.EA (Index));
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end Query_Element; end Query_Element;
procedure Query_Element procedure Query_Element
...@@ -2785,7 +2318,7 @@ package body Ada.Containers.Vectors is ...@@ -2785,7 +2318,7 @@ package body Ada.Containers.Vectors is
Process : not null access procedure (Element : Element_Type)) Process : not null access procedure (Element : Element_Type))
is is
begin begin
if Position.Container = null then if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
else else
Query_Element (Position.Container.all, Position.Index, Process); Query_Element (Position.Container.all, Position.Index, Process);
...@@ -2852,31 +2385,37 @@ package body Ada.Containers.Vectors is ...@@ -2852,31 +2385,37 @@ package body Ada.Containers.Vectors is
Position : Cursor) return Reference_Type Position : Cursor) return Reference_Type
is is
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
end if; raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then if 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; end if;
if Position.Index > Position.Container.Last then if Position.Index > Position.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;
end if; end if;
declare if T_Check then
C : Vector renames Position.Container.all; declare
B : Natural renames C.Busy; TC : constant Tamper_Counts_Access :=
L : Natural renames C.Lock; Container.TC'Unrestricted_Access;
begin begin
return R : constant Reference_Type :=
(Element => Container.Elements.EA (Position.Index)'Access,
Control => (Controlled with TC))
do
Lock (TC.all);
end return;
end;
else
return R : constant Reference_Type := return R : constant Reference_Type :=
(Element => Container.Elements.EA (Position.Index)'Access, (Element => Container.Elements.EA (Position.Index)'Access,
Control => (Controlled with Position.Container)) Control => (Controlled with null));
do end if;
B := B + 1;
L := L + 1;
end return;
end;
end Reference; end Reference;
function Reference function Reference
...@@ -2884,23 +2423,26 @@ package body Ada.Containers.Vectors is ...@@ -2884,23 +2423,26 @@ package body Ada.Containers.Vectors is
Index : Index_Type) return Reference_Type Index : Index_Type) return Reference_Type
is is
begin begin
if Index > Container.Last then if Checks and then 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 if T_Check then
declare declare
C : Vector renames Container'Unrestricted_Access.all; TC : constant Tamper_Counts_Access :=
B : Natural renames C.Busy; Container.TC'Unrestricted_Access;
L : Natural renames C.Lock;
begin begin
return R : constant Reference_Type := return R : constant Reference_Type :=
(Element => Container.Elements.EA (Index)'Access, (Element => Container.Elements.EA (Index)'Access,
Control => (Controlled with Container'Unrestricted_Access)) Control => (Controlled with TC))
do do
B := B + 1; Lock (TC.all);
L := L + 1;
end return; end return;
end; end;
else
return R : constant Reference_Type :=
(Element => Container.Elements.EA (Index)'Access,
Control => (Controlled with null));
end if; end if;
end Reference; end Reference;
...@@ -2914,14 +2456,12 @@ package body Ada.Containers.Vectors is ...@@ -2914,14 +2456,12 @@ package body Ada.Containers.Vectors is
New_Item : Element_Type) New_Item : Element_Type)
is is
begin begin
if Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
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; end if;
TE_Check (Container.TC);
Container.Elements.EA (Index) := New_Item;
end Replace_Element; end Replace_Element;
procedure Replace_Element procedure Replace_Element
...@@ -2930,23 +2470,20 @@ package body Ada.Containers.Vectors is ...@@ -2930,23 +2470,20 @@ package body Ada.Containers.Vectors is
New_Item : Element_Type) New_Item : Element_Type)
is is
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
elsif 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";
elsif Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range";
else elsif Position.Index > Container.Last then
if Container.Lock > 0 then raise Constraint_Error with "Position cursor is out of range";
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if; end if;
Container.Elements.EA (Position.Index) := New_Item;
end if; end if;
TE_Check (Container.TC);
Container.Elements.EA (Position.Index) := New_Item;
end Replace_Element; end Replace_Element;
---------------------- ----------------------
...@@ -3008,10 +2545,7 @@ package body Ada.Containers.Vectors is ...@@ -3008,10 +2545,7 @@ package body Ada.Containers.Vectors is
-- so this is the best we can do with respect to minimizing -- so this is the best we can do with respect to minimizing
-- storage). -- storage).
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
declare declare
subtype Src_Index_Subtype is Index_Type'Base range subtype Src_Index_Subtype is Index_Type'Base range
...@@ -3068,7 +2602,9 @@ package body Ada.Containers.Vectors is ...@@ -3068,7 +2602,9 @@ package body Ada.Containers.Vectors is
-- Which can rewrite as: -- Which can rewrite as:
-- No_Index <= Last - Length -- No_Index <= Last - Length
if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then if Checks and then
Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index
then
raise Constraint_Error with "Capacity is out of range"; raise Constraint_Error with "Capacity is out of range";
end if; end if;
...@@ -3080,7 +2616,7 @@ package body Ada.Containers.Vectors is ...@@ -3080,7 +2616,7 @@ package body Ada.Containers.Vectors is
-- Finally we test whether the value is within the range of the -- Finally we test whether the value is within the range of the
-- generic actual index subtype: -- generic actual index subtype:
if Last > Index_Type'Last then if Checks and then Last > Index_Type'Last then
raise Constraint_Error with "Capacity is out of range"; raise Constraint_Error with "Capacity is out of range";
end if; end if;
...@@ -3092,7 +2628,7 @@ package body Ada.Containers.Vectors is ...@@ -3092,7 +2628,7 @@ package body Ada.Containers.Vectors is
Index := Count_Type'Base (No_Index) + Capacity; -- Last Index := Count_Type'Base (No_Index) + Capacity; -- Last
if Index > Count_Type'Base (Index_Type'Last) then if Checks and then Index > Count_Type'Base (Index_Type'Last) then
raise Constraint_Error with "Capacity is out of range"; raise Constraint_Error with "Capacity is out of range";
end if; end if;
...@@ -3109,7 +2645,7 @@ package body Ada.Containers.Vectors is ...@@ -3109,7 +2645,7 @@ package body Ada.Containers.Vectors is
Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
if Index < Count_Type'Base (No_Index) then if Checks and then Index < Count_Type'Base (No_Index) then
raise Constraint_Error with "Capacity is out of range"; raise Constraint_Error with "Capacity is out of range";
end if; end if;
...@@ -3148,10 +2684,7 @@ package body Ada.Containers.Vectors is ...@@ -3148,10 +2684,7 @@ package body Ada.Containers.Vectors is
-- new internal array having a length that exactly matches the -- new internal array having a length that exactly matches the
-- number of items in the container. -- number of items in the container.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
declare declare
subtype Src_Index_Subtype is Index_Type'Base range subtype Src_Index_Subtype is Index_Type'Base range
...@@ -3208,10 +2741,7 @@ package body Ada.Containers.Vectors is ...@@ -3208,10 +2741,7 @@ package body Ada.Containers.Vectors is
-- number of active elements in the container.) We must check whether -- number of active elements in the container.) We must check whether
-- the container is busy before doing anything else. -- the container is busy before doing anything else.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
-- We now allocate a new internal array, having a length different from -- We now allocate a new internal array, having a length different from
-- its current value. -- its current value.
...@@ -3283,10 +2813,7 @@ package body Ada.Containers.Vectors is ...@@ -3283,10 +2813,7 @@ package body Ada.Containers.Vectors is
-- implementation. Logically Reverse_Elements requires a check for -- implementation. Logically Reverse_Elements requires a check for
-- cursor tampering. -- cursor tampering.
if Container.Busy > 0 then TC_Check (Container.TC);
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
declare declare
K : Index_Type; K : Index_Type;
...@@ -3322,7 +2849,7 @@ package body Ada.Containers.Vectors is ...@@ -3322,7 +2849,7 @@ package body Ada.Containers.Vectors is
Last : Index_Type'Base; Last : Index_Type'Base;
begin begin
if Position.Container /= null if Checks and then Position.Container /= null
and then Position.Container /= Container'Unrestricted_Access and then Position.Container /= Container'Unrestricted_Access
then then
raise Program_Error with "Position cursor denotes wrong container"; raise Program_Error with "Position cursor denotes wrong container";
...@@ -3337,38 +2864,15 @@ package body Ada.Containers.Vectors is ...@@ -3337,38 +2864,15 @@ package body Ada.Containers.Vectors is
-- element tampering by a generic actual subprogram. -- element tampering by a generic actual subprogram.
declare declare
B : Natural renames Container'Unrestricted_Access.Busy; Lock : With_Lock (Container.TC'Unrestricted_Access);
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin 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
Result := Indx; return Cursor'(Container'Unrestricted_Access, Indx);
exit;
end if; end if;
end loop; end loop;
B := B - 1; return No_Element;
L := L - 1;
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;
end Reverse_Find; end Reverse_Find;
...@@ -3381,67 +2885,36 @@ package body Ada.Containers.Vectors is ...@@ -3381,67 +2885,36 @@ 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; -- Per AI05-0022, the container implementation is required to detect
L : Natural renames Container'Unrestricted_Access.Lock; -- element tampering by a generic actual subprogram.
Lock : With_Lock (Container.TC'Unrestricted_Access);
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
Result := Indx; return Indx;
exit;
end if; end if;
end loop; end loop;
B := B - 1; return No_Index;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end Reverse_Find_Index; end Reverse_Find_Index;
--------------------- ---------------------
-- Reverse_Iterate -- -- Reverse_Iterate --
--------------------- ---------------------
procedure Reverse_Iterate procedure Reverse_Iterate
(Container : Vector; (Container : Vector;
Process : not null access procedure (Position : Cursor)) Process : not null access procedure (Position : Cursor))
is is
V : Vector renames Container'Unrestricted_Access.all; Busy : With_Busy (Container.TC'Unrestricted_Access);
B : Natural renames V.Busy;
begin begin
B := B + 1; for Indx in reverse Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
begin end loop;
for Indx in reverse Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Reverse_Iterate; end Reverse_Iterate;
---------------- ----------------
...@@ -3462,7 +2935,7 @@ package body Ada.Containers.Vectors is ...@@ -3462,7 +2935,7 @@ package body Ada.Containers.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 Checks and then 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
...@@ -3476,22 +2949,21 @@ package body Ada.Containers.Vectors is ...@@ -3476,22 +2949,21 @@ package body Ada.Containers.Vectors is
procedure Swap (Container : in out Vector; I, J : Index_Type) is procedure Swap (Container : in out Vector; I, J : Index_Type) is
begin begin
if I > Container.Last then if Checks then
raise Constraint_Error with "I index is out of range"; if I > Container.Last then
end if; raise Constraint_Error with "I index is out of range";
end if;
if J > Container.Last then if J > Container.Last then
raise Constraint_Error with "J index is out of range"; raise Constraint_Error with "J index is out of range";
end if;
end if; end if;
if I = J then if I = J then
return; return;
end if; end if;
if Container.Lock > 0 then TE_Check (Container.TC);
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
declare declare
EI_Copy : constant Element_Type := Container.Elements.EA (I); EI_Copy : constant Element_Type := Container.Elements.EA (I);
...@@ -3503,21 +2975,22 @@ package body Ada.Containers.Vectors is ...@@ -3503,21 +2975,22 @@ package body Ada.Containers.Vectors is
procedure Swap (Container : in out Vector; I, J : Cursor) is procedure Swap (Container : in out Vector; I, J : Cursor) is
begin begin
if I.Container = null then if Checks then
raise Constraint_Error with "I cursor has no element"; if I.Container = null then
raise Constraint_Error with "I cursor has no element";
elsif 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";
elsif 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";
elsif 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);
end if; end if;
Swap (Container, I.Index, J.Index);
end Swap; end Swap;
--------------- ---------------
...@@ -3585,7 +3058,9 @@ package body Ada.Containers.Vectors is ...@@ -3585,7 +3058,9 @@ package body Ada.Containers.Vectors is
-- Which can rewrite as: -- Which can rewrite as:
-- No_Index <= Last - Length -- No_Index <= Last - Length
if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then if Checks and then
Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -3597,7 +3072,7 @@ package body Ada.Containers.Vectors is ...@@ -3597,7 +3072,7 @@ package body Ada.Containers.Vectors is
-- Finally we test whether the value is within the range of the -- Finally we test whether the value is within the range of the
-- generic actual index subtype: -- generic actual index subtype:
if Last > Index_Type'Last then if Checks and then Last > Index_Type'Last then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -3609,7 +3084,7 @@ package body Ada.Containers.Vectors is ...@@ -3609,7 +3084,7 @@ package body Ada.Containers.Vectors is
Index := Count_Type'Base (No_Index) + Length; -- Last Index := Count_Type'Base (No_Index) + Length; -- Last
if Index > Count_Type'Base (Index_Type'Last) then if Checks and then Index > Count_Type'Base (Index_Type'Last) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -3626,7 +3101,7 @@ package body Ada.Containers.Vectors is ...@@ -3626,7 +3101,7 @@ package body Ada.Containers.Vectors is
Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
if Index < Count_Type'Base (No_Index) then if Checks and then Index < Count_Type'Base (No_Index) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -3675,7 +3150,9 @@ package body Ada.Containers.Vectors is ...@@ -3675,7 +3150,9 @@ package body Ada.Containers.Vectors is
-- Which can rewrite as: -- Which can rewrite as:
-- No_Index <= Last - Length -- No_Index <= Last - Length
if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then if Checks and then
Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -3687,7 +3164,7 @@ package body Ada.Containers.Vectors is ...@@ -3687,7 +3164,7 @@ package body Ada.Containers.Vectors is
-- Finally we test whether the value is within the range of the -- Finally we test whether the value is within the range of the
-- generic actual index subtype: -- generic actual index subtype:
if Last > Index_Type'Last then if Checks and then Last > Index_Type'Last then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -3699,7 +3176,7 @@ package body Ada.Containers.Vectors is ...@@ -3699,7 +3176,7 @@ package body Ada.Containers.Vectors is
Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last
if Index > Count_Type'Base (Index_Type'Last) then if Checks and then Index > Count_Type'Base (Index_Type'Last) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -3716,7 +3193,7 @@ package body Ada.Containers.Vectors is ...@@ -3716,7 +3193,7 @@ package body Ada.Containers.Vectors is
Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
if Index < Count_Type'Base (No_Index) then if Checks and then Index < Count_Type'Base (No_Index) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
...@@ -3741,28 +3218,13 @@ package body Ada.Containers.Vectors is ...@@ -3741,28 +3218,13 @@ package body Ada.Containers.Vectors is
Index : Index_Type; Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type)) Process : not null access procedure (Element : in out Element_Type))
is is
B : Natural renames Container.Busy; Lock : With_Lock (Container.TC'Unchecked_Access);
L : Natural renames Container.Lock;
begin begin
if Index > Container.Last then if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range"; raise Constraint_Error with "Index is out of range";
end if; end if;
B := B + 1; Process (Container.Elements.EA (Index));
L := L + 1;
begin
Process (Container.Elements.EA (Index));
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end Update_Element; end Update_Element;
procedure Update_Element procedure Update_Element
...@@ -3771,13 +3233,15 @@ package body Ada.Containers.Vectors is ...@@ -3771,13 +3233,15 @@ package body Ada.Containers.Vectors is
Process : not null access procedure (Element : in out Element_Type)) Process : not null access procedure (Element : in out Element_Type))
is is
begin begin
if Position.Container = null then if Checks then
raise Constraint_Error with "Position cursor has no element"; if Position.Container = null then
elsif Position.Container /= Container'Unrestricted_Access then raise Constraint_Error with "Position cursor has no element";
raise Program_Error with "Position cursor denotes wrong container"; elsif Position.Container /= Container'Unrestricted_Access then
else raise Program_Error with "Position cursor denotes wrong container";
Update_Element (Container, Position.Index, Process); end if;
end if; end if;
Update_Element (Container, Position.Index, Process);
end Update_Element; end Update_Element;
----------- -----------
......
gcc/ada/a-convec.ads
...@@ -366,8 +366,10 @@ private ...@@ -366,8 +366,10 @@ private
pragma Inline (Next); pragma Inline (Next);
pragma Inline (Previous); pragma Inline (Previous);
package Implementation is new Generic_Implementation;
use Implementation;
type Elements_Array is array (Index_Type range <>) of aliased Element_Type; type Elements_Array is array (Index_Type range <>) of aliased Element_Type;
function "=" (L, R : Elements_Array) return Boolean is abstract;
type Elements_Type (Last : Extended_Index) is limited record type Elements_Type (Last : Extended_Index) is limited record
EA : Elements_Array (Index_Type'First .. Last); EA : Elements_Array (Index_Type'First .. Last);
...@@ -375,14 +377,13 @@ private ...@@ -375,14 +377,13 @@ private
type Elements_Access is access all Elements_Type; type Elements_Access is access all Elements_Type;
use Ada.Finalization; use Finalization;
use Ada.Streams; use Streams;
type Vector is new Controlled with record type Vector is new Controlled with record
Elements : Elements_Access := null; Elements : Elements_Access := null;
Last : Extended_Index := No_Index; Last : Extended_Index := No_Index;
Busy : Natural := 0; TC : aliased Tamper_Counts;
Lock : Natural := 0;
end record; end record;
overriding procedure Adjust (Container : in out Vector); overriding procedure Adjust (Container : in out Vector);
...@@ -420,16 +421,8 @@ private ...@@ -420,16 +421,8 @@ private
for Cursor'Write use Write; for Cursor'Write use Write;
type Reference_Control_Type is subtype Reference_Control_Type is Implementation.Reference_Control_Type;
new Controlled with record -- It is necessary to rename this here, so that the compiler can find it
Container : Vector_Access;
end record;
overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Constant_Reference_Type type Constant_Reference_Type
(Element : not null access constant Element_Type) is (Element : not null access constant Element_Type) is
...@@ -477,7 +470,7 @@ private ...@@ -477,7 +470,7 @@ private
-- Three operations are used to optimize in the expansion of "for ... of" -- Three operations are used to optimize in the expansion of "for ... of"
-- loops: the Next(Cursor) procedure in the visible part, and the following -- loops: the Next(Cursor) procedure in the visible part, and the following
-- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for
-- details. -- details.
function Pseudo_Reference function Pseudo_Reference
...@@ -501,4 +494,25 @@ private ...@@ -501,4 +494,25 @@ private
-- Count_Type'Last as a universal_integer, so we can compare Index_Type -- Count_Type'Last as a universal_integer, so we can compare Index_Type
-- values against this without type conversions that might overflow. -- values against this without type conversions that might overflow.
type Iterator is new Limited_Controlled and
Vector_Iterator_Interfaces.Reversible_Iterator with
record
Container : Vector_Access;
Index : Index_Type'Base;
end record
with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Iterator);
overriding function First (Object : Iterator) return Cursor;
overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
Position : Cursor) return Cursor;
overriding function Previous
(Object : Iterator;
Position : Cursor) return Cursor;
end Ada.Containers.Vectors; end Ada.Containers.Vectors;
gcc/ada/sem_ch13.adb
...@@ -9840,9 +9840,15 @@ package body Sem_Ch13 is ...@@ -9840,9 +9840,15 @@ package body Sem_Ch13 is
(Parent_Last_Bit, (Parent_Last_Bit,
Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
end if; end if;
else
-- Skip anonymous types generated for constrained array
-- or record components.
Next_Entity (Pcomp); null;
end if; end if;
Next_Entity (Pcomp);
end loop; end loop;
end if; end if;
end; end;
......
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