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>
* 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 @@
-- --
------------------------------------------------------------------------------
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
pragma Pure;
......@@ -21,4 +32,123 @@ package Ada.Containers is
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;
gcc/ada/a-convec.adb
......@@ -36,29 +36,13 @@ package body Ada.Containers.Vectors is
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
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
(Container : in out Vector;
New_Item : Element_Type;
......@@ -70,273 +54,45 @@ package body Ada.Containers.Vectors is
-- "&" --
---------
function "&" (Left, Right : Vector) return Vector is
LN : constant Count_Type := Length (Left);
RN : constant Count_Type := Length (Right);
N : Count_Type'Base; -- length of result
J : Count_Type'Base; -- for computing intermediate index values
Last : Index_Type'Base; -- Last index of result
-- We decide that the capacity of the result of "&" is the minimum needed
-- -- the sum of the lengths of the vector parameters. We could decide to
-- make it larger, but we have no basis for knowing how much larger, so we
-- just allocate the minimum amount of storage.
function "&" (Left, Right : Vector) return Vector is
begin
-- We decide that the capacity of the result is the sum of the lengths
-- of the vector parameters. We could decide to make it larger, but we
-- have no basis for knowing how much larger, so we just allocate the
-- minimum amount of storage.
-- 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;
return Result : Vector do
Reserve_Capacity (Result, Length (Left) + Length (Right));
Append (Result, Left);
Append (Result, Right);
end return;
end "&";
function "&" (Left : Vector; Right : Element_Type) return Vector is
begin
-- We decide that the capacity of the result is the sum of the lengths
-- of the parameters. We could decide to make it larger, but we have no
-- basis for knowing how much larger, so we just allocate the minimum
-- amount of storage.
-- 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;
return Result : Vector do
Reserve_Capacity (Result, Length (Left) + 1);
Append (Result, Left);
Append (Result, Right);
end return;
end "&";
function "&" (Left : Element_Type; Right : Vector) return Vector is
begin
-- We decide that the capacity of the result is the sum of the lengths
-- of the parameters. We could decide to make it larger, but we have no
-- basis for knowing how much larger, so we just allocate the minimum
-- amount of storage.
-- 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;
return Result : Vector do
Reserve_Capacity (Result, 1 + Length (Right));
Append (Result, Left);
Append (Result, Right);
end return;
end "&";
function "&" (Left, Right : Element_Type) return Vector is
begin
-- We decide that the capacity of the result is the sum of the lengths
-- of the parameters. We could decide to make it larger, but we have no
-- basis for knowing how much larger, so we just allocate the minimum
-- amount of storage.
-- 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;
return Result : Vector do
Reserve_Capacity (Result, 1 + 1);
Append (Result, Left);
Append (Result, Right);
end return;
end "&";
---------
......@@ -344,57 +100,20 @@ package body Ada.Containers.Vectors is
---------
overriding function "=" (Left, Right : Vector) return Boolean is
BL : Natural renames Left'Unrestricted_Access.Busy;
LL : Natural renames Left'Unrestricted_Access.Lock;
BR : Natural renames Right'Unrestricted_Access.Busy;
LR : Natural renames Right'Unrestricted_Access.Lock;
Result : Boolean;
begin
if Left'Address = Right'Address then
return True;
end if;
if Left.Last /= Right.Last then
return False;
end if;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
BL := BL + 1;
LL := LL + 1;
BR := BR + 1;
LR := LR + 1;
Result := True;
for J in Index_Type range Index_Type'First .. Left.Last loop
if Left.Elements.EA (J) /= Right.Elements.EA (J) then
Result := False;
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;
declare
Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
Left_Valid : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last);
Right_Valid : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last);
begin
return Left_Valid = Right_Valid;
end;
end "=";
------------
......@@ -415,8 +134,7 @@ package body Ada.Containers.Vectors is
begin
Container.Elements := null;
Container.Busy := 0;
Container.Lock := 0;
Zero_Counts (Container.TC);
-- Note: it may seem that the following assignment to Container.Last
-- is useless, since we assign it to L below. However this code is
......@@ -429,20 +147,6 @@ package body Ada.Containers.Vectors is
end;
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 --
------------
......@@ -451,7 +155,7 @@ package body Ada.Containers.Vectors is
begin
if Is_Empty (New_Item) then
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";
else
Insert (Container, Container.Last + 1, New_Item);
......@@ -472,10 +176,7 @@ package body Ada.Containers.Vectors is
and then Container.Elements /= null
and then Container.Last /= Container.Elements.Last
then
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
-- Increment Container.Last after assigning the New_Item, so we
-- leave the Container unmodified in case Finalize/Adjust raises
......@@ -505,7 +206,7 @@ package body Ada.Containers.Vectors is
begin
if Count = 0 then
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";
else
Insert (Container, Container.Last + 1, New_Item, Count);
......@@ -545,12 +246,8 @@ package body Ada.Containers.Vectors is
procedure Clear (Container : in out Vector) is
begin
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
else
Container.Last := No_Index;
end if;
TC_Check (Container.TC);
Container.Last := No_Index;
end Clear;
------------------------
......@@ -562,31 +259,37 @@ package body Ada.Containers.Vectors is
Position : Cursor) return Constant_Reference_Type
is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
end if;
declare
C : Vector renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
if T_Check then
declare
TC : constant Tamper_Counts_Access :=
Container.TC'Unrestricted_Access;
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 :=
(Element => Container.Elements.EA (Position.Index)'Access,
Control => (Controlled with Container'Unrestricted_Access))
do
B := B + 1;
L := L + 1;
end return;
end;
Control => (Controlled with null));
end if;
end Constant_Reference;
function Constant_Reference
......@@ -594,22 +297,26 @@ package body Ada.Containers.Vectors is
Index : Index_Type) return Constant_Reference_Type
is
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
else
end if;
if T_Check then
declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
TC : constant Tamper_Counts_Access :=
Container.TC'Unrestricted_Access;
begin
return R : constant Constant_Reference_Type :=
(Element => Container.Elements.EA (Index)'Access,
Control => (Controlled with Container'Unrestricted_Access))
Control => (Controlled with TC))
do
B := B + 1;
L := L + 1;
Lock (TC.all);
end return;
end;
else
return R : constant Constant_Reference_Type :=
(Element => Container.Elements.EA (Index)'Access,
Control => (Controlled with null));
end if;
end Constant_Reference;
......@@ -642,7 +349,7 @@ package body Ada.Containers.Vectors is
elsif Capacity >= Source.Length then
C := Capacity;
else
elsif Checks then
raise Capacity_Error with
"Requested capacity is less than Source length";
end if;
......@@ -685,7 +392,7 @@ package body Ada.Containers.Vectors is
-- in the base range that immediately precede and immediately follow the
-- 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)";
end if;
......@@ -697,7 +404,7 @@ package body Ada.Containers.Vectors is
-- algorithm, so that case is treated as a proper error.)
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)";
else
return;
......@@ -717,10 +424,7 @@ package body Ada.Containers.Vectors is
-- the count on exit. Delete checks the count to determine whether it is
-- being called while the associated callback procedure is executing.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
-- We first calculate what's available for deletion starting at
-- Index. Here and elsewhere we use the wider of Index_Type'Base and
......@@ -778,22 +482,21 @@ package body Ada.Containers.Vectors is
Position : in out Cursor;
Count : Count_Type := 1)
is
pragma Warnings (Off, Position);
begin
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";
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
elsif Position.Index > Container.Last then
raise Program_Error with "Position index is out of range";
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
else
Delete (Container, Position.Index, Count);
Position := No_Element;
elsif Position.Index > Container.Last then
raise Program_Error with "Position index is out of range";
end if;
end if;
Delete (Container, Position.Index, Count);
Position := No_Element;
end Delete;
------------------
......@@ -842,10 +545,7 @@ package body Ada.Containers.Vectors is
-- it is being called while the associated callback procedure is
-- executing.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
-- 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
......@@ -878,7 +578,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type) return Element_Type
is
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
else
return Container.Elements.EA (Index);
......@@ -887,13 +587,15 @@ package body Ada.Containers.Vectors is
function Element (Position : Cursor) return Element_Type is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
elsif Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
else
return Position.Container.Elements.EA (Position.Index);
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
elsif Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
end if;
return Position.Container.Elements.EA (Position.Index);
end Element;
--------------
......@@ -909,32 +611,13 @@ package body Ada.Containers.Vectors is
Free (X);
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
end Finalize;
procedure Finalize (Object : in out Iterator) is
B : Natural renames Object.Container.Busy;
begin
B := B - 1;
end Finalize;
procedure Finalize (Control : in out Reference_Control_Type) is
pragma Assert (T_Check); -- not called if check suppressed
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;
Control.Container := null;
end if;
Unbusy (Object.Container.TC);
end Finalize;
----------
......@@ -947,7 +630,7 @@ package body Ada.Containers.Vectors is
Position : Cursor := No_Element) return Cursor
is
begin
if Position.Container /= null then
if Checks and then Position.Container /= null then
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
......@@ -961,38 +644,15 @@ package body Ada.Containers.Vectors is
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for J in Position.Index .. Container.Last loop
if Container.Elements.EA (J) = Item then
Result := J;
exit;
return Cursor'(Container'Unrestricted_Access, J);
end if;
end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
return No_Element;
end;
end Find;
......@@ -1005,37 +665,18 @@ package body Ada.Containers.Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'First) return Extended_Index
is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
for Indx in Index .. Container.Last loop
if Container.Elements.EA (Indx) = Item then
Result := Indx;
exit;
return Indx;
end if;
end loop;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
return No_Index;
end Find_Index;
-----------
......@@ -1080,7 +721,7 @@ package body Ada.Containers.Vectors is
function First_Element (Container : Vector) return Element_Type is
begin
if Container.Last = No_Index then
if Checks and then Container.Last = No_Index then
raise Constraint_Error with "Container is empty";
else
return Container.Elements.EA (Index_Type'First);
......@@ -1117,36 +758,16 @@ package body Ada.Containers.Vectors is
-- element tampering by a generic actual subprogram.
declare
EA : Elements_Array renames Container.Elements.EA;
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Boolean;
Lock : With_Lock (Container.TC'Unrestricted_Access);
EA : Elements_Array renames Container.Elements.EA;
begin
B := B + 1;
L := L + 1;
Result := True;
for J in Index_Type'First .. Container.Last - 1 loop
if EA (J + 1) < EA (J) then
Result := False;
exit;
return False;
end if;
end loop;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
return True;
end;
end Is_Sorted;
......@@ -1171,7 +792,7 @@ package body Ada.Containers.Vectors is
return;
end if;
if Target'Address = Source'Address then
if Checks and then Target'Address = Source'Address then
raise Program_Error with
"Target and Source denote same non-empty container";
end if;
......@@ -1181,10 +802,7 @@ package body Ada.Containers.Vectors is
return;
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Source.TC);
Target.Set_Length (Length (Target) + Length (Source));
......@@ -1195,19 +813,9 @@ package body Ada.Containers.Vectors is
TA : Elements_Array renames Target.Elements.EA;
SA : Elements_Array renames Source.Elements.EA;
TB : Natural renames Target.Busy;
TL : Natural renames Target.Lock;
SB : Natural renames Source.Busy;
SL : Natural renames Source.Lock;
Lock_Target : With_Lock (Target.TC'Unchecked_Access);
Lock_Source : With_Lock (Source.TC'Unchecked_Access);
begin
TB := TB + 1;
TL := TL + 1;
SB := SB + 1;
SL := SL + 1;
J := Target.Last;
while Source.Last >= Index_Type'First loop
pragma Assert (Source.Last <= Index_Type'First
......@@ -1236,22 +844,6 @@ package body Ada.Containers.Vectors is
J := J - 1;
end loop;
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
exception
when others =>
TB := TB - 1;
TL := TL - 1;
SB := SB - 1;
SL := SL - 1;
raise;
end;
end Merge;
......@@ -1283,33 +875,15 @@ package body Ada.Containers.Vectors is
-- an artifact of our array-based implementation. Logically Sort
-- requires a check for cursor tampering.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
Lock : With_Lock (Container.TC'Unchecked_Access);
begin
B := B + 1;
L := L + 1;
Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
B := B - 1;
L := L - 1;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
end;
end Sort;
......@@ -1358,31 +932,33 @@ package body Ada.Containers.Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we do
-- not allow that as the value for Index when specifying where the new
-- items should be inserted, so we must manually check. (That the user
-- is allowed to specify the value at all here is a consequence of the
-- declaration of the Extended_Index subtype, which includes the values
-- in the base range that immediately precede and immediately follow the
-- values in the Index_Type.)
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we
-- do not allow that as the value for Index when specifying where the
-- new items should be inserted, so we must manually check. (That the
-- user is allowed to specify the value at all here is a consequence
-- of the declaration of the Extended_Index subtype, which includes
-- the values in the base range that immediately precede and
-- immediately follow the values in the Index_Type.)
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
-- 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
-- case of appending items to the back end of the vector. (It is assumed
-- that specifying an index value greater than Last + 1 indicates some
-- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.)
-- 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 case of appending items to the back end of the vector. (It is
-- assumed that specifying an index value greater than Last + 1
-- indicates some deeper flaw in the caller's algorithm, so that case
-- is treated as a proper error.)
if Before > Container.Last + 1 then
raise Constraint_Error with
"Before index is out of range (too large)";
if Before > Container.Last + 1 then
raise Constraint_Error with
"Before index is out of range (too large)";
end if;
end if;
-- We treat inserting 0 items into the container as a no-op, even when
......@@ -1398,7 +974,7 @@ package body Ada.Containers.Vectors is
-- Note: we cannot simply add these values, because of the possibility
-- 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";
end if;
......@@ -1506,7 +1082,7 @@ package body Ada.Containers.Vectors is
-- an internal array with a last index value greater than
-- 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";
end if;
......@@ -1551,10 +1127,7 @@ package body Ada.Containers.Vectors is
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
-- An internal array has already been allocated, so we must determine
-- whether there is enough unused storage for the new items.
......@@ -1828,7 +1401,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type'Base;
begin
if Before.Container /= null
if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
......@@ -1839,7 +1412,7 @@ package body Ada.Containers.Vectors is
end if;
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
"vector is already at its maximum length";
end if;
......@@ -1862,7 +1435,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type'Base;
begin
if Before.Container /= null
if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
......@@ -1879,7 +1452,7 @@ package body Ada.Containers.Vectors is
end if;
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
"vector is already at its maximum length";
end if;
......@@ -1904,7 +1477,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type'Base;
begin
if Before.Container /= null
if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
......@@ -1915,7 +1488,7 @@ package body Ada.Containers.Vectors is
end if;
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
"vector is already at its maximum length";
else
......@@ -1939,7 +1512,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type'Base;
begin
if Before.Container /= null
if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
......@@ -1956,7 +1529,7 @@ package body Ada.Containers.Vectors is
end if;
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
"vector is already at its maximum length";
end if;
......@@ -2019,31 +1592,33 @@ package body Ada.Containers.Vectors is
Dst : Elements_Access; -- new, expanded internal array
begin
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we do
-- not allow that as the value for Index when specifying where the new
-- items should be inserted, so we must manually check. (That the user
-- is allowed to specify the value at all here is a consequence of the
-- declaration of the Extended_Index subtype, which includes the values
-- in the base range that immediately precede and immediately follow the
-- values in the Index_Type.)
if Checks then
-- As a precondition on the generic actual Index_Type, the base type
-- must include Index_Type'Pred (Index_Type'First); this is the value
-- that Container.Last assumes when the vector is empty. However, we
-- do not allow that as the value for Index when specifying where the
-- new items should be inserted, so we must manually check. (That the
-- user is allowed to specify the value at all here is a consequence
-- of the declaration of the Extended_Index subtype, which includes
-- the values in the base range that immediately precede and
-- immediately follow the values in the Index_Type.)
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
if Before < Index_Type'First then
raise Constraint_Error with
"Before index is out of range (too small)";
end if;
-- 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
-- case of appending items to the back end of the vector. (It is assumed
-- that specifying an index value greater than Last + 1 indicates some
-- deeper flaw in the caller's algorithm, so that case is treated as a
-- proper error.)
-- 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 case of appending items to the back end of the vector. (It is
-- assumed that specifying an index value greater than Last + 1
-- indicates some deeper flaw in the caller's algorithm, so that case
-- is treated as a proper error.)
if Before > Container.Last + 1 then
raise Constraint_Error with
"Before index is out of range (too large)";
if Before > Container.Last + 1 then
raise Constraint_Error with
"Before index is out of range (too large)";
end if;
end if;
-- We treat inserting 0 items into the container as a no-op, even when
......@@ -2059,7 +1634,7 @@ package body Ada.Containers.Vectors is
-- Note: we cannot simply add these values, because of the possibility
-- 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";
end if;
......@@ -2167,7 +1742,7 @@ package body Ada.Containers.Vectors is
-- an internal array with a last index value greater than
-- 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";
end if;
......@@ -2211,10 +1786,7 @@ package body Ada.Containers.Vectors is
-- exit. Insert checks the count to determine whether it is being called
-- while the associated callback procedure is executing.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
-- An internal array has already been allocated, so we must determine
-- whether there is enough unused storage for the new items.
......@@ -2360,7 +1932,7 @@ package body Ada.Containers.Vectors is
Index : Index_Type'Base;
begin
if Before.Container /= null
if Checks and then Before.Container /= null
and then Before.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Before cursor denotes wrong container";
......@@ -2377,7 +1949,7 @@ package body Ada.Containers.Vectors is
end if;
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
"vector is already at its maximum length";
else
......@@ -2410,22 +1982,11 @@ package body Ada.Containers.Vectors is
(Container : Vector;
Process : not null access procedure (Position : Cursor))
is
B : Natural renames Container'Unrestricted_Access.all.Busy;
Busy : With_Busy (Container.TC'Unrestricted_Access);
begin
B := B + 1;
begin
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;
for Indx in Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
end Iterate;
function Iterate
......@@ -2433,8 +1994,6 @@ package body Ada.Containers.Vectors is
return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is
V : constant Vector_Access := Container'Unrestricted_Access;
B : Natural renames V.Busy;
begin
-- The value of its Index component influences the behavior of the First
-- and Last selector functions of the iterator object. When the Index
......@@ -2451,7 +2010,7 @@ package body Ada.Containers.Vectors is
Container => V,
Index => No_Index)
do
B := B + 1;
Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
......@@ -2461,8 +2020,6 @@ package body Ada.Containers.Vectors is
return Vector_Iterator_Interfaces.Reversible_Iterator'class
is
V : constant Vector_Access := Container'Unrestricted_Access;
B : Natural renames V.Busy;
begin
-- It was formerly the case that when Start = No_Element, the partial
-- iterator was defined to behave the same as for a complete iterator,
......@@ -2475,19 +2032,21 @@ package body Ada.Containers.Vectors is
-- however, that it is not possible to use a partial iterator to specify
-- an empty sequence of items.
if Start.Container = null then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
if Checks then
if Start.Container = null then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
if Start.Container /= V then
raise Program_Error with
"Start cursor of Iterate designates wrong vector";
end if;
if Start.Container /= V then
raise Program_Error with
"Start cursor of Iterate designates wrong vector";
end if;
if Start.Index > V.Last then
raise Constraint_Error with
"Start position for iterator equals No_Element";
if Start.Index > V.Last then
raise Constraint_Error with
"Start position for iterator equals No_Element";
end if;
end if;
-- The value of its Index component influences the behavior of the First
......@@ -2504,7 +2063,7 @@ package body Ada.Containers.Vectors is
Container => V,
Index => Start.Index)
do
B := B + 1;
Busy (Container.TC'Unrestricted_Access.all);
end return;
end Iterate;
......@@ -2549,7 +2108,7 @@ package body Ada.Containers.Vectors is
function Last_Element (Container : Vector) return Element_Type is
begin
if Container.Last = No_Index then
if Checks and then Container.Last = No_Index then
raise Constraint_Error with "Container is empty";
else
return Container.Elements.EA (Container.Last);
......@@ -2612,15 +2171,8 @@ package body Ada.Containers.Vectors is
return;
end if;
if Target.Busy > 0 then
raise Program_Error with
"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;
TC_Check (Target.TC);
TC_Check (Source.TC);
declare
Target_Elements : constant Elements_Access := Target.Elements;
......@@ -2652,7 +2204,7 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
return No_Element;
elsif Position.Container /= Object.Container then
elsif Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong vector";
else
......@@ -2708,7 +2260,7 @@ package body Ada.Containers.Vectors is
begin
if Position.Container = null then
return No_Element;
elsif Position.Container /= Object.Container then
elsif Checks and then Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong vector";
else
......@@ -2734,15 +2286,10 @@ package body Ada.Containers.Vectors is
function Pseudo_Reference
(Container : aliased Vector'Class) return Reference_Control_Type
is
C : constant Vector_Access := Container'Unrestricted_Access;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Control_Type :=
(Controlled with C)
do
B := B + 1;
L := L + 1;
return R : constant Reference_Control_Type := (Controlled with TC) do
Lock (TC.all);
end return;
end Pseudo_Reference;
......@@ -2755,29 +2302,15 @@ package body Ada.Containers.Vectors is
Index : Index_Type;
Process : not null access procedure (Element : Element_Type))
is
Lock : With_Lock (Container.TC'Unrestricted_Access);
V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
L : Natural renames V.Lock;
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
B := B + 1;
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;
Process (V.Elements.EA (Index));
end Query_Element;
procedure Query_Element
......@@ -2785,7 +2318,7 @@ package body Ada.Containers.Vectors is
Process : not null access procedure (Element : Element_Type))
is
begin
if Position.Container = null then
if Checks and then Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
else
Query_Element (Position.Container.all, Position.Index, Process);
......@@ -2852,31 +2385,37 @@ package body Ada.Containers.Vectors is
Position : Cursor) return Reference_Type
is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Checks then
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
end if;
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
if Position.Index > Position.Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
end if;
declare
C : Vector renames Position.Container.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
begin
if T_Check then
declare
TC : constant Tamper_Counts_Access :=
Container.TC'Unrestricted_Access;
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 :=
(Element => Container.Elements.EA (Position.Index)'Access,
Control => (Controlled with Position.Container))
do
B := B + 1;
L := L + 1;
end return;
end;
Control => (Controlled with null));
end if;
end Reference;
function Reference
......@@ -2884,23 +2423,26 @@ package body Ada.Containers.Vectors is
Index : Index_Type) return Reference_Type
is
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
else
if T_Check then
declare
C : Vector renames Container'Unrestricted_Access.all;
B : Natural renames C.Busy;
L : Natural renames C.Lock;
TC : constant Tamper_Counts_Access :=
Container.TC'Unrestricted_Access;
begin
return R : constant Reference_Type :=
(Element => Container.Elements.EA (Index)'Access,
Control => (Controlled with Container'Unrestricted_Access))
Control => (Controlled with TC))
do
B := B + 1;
L := L + 1;
Lock (TC.all);
end return;
end;
else
return R : constant Reference_Type :=
(Element => Container.Elements.EA (Index)'Access,
Control => (Controlled with null));
end if;
end Reference;
......@@ -2914,14 +2456,12 @@ package body Ada.Containers.Vectors is
New_Item : Element_Type)
is
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
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;
TE_Check (Container.TC);
Container.Elements.EA (Index) := New_Item;
end Replace_Element;
procedure Replace_Element
......@@ -2930,23 +2470,20 @@ package body Ada.Containers.Vectors is
New_Item : Element_Type)
is
begin
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
if Checks then
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
raise Constraint_Error with "Position cursor is out of range";
elsif Position.Container /= Container'Unrestricted_Access then
raise Program_Error with "Position cursor denotes wrong container";
else
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
elsif Position.Index > Container.Last then
raise Constraint_Error with "Position cursor is out of range";
end if;
Container.Elements.EA (Position.Index) := New_Item;
end if;
TE_Check (Container.TC);
Container.Elements.EA (Position.Index) := New_Item;
end Replace_Element;
----------------------
......@@ -3008,10 +2545,7 @@ package body Ada.Containers.Vectors is
-- so this is the best we can do with respect to minimizing
-- storage).
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
declare
subtype Src_Index_Subtype is Index_Type'Base range
......@@ -3068,7 +2602,9 @@ package body Ada.Containers.Vectors is
-- Which can rewrite as:
-- 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";
end if;
......@@ -3080,7 +2616,7 @@ package body Ada.Containers.Vectors is
-- Finally we test whether the value is within the range of the
-- 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";
end if;
......@@ -3092,7 +2628,7 @@ package body Ada.Containers.Vectors is
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";
end if;
......@@ -3109,7 +2645,7 @@ package body Ada.Containers.Vectors is
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";
end if;
......@@ -3148,10 +2684,7 @@ package body Ada.Containers.Vectors is
-- new internal array having a length that exactly matches the
-- number of items in the container.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
declare
subtype Src_Index_Subtype is Index_Type'Base range
......@@ -3208,10 +2741,7 @@ package body Ada.Containers.Vectors is
-- number of active elements in the container.) We must check whether
-- the container is busy before doing anything else.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
-- We now allocate a new internal array, having a length different from
-- its current value.
......@@ -3283,10 +2813,7 @@ package body Ada.Containers.Vectors is
-- implementation. Logically Reverse_Elements requires a check for
-- cursor tampering.
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is busy)";
end if;
TC_Check (Container.TC);
declare
K : Index_Type;
......@@ -3322,7 +2849,7 @@ package body Ada.Containers.Vectors is
Last : Index_Type'Base;
begin
if Position.Container /= null
if Checks and then Position.Container /= null
and then Position.Container /= Container'Unrestricted_Access
then
raise Program_Error with "Position cursor denotes wrong container";
......@@ -3337,38 +2864,15 @@ package body Ada.Containers.Vectors is
-- element tampering by a generic actual subprogram.
declare
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
Result : Index_Type'Base;
Lock : With_Lock (Container.TC'Unrestricted_Access);
begin
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) = Item then
Result := Indx;
exit;
return Cursor'(Container'Unrestricted_Access, Indx);
end if;
end loop;
B := B - 1;
L := L - 1;
if Result = No_Index then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
return No_Element;
end;
end Reverse_Find;
......@@ -3381,67 +2885,36 @@ package body Ada.Containers.Vectors is
Item : Element_Type;
Index : Index_Type := Index_Type'Last) return Extended_Index
is
B : Natural renames Container'Unrestricted_Access.Busy;
L : Natural renames Container'Unrestricted_Access.Lock;
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
Lock : With_Lock (Container.TC'Unrestricted_Access);
Last : constant Index_Type'Base :=
Index_Type'Min (Container.Last, Index);
Result : Index_Type'Base;
begin
-- Per AI05-0022, the container implementation is required to detect
-- element tampering by a generic actual subprogram.
B := B + 1;
L := L + 1;
Result := No_Index;
for Indx in reverse Index_Type'First .. Last loop
if Container.Elements.EA (Indx) = Item then
Result := Indx;
exit;
return Indx;
end if;
end loop;
B := B - 1;
L := L - 1;
return Result;
exception
when others =>
B := B - 1;
L := L - 1;
raise;
return No_Index;
end Reverse_Find_Index;
---------------------
-- Reverse_Iterate --
---------------------
procedure Reverse_Iterate
(Container : Vector;
Process : not null access procedure (Position : Cursor))
is
V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
Busy : With_Busy (Container.TC'Unrestricted_Access);
begin
B := B + 1;
begin
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;
for Indx in reverse Index_Type'First .. Container.Last loop
Process (Cursor'(Container'Unrestricted_Access, Indx));
end loop;
end Reverse_Iterate;
----------------
......@@ -3462,7 +2935,7 @@ package body Ada.Containers.Vectors is
if Count >= 0 then
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";
else
......@@ -3476,22 +2949,21 @@ package body Ada.Containers.Vectors is
procedure Swap (Container : in out Vector; I, J : Index_Type) is
begin
if I > Container.Last then
raise Constraint_Error with "I index is out of range";
end if;
if Checks then
if I > Container.Last then
raise Constraint_Error with "I index is out of range";
end if;
if J > Container.Last then
raise Constraint_Error with "J index is out of range";
if J > Container.Last then
raise Constraint_Error with "J index is out of range";
end if;
end if;
if I = J then
return;
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is locked)";
end if;
TE_Check (Container.TC);
declare
EI_Copy : constant Element_Type := Container.Elements.EA (I);
......@@ -3503,21 +2975,22 @@ package body Ada.Containers.Vectors is
procedure Swap (Container : in out Vector; I, J : Cursor) is
begin
if I.Container = null then
raise Constraint_Error with "I cursor has no element";
if Checks then
if I.Container = null then
raise Constraint_Error with "I cursor has no element";
elsif J.Container = null then
raise Constraint_Error with "J cursor has no element";
elsif J.Container = null then
raise Constraint_Error with "J cursor has no element";
elsif I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor denotes wrong container";
elsif I.Container /= Container'Unrestricted_Access then
raise Program_Error with "I cursor denotes wrong container";
elsif J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor denotes wrong container";
else
Swap (Container, I.Index, J.Index);
elsif J.Container /= Container'Unrestricted_Access then
raise Program_Error with "J cursor denotes wrong container";
end if;
end if;
Swap (Container, I.Index, J.Index);
end Swap;
---------------
......@@ -3585,7 +3058,9 @@ package body Ada.Containers.Vectors is
-- Which can rewrite as:
-- 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";
end if;
......@@ -3597,7 +3072,7 @@ package body Ada.Containers.Vectors is
-- Finally we test whether the value is within the range of the
-- 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";
end if;
......@@ -3609,7 +3084,7 @@ package body Ada.Containers.Vectors is
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";
end if;
......@@ -3626,7 +3101,7 @@ package body Ada.Containers.Vectors is
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";
end if;
......@@ -3675,7 +3150,9 @@ package body Ada.Containers.Vectors is
-- Which can rewrite as:
-- 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";
end if;
......@@ -3687,7 +3164,7 @@ package body Ada.Containers.Vectors is
-- Finally we test whether the value is within the range of the
-- 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";
end if;
......@@ -3699,7 +3176,7 @@ package body Ada.Containers.Vectors is
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";
end if;
......@@ -3716,7 +3193,7 @@ package body Ada.Containers.Vectors is
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";
end if;
......@@ -3741,28 +3218,13 @@ package body Ada.Containers.Vectors is
Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type))
is
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
Lock : With_Lock (Container.TC'Unchecked_Access);
begin
if Index > Container.Last then
if Checks and then Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
B := B + 1;
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;
Process (Container.Elements.EA (Index));
end Update_Element;
procedure Update_Element
......@@ -3771,13 +3233,15 @@ package body Ada.Containers.Vectors is
Process : not null access procedure (Element : in out Element_Type))
is
begin
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";
else
Update_Element (Container, Position.Index, Process);
if Checks then
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";
end if;
end if;
Update_Element (Container, Position.Index, Process);
end Update_Element;
-----------
......
gcc/ada/a-convec.ads
......@@ -366,8 +366,10 @@ private
pragma Inline (Next);
pragma Inline (Previous);
package Implementation is new Generic_Implementation;
use Implementation;
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
EA : Elements_Array (Index_Type'First .. Last);
......@@ -375,14 +377,13 @@ private
type Elements_Access is access all Elements_Type;
use Ada.Finalization;
use Ada.Streams;
use Finalization;
use Streams;
type Vector is new Controlled with record
Elements : Elements_Access := null;
Last : Extended_Index := No_Index;
Busy : Natural := 0;
Lock : Natural := 0;
TC : aliased Tamper_Counts;
end record;
overriding procedure Adjust (Container : in out Vector);
......@@ -420,16 +421,8 @@ private
for Cursor'Write use Write;
type Reference_Control_Type is
new Controlled with record
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);
subtype Reference_Control_Type is Implementation.Reference_Control_Type;
-- It is necessary to rename this here, so that the compiler can find it
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
......@@ -477,7 +470,7 @@ private
-- Three operations are used to optimize in the expansion of "for ... of"
-- 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.
function Pseudo_Reference
......@@ -501,4 +494,25 @@ private
-- Count_Type'Last as a universal_integer, so we can compare Index_Type
-- 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;
gcc/ada/sem_ch13.adb
......@@ -9840,9 +9840,15 @@ package body Sem_Ch13 is
(Parent_Last_Bit,
Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
end if;
else
-- Skip anonymous types generated for constrained array
-- or record components.
Next_Entity (Pcomp);
null;
end if;
Next_Entity (Pcomp);
end loop;
end if;
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