[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
This commit is contained in:
parent
00c93ba2f2
commit
2a738b3469
|
@ -1,3 +1,33 @@
|
|||
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.
|
||||
|
|
|
@ -0,0 +1,189 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- 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;
|
|
@ -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;
|
||||
|
|
1228
gcc/ada/a-convec.adb
1228
gcc/ada/a-convec.adb
File diff suppressed because it is too large
Load Diff
|
@ -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;
|
||||
|
|
|
@ -9840,9 +9840,15 @@ package body Sem_Ch13 is
|
|||
(Parent_Last_Bit,
|
||||
Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
|
||||
end if;
|
||||
else
|
||||
|
||||
Next_Entity (Pcomp);
|
||||
-- Skip anonymous types generated for constrained array
|
||||
-- or record components.
|
||||
|
||||
null;
|
||||
end if;
|
||||
|
||||
Next_Entity (Pcomp);
|
||||
end loop;
|
||||
end if;
|
||||
end;
|
||||
|
|
Loading…
Reference in New Issue