[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

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

+------------------------------------------------------------------------------
+--                                                                          --
+--                         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.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;