2014-07-30 Robert Dewar <dewar@adacore.com>

	* clean.adb: Minor reformatting.
	* opt.ads: Minor fix to incorrect comment.

2014-07-30  Ed Schonberg  <schonberg@adacore.com>

	* a-chtgbo.ads, a-chtgbo.adb (Delete_Node_At_Index): New
	subprogram, used by bounded hashed sets, to delete a node at
	a given index, whose element may have been improperly updated
	through a Reference_Preserving key.
	* a-cbhase.ads: Add Reference_Control_Type to package Generic_Keys.
	* a-cbhase.adb: Add Adjust and Finalize routines for
	Reference_Control_Type.
	(Delete, Insert): Raise Program_Error, not Constraint_Error,
	when operation is illegal.
	(Reference_Preserving_Key): Build aggregate for Reference_Control_Type
	* a-cmbutr.ads: Add Reference_Control_Type to detect tampering. Add
	private with_clause for Ada.Finalization.
	* a-cbmutr.adb: Add Adjust and Finalize routines for
	Reference_Control_Type. Use it in the construction of Reference
	and Constant_Reference values.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@213285 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 62 insertions, 10 deletions

diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb
index 1745528d93a..26b0085b648 100644
--- a/gcc/ada/a-cbmutr.adb
+++ b/gcc/ada/a-cbmutr.adb
@@ -27,8 +27,6 @@
 -- This unit was originally developed by Matthew J Heaney.                  --
 ------------------------------------------------------------------------------
 
-with Ada.Finalization; use Ada.Finalization;
-
 with System; use type System.Address;
 
 package body Ada.Containers.Bounded_Multiway_Trees is
@@ -236,6 +234,24 @@ package body Ada.Containers.Bounded_Multiway_Trees is
                 Right_Subtree => Root_Node (Right));
    end "=";
 
+   ------------
+   -- Adjust --
+   ------------
+
+   procedure Adjust (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            C : Tree 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;
+
    -------------------
    -- Allocate_Node --
    -------------------
@@ -329,12 +345,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
          raise Constraint_Error with "Position cursor has no element";
       end if;
 
-      --  Commented-out pending ruling by ARG.  ???
-
-      --  if Position.Container /= Container'Unrestricted_Access then
-      --     raise Program_Error with "Position cursor not in container";
-      --  end if;
-
       --  AI-0136 says to raise PE if Position equals the root node. This does
       --  not seem correct, as this value is just the limiting condition of the
       --  search. For now we omit this check, pending a ruling from the ARG.
@@ -602,7 +612,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is
       --  pragma Assert (Vet (Position),
       --                 "Position cursor in Constant_Reference is bad");
 
-      return (Element => Container.Elements (Position.Node)'Access);
+      declare
+         C : Tree renames Position.Container.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+
+      begin
+         return R : constant Constant_Reference_Type :=
+           (Element => Container.Elements (Position.Node)'Access,
+            Control => (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -1270,6 +1293,22 @@ package body Ada.Containers.Bounded_Multiway_Trees is
       B := B - 1;
    end Finalize;
 
+   procedure Finalize (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            C : Tree renames Control.Container.all;
+            B : Natural renames C.Busy;
+            L : Natural renames C.Lock;
+         begin
+            B := B - 1;
+            L := L - 1;
+         end;
+
+         Control.Container := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -2516,7 +2555,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is
       --  pragma Assert (Vet (Position),
       --                 "Position cursor in Constant_Reference is bad");
 
-      return (Element => Container.Elements (Position.Node)'Access);
+      declare
+         C : Tree renames Position.Container.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+      begin
+         return R : constant Reference_Type :=
+           (Element => Container.Elements (Position.Node)'Access,
+            Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
+
    end Reference;
 
    --------------------