Patchwork [Ada] Controlled finalization for references in Ada 2012 containers

login
register
mail settings
Submitter Arnaud Charlet
Date Feb. 17, 2012, 2:16 p.m.
Message ID <20120217141607.GA22658@adacore.com>
Download mbox | patch
Permalink /patch/141829/
State New
Headers show

Comments

Arnaud Charlet - Feb. 17, 2012, 2:16 p.m.
This patch introduces controlled finalization in order to prevent any tampering
while referencing to an element in a container.

------------
-- Source --
------------

with Ada.Containers.Doubly_Linked_Lists;
with Ada.Containers; use Ada.Containers;
with Ada.Text_IO;    use Ada.Text_IO;

procedure Main is
   type Element is record
      Comp : Integer := 1234;
   end record;

   E : Element := Element'(Comp => 4);

   package DLL is new Ada.Containers.Doubly_Linked_Lists
     (Element_Type => Element,
      "="          => "=");

   Cont : DLL.List;
   Pos  : DLL.Cursor;

begin
   Put_Line ("TEST: Doubly Linked Lists");

   Cont.Append (Element'(Comp => 1));
   Cont.Append (Element'(Comp => 2));
   Cont.Append (Element'(Comp => 3));

   begin
      --  Explicit references

      Put_Line ("Explicit reference 1:");
      Pos := Cont.First;

      declare
         R : constant DLL.Reference_Type := Cont.Reference (Pos);
      begin
         Cont.Delete_Last;
         Put_Line ("ERROR: tamper with cursors not prevented");
      exception
         when Program_Error => Put_Line ("OK");
         when others => Put_Line ("ERROR: unexpected error raised while " &
                                  "tampering with cursors");
      end;

      declare
         R : constant DLL.Reference_Type := Cont.Reference (Pos);
      begin
         Cont.Replace_Element (Pos, E);
         Put_Line ("ERROR: tamper with elements not prevented");
      exception
         when Program_Error => Put_Line ("OK");
         when others => Put_Line ("ERROR: unexpected error raised while " &
                                  "tampering with elements");
      end;

      Put_Line ("Explicit reference 2:");

      declare
         R : constant DLL.Constant_Reference_Type :=
               Cont.Constant_Reference (Pos);
      begin
         Cont.Delete_Last;
         Put_Line ("ERROR: tamper with cursors not prevented");
      exception
         when Program_Error => Put_Line ("OK");
         when others => Put_Line ("ERROR: unexpected error raised while " &
                                     "tampering with cursors");
      end;

      declare
         R : constant DLL.Constant_Reference_Type :=
                 Cont.Constant_Reference (Pos);
      begin
         Cont.Replace_Element (Pos, E);
         Put_Line ("ERROR: tamper with elements not prevented");
      exception
         when Program_Error => Put_Line ("OK");
         when others => Put_Line ("ERROR: unexpected error raised while " &
                                     "tampering with elements");
      end;

      --  Implicit references

      Put_Line ("Implicit reference 1:");
      
      declare
         E : Element renames Cont (Pos);
      begin
         Cont.Delete_Last;
         Put_Line ("ERROR: tamper with cursors not prevented");
      exception
         when Program_Error => Put_Line ("OK");
         when others => Put_Line ("ERROR: unexpected error raised while " &
                                  "tampering with cursors");
      end;

      declare
         E : Element renames Cont (Pos);
      begin
         Cont.Replace_Element (Pos, E);
         Put_Line ("ERROR: tamper with elements not prevented");
      exception
         when Program_Error => Put_Line ("OK");
         when others => Put_Line ("ERROR: unexpected error raised while " &
                                  "tampering with elements");
      end;

      Put_Line ("Implicit reference 2:");

      declare
      begin
         for E of Cont loop
            begin
               Cont.Delete_Last;
               Put_Line ("ERROR: tamper with cursors not prevented");
            exception
               when Program_Error => Put_Line ("OK");
               when others => Put_Line ("ERROR: unexpected error raised " &
                                        "while tampering with cursors");
            end;
         end loop;
      end;

      declare
      begin
         for E of Cont loop
            begin
               Cont.Replace_Element (Pos, E);
               Put_Line ("ERROR: tamper with elements not prevented");
            exception
               when Program_Error => Put_Line ("OK");
               when others => Put_Line ("ERROR: unexpected error raised " &
                                        "while tampering with elements");
            end;
         end loop;
      end;

      Cont.Replace_Element (Pos, E);
      Cont.Delete (Pos);

   exception
      when others => Put_Line ("ERROR: raised after finalization");
   end;
end Main;

-----------------
-- Compilation --
-----------------

gnatmake -q -gnat12 main.adb

-----------------------------------
-- Execution and expected output --
-----------------------------------

$./main
$TEST: Doubly Linked Lists
$Explicit reference 1:
$OK
$OK
$Explicit reference 2:
$OK
$OK
$Implicit reference 1:
$OK
$OK
$Implicit reference 2:
$OK
$OK
$OK
$OK
$OK
$OK

Tested on x86_64-pc-linux-gnu, committed on trunk

2012-02-17  Vincent Pucci  <pucci@adacore.com>

	* a-cdlili.adb, a-cidlli.adb, a-cihama.adb, a-cimutr.adb,
	* a-ciorma.adb, a-cohama.adb, a-coinve.adb, a-comutr.adb,
	* a-convec.adb, a-coorma.adb (Adjust): New routine.
	(Constant_Reference): Increment Busy and Lock counters.
	(Reference): Increase Busy and Lock counters.
	(Finalize): New routine.
	* a-cihase.adb, a-ciorse.adb, a-cohase.adb, a-coorse.adb:
	(Adjust): New routine.	(Constant_Reference): Increment Busy
	and Lock counters.
	(Finalize): New routine.
	* a-cdlili.ads, a-cidlli.ads, a-cihama.ads, a-cihase.ads,
	* a-cimutr.ads, a-ciorma.ads, a-ciorse.ads, a-cohama.ads,
	* a-cohase.ads, a-coinve.ads, a-comutr.ads, a-convec.ads,
	* a-coorma.ads, a-coorse: Controlled component added to the
	reference types.

Patch

Index: a-cdlili.adb
===================================================================
--- a-cdlili.adb	(revision 184330)
+++ a-cdlili.adb	(working copy)
@@ -142,6 +142,20 @@ 
       end loop;
    end Adjust;
 
+   procedure Adjust (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            C : List 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 --
    ------------
@@ -244,7 +258,20 @@ 
 
       pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
 
-      return (Element => Position.Node.Element'Access);
+      declare
+         C : List renames Position.Container.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Position.Node.Element'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -442,6 +469,22 @@ 
       end if;
    end Finalize;
 
+   procedure Finalize (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            C : List 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 --
    ----------
@@ -1336,7 +1379,19 @@ 
 
       pragma Assert (Vet (Position), "bad cursor in function Reference");
 
-      return (Element => Position.Node.Element'Access);
+      declare
+         C : List renames Position.Container.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => Position.Node.Element'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    ---------------------
Index: a-cdlili.ads
===================================================================
--- a-cdlili.ads	(revision 184330)
+++ a-cdlili.ads	(working copy)
@@ -104,10 +104,12 @@ 
    function Constant_Reference
      (Container : aliased List;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out List;
       Position  : Cursor) return Reference_Type;
+   pragma Inline (Reference);
 
    procedure Assign (Target : in out List; Source : List);
 
@@ -305,8 +307,22 @@ 
 
    for Cursor'Write use Write;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : List_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-      (Element : not null access constant Element_Type) is null record;
+      (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
@@ -321,7 +337,10 @@ 
    for Constant_Reference_Type'Read use Read;
 
    type Reference_Type
-      (Element : not null access Element_Type) is null record;
+      (Element : not null access Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
Index: a-cihama.adb
===================================================================
--- a-cihama.adb	(revision 184330)
+++ a-cihama.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, 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- --
@@ -136,6 +136,21 @@ 
       HT_Ops.Adjust (Container.HT);
    end Adjust;
 
+   procedure Adjust (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            M : Map renames Control.Container.all;
+            HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+            B : Natural renames HT.Busy;
+            L : Natural renames HT.Lock;
+         begin
+            B := B + 1;
+            L := L + 1;
+         end;
+      end if;
+   end Adjust;
+
    ------------
    -- Assign --
    ------------
@@ -217,7 +232,21 @@ 
         (Vet (Position),
          "Position cursor in Constant_Reference is bad");
 
-      return (Element => Position.Node.Element.all'Access);
+      declare
+         M : Map renames Position.Container.all;
+         HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+         B : Natural renames HT.Busy;
+         L : Natural renames HT.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Position.Node.Element.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    function Constant_Reference
@@ -235,7 +264,21 @@ 
          raise Program_Error with "key has no element";
       end if;
 
-      return (Element => Node.Element.all'Access);
+      declare
+         M : Map renames Container'Unrestricted_Access.all;
+         HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+         B : Natural renames HT.Busy;
+         L : Natural renames HT.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Node.Element.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -484,6 +527,23 @@ 
       end if;
    end Finalize;
 
+   procedure Finalize (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            M : Map renames Control.Container.all;
+            HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+            B : Natural renames HT.Busy;
+            L : Natural renames HT.Lock;
+         begin
+            B := B - 1;
+            L := L - 1;
+         end;
+
+         Control.Container := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -1028,7 +1088,20 @@ 
         (Vet (Position),
          "Position cursor in function Reference is bad");
 
-      return (Element => Position.Node.Element.all'Access);
+      declare
+         M : Map renames Position.Container.all;
+         HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+         B : Natural renames HT.Busy;
+         L : Natural renames HT.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => Position.Node.Element.all'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    function Reference
@@ -1046,7 +1119,21 @@ 
          raise Program_Error with "key has no element";
       end if;
 
-      return (Element => Node.Element.all'Access);
+      declare
+         M : Map renames Container'Unrestricted_Access.all;
+         HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
+         B : Natural renames HT.Busy;
+         L : Natural renames HT.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => Node.Element.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    -------------
Index: a-cihama.ads
===================================================================
--- a-cihama.ads	(revision 184330)
+++ a-cihama.ads	(working copy)
@@ -147,18 +147,22 @@ 
    function Constant_Reference
      (Container : aliased Map;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Map;
       Position  : Cursor) return Reference_Type;
+   pragma Inline (Reference);
 
    function Constant_Reference
      (Container : aliased Map;
       Key       : Key_Type) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Map;
       Key       : Key_Type) return Reference_Type;
+   pragma Inline (Reference);
 
    procedure Assign (Target : in out Map; Source : Map);
 
@@ -363,8 +367,22 @@ 
 
    for Cursor'Read use Read;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : Map_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-      (Element : not null access constant Element_Type) is null record;
+      (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
@@ -379,7 +397,10 @@ 
    for Constant_Reference_Type'Read use Read;
 
    type Reference_Type
-      (Element : not null access Element_Type) is null record;
+      (Element : not null access Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
Index: a-coinve.adb
===================================================================
--- a-coinve.adb	(revision 184330)
+++ a-coinve.adb	(working copy)
@@ -578,6 +578,20 @@ 
       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 --
    ------------
@@ -697,7 +711,20 @@ 
          raise Constraint_Error with "element at Position is empty";
       end if;
 
-      return (Element => E.all'Access);
+      declare
+         C : Vector renames Container'Unrestricted_Access.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => E.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    function Constant_Reference
@@ -717,7 +744,20 @@ 
          raise Constraint_Error with "element at Index is empty";
       end if;
 
-      return (Element => E.all'Access);
+      declare
+         C : Vector renames Container'Unrestricted_Access.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => E.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -1131,6 +1171,22 @@ 
       B := B - 1;
    end Finalize;
 
+   procedure Finalize (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;
+
+         Control.Container := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -1402,6 +1458,8 @@ 
             Array_Type   => Elements_Array,
             "<"          => Is_Less);
 
+      --  Start of processing for Sort
+
       begin
          if Container.Last <= Index_Type'First then
             return;
@@ -3047,7 +3105,19 @@ 
          raise Constraint_Error with "element at Position is empty";
       end if;
 
-      return (Element => E.all'Access);
+      declare
+         C : Vector renames Container'Unrestricted_Access.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => E.all'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    function Reference
@@ -3067,7 +3137,20 @@ 
          raise Constraint_Error with "element at Index is empty";
       end if;
 
-      return (Element => E.all'Access);
+      declare
+         C : Vector renames Container'Unrestricted_Access.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => E.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    ---------------------
@@ -3430,9 +3513,9 @@ 
       --  catch more things) instead of for element tampering (which will catch
       --  fewer things). It's true that the elements of this vector container
       --  could be safely moved around while (say) an iteration is taking place
-      --  (iteration only increments the busy counter), and so technically
-      --  all we would need here is a test for element tampering (indicated
-      --  by the lock counter), that's simply an artifact of our array-based
+      --  (iteration only increments the busy counter), and so technically all
+      --  we would need here is a test for element tampering (indicated by the
+      --  lock counter), that's simply an artifact of our array-based
       --  implementation. Logically Reverse_Elements requires a check for
       --  cursor tampering.
 
Index: a-coinve.ads
===================================================================
--- a-coinve.ads	(revision 184330)
+++ a-coinve.ads	(working copy)
@@ -117,18 +117,22 @@ 
    function Constant_Reference
      (Container : aliased Vector;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Vector;
       Position  : Cursor) return Reference_Type;
+   pragma Inline (Reference);
 
    function Constant_Reference
      (Container : aliased Vector;
       Index     : Index_Type) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Vector;
       Index     : Index_Type) return Reference_Type;
+   pragma Inline (Reference);
 
    function To_Cursor
      (Container : Vector;
@@ -408,8 +412,22 @@ 
 
    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);
+
    type Constant_Reference_Type
-     (Element : not null access constant Element_Type) is null record;
+     (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
@@ -424,7 +442,10 @@ 
    for Constant_Reference_Type'Read use Read;
 
    type Reference_Type
-     (Element : not null access Element_Type) is null record;
+     (Element : not null access Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
Index: a-ciorse.adb
===================================================================
--- a-ciorse.adb	(revision 184330)
+++ a-ciorse.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, 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- --
@@ -325,6 +325,20 @@ 
       Adjust (Container.Tree);
    end Adjust;
 
+   procedure Adjust (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            Tree : Tree_Type renames Control.Container.all.Tree;
+            B : Natural renames Tree.Busy;
+            L : Natural renames Tree.Lock;
+         begin
+            B := B + 1;
+            L := L + 1;
+         end;
+      end if;
+   end Adjust;
+
    ------------
    -- Assign --
    ------------
@@ -398,7 +412,20 @@ 
         (Vet (Container.Tree, Position.Node),
          "bad cursor in Constant_Reference");
 
-      return (Element => Position.Node.Element.all'Access);
+      declare
+         Tree : Tree_Type renames Position.Container.all.Tree;
+         B : Natural renames Tree.Busy;
+         L : Natural renames Tree.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Position.Node.Element.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -617,6 +644,22 @@ 
       end if;
    end Finalize;
 
+   procedure Finalize (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            Tree : Tree_Type renames Control.Container.all.Tree;
+            B : Natural renames Tree.Busy;
+            L : Natural renames Tree.Lock;
+         begin
+            B := B - 1;
+            L := L - 1;
+         end;
+
+         Control.Container := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -782,7 +825,20 @@ 
             raise Program_Error with "Node has no element";
          end if;
 
-         return (Element => Node.Element.all'Access);
+         declare
+            Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
+            B : Natural renames Tree.Busy;
+            L : Natural renames Tree.Lock;
+         begin
+            return R : constant Constant_Reference_Type :=
+                         (Element => Node.Element.all'Access,
+                          Control =>
+                            (Controlled with Container'Unrestricted_Access))
+            do
+               B := B + 1;
+               L := L + 1;
+            end return;
+         end;
       end Constant_Reference;
 
       --------------
Index: a-ciorse.ads
===================================================================
--- a-ciorse.ads	(revision 184330)
+++ a-ciorse.ads	(working copy)
@@ -99,6 +99,7 @@ 
    function Constant_Reference
      (Container : aliased Set;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    procedure Assign (Target : in out Set; Source : Set);
 
@@ -376,8 +377,22 @@ 
 
    for Cursor'Read use Read;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : Set_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-      (Element : not null access constant Element_Type) is null record;
+      (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
Index: a-coorma.adb
===================================================================
--- a-coorma.adb	(revision 184330)
+++ a-coorma.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, 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- --
@@ -252,6 +252,20 @@ 
       Adjust (Container.Tree);
    end Adjust;
 
+   procedure Adjust (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            T : Tree_Type renames Control.Container.all.Tree;
+            B : Natural renames T.Busy;
+            L : Natural renames T.Lock;
+         begin
+            B := B + 1;
+            L := L + 1;
+         end;
+      end if;
+   end Adjust;
+
    ------------
    -- Assign --
    ------------
@@ -340,7 +354,19 @@ 
       pragma Assert (Vet (Container.Tree, Position.Node),
                      "Position cursor in Constant_Reference is bad");
 
-      return (Element => Position.Node.Element'Access);
+      declare
+         T : Tree_Type renames Position.Container.all.Tree;
+         B : Natural renames T.Busy;
+         L : Natural renames T.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Position.Node.Element'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    function Constant_Reference
@@ -354,7 +380,20 @@ 
          raise Constraint_Error with "key not in map";
       end if;
 
-      return (Element => Node.Element'Access);
+      declare
+         T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
+         B : Natural renames T.Busy;
+         L : Natural renames T.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Node.Element'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -532,6 +571,22 @@ 
       end if;
    end Finalize;
 
+   procedure Finalize (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            T : Tree_Type renames Control.Container.all.Tree;
+            B : Natural renames T.Busy;
+            L : Natural renames T.Lock;
+         begin
+            B := B - 1;
+            L := L - 1;
+         end;
+
+         Control.Container := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -1294,7 +1349,19 @@ 
       pragma Assert (Vet (Container.Tree, Position.Node),
                      "Position cursor in function Reference is bad");
 
-      return (Element => Position.Node.Element'Access);
+      declare
+         T : Tree_Type renames Position.Container.all.Tree;
+         B : Natural renames T.Busy;
+         L : Natural renames T.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => Position.Node.Element'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    function Reference
@@ -1308,7 +1375,20 @@ 
          raise Constraint_Error with "key not in map";
       end if;
 
-      return (Element => Node.Element'Access);
+      declare
+         T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
+         B : Natural renames T.Busy;
+         L : Natural renames T.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => Node.Element'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    -------------
Index: a-coorma.ads
===================================================================
--- a-coorma.ads	(revision 184330)
+++ a-coorma.ads	(working copy)
@@ -108,18 +108,22 @@ 
    function Constant_Reference
      (Container : aliased Map;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Map;
       Position  : Cursor) return Reference_Type;
+   pragma Inline (Reference);
 
    function Constant_Reference
      (Container : aliased Map;
       Key       : Key_Type) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Map;
       Key       : Key_Type) return Reference_Type;
+   pragma Inline (Reference);
 
    procedure Assign (Target : in out Map; Source : Map);
 
@@ -293,8 +297,22 @@ 
 
    for Cursor'Read use Read;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : Map_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-      (Element : not null access constant Element_Type) is null record;
+      (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
@@ -309,7 +327,10 @@ 
    for Constant_Reference_Type'Write use Write;
 
    type Reference_Type
-      (Element : not null access Element_Type) is null record;
+      (Element : not null access Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
Index: a-cidlli.adb
===================================================================
--- a-cidlli.adb	(revision 184330)
+++ a-cidlli.adb	(working copy)
@@ -166,6 +166,20 @@ 
       end loop;
    end Adjust;
 
+   procedure Adjust (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            C : List 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 --
    ------------
@@ -271,7 +285,19 @@ 
 
       pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
 
-      return (Element => Position.Node.Element.all'Access);
+      declare
+         C : List renames Position.Container.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Position.Node.Element.all'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -479,6 +505,22 @@ 
       end if;
    end Finalize;
 
+   procedure Finalize (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            C : List 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 --
    ----------
@@ -1372,7 +1414,19 @@ 
 
       pragma Assert (Vet (Position), "bad cursor in function Reference");
 
-      return (Element => Position.Node.Element.all'Access);
+      declare
+         C : List renames Position.Container.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => Position.Node.Element.all'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    ---------------------
Index: a-cidlli.ads
===================================================================
--- a-cidlli.ads	(revision 184330)
+++ a-cidlli.ads	(working copy)
@@ -103,10 +103,12 @@ 
    function Constant_Reference
      (Container : aliased List;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out List;
       Position  : Cursor) return Reference_Type;
+   pragma Inline (Reference);
 
    procedure Assign (Target : in out List; Source : List);
 
@@ -299,8 +301,22 @@ 
 
    for Cursor'Write use Write;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : List_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-      (Element : not null access constant Element_Type) is null record;
+      (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
@@ -315,7 +331,10 @@ 
    for Constant_Reference_Type'Read use Read;
 
    type Reference_Type
-      (Element : not null access Element_Type) is null record;
+      (Element : not null access Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
Index: a-cimutr.adb
===================================================================
--- a-cimutr.adb	(revision 184330)
+++ a-cimutr.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, 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- --
@@ -204,6 +204,20 @@ 
       Container.Count := Source_Count;
    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;
+
    -------------------
    -- Ancestor_Find --
    -------------------
@@ -472,7 +486,20 @@ 
       --  pragma Assert (Vet (Position),
       --                 "Position cursor in Constant_Reference is bad");
 
-      return (Element => Position.Node.Element.all'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 => Position.Node.Element.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -985,6 +1012,22 @@ 
       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 --
    ----------
@@ -2041,7 +2084,19 @@ 
       --  pragma Assert (Vet (Position),
       --                 "Position cursor in Constant_Reference is bad");
 
-      return (Element => Position.Node.Element.all'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 => Position.Node.Element.all'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    --------------------
Index: a-cimutr.ads
===================================================================
--- a-cimutr.ads	(revision 184330)
+++ a-cimutr.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -112,10 +112,12 @@ 
    function Constant_Reference
      (Container : aliased Tree;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Tree;
       Position  : Cursor) return Reference_Type;
+   pragma Inline (Reference);
 
    procedure Assign (Target : in out Tree; Source : Tree);
 
@@ -378,8 +380,22 @@ 
 
    for Cursor'Read use Read;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : Tree_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-     (Element : not null access constant Element_Type) is null record;
+     (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
@@ -394,7 +410,10 @@ 
    for Constant_Reference_Type'Write use Write;
 
    type Reference_Type
-     (Element : not null access Element_Type) is null record;
+     (Element : not null access Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
Index: a-cihase.adb
===================================================================
--- a-cihase.adb	(revision 184330)
+++ a-cihase.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, 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- --
@@ -165,6 +165,20 @@ 
       HT_Ops.Adjust (Container.HT);
    end Adjust;
 
+   procedure Adjust (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            HT : Hash_Table_Type renames Control.Container.all.HT;
+            B : Natural renames HT.Busy;
+            L : Natural renames HT.Lock;
+         begin
+            B := B + 1;
+            L := L + 1;
+         end;
+      end if;
+   end Adjust;
+
    ------------
    -- Assign --
    ------------
@@ -228,7 +242,20 @@ 
 
       pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
 
-      return (Element => Position.Node.Element.all'Access);
+      declare
+         HT : Hash_Table_Type renames Position.Container.all.HT;
+         B : Natural renames HT.Busy;
+         L : Natural renames HT.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Position.Node.Element.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -610,6 +637,22 @@ 
       end if;
    end Finalize;
 
+   procedure Finalize (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            HT : Hash_Table_Type renames Control.Container.all.HT;
+            B : Natural renames HT.Busy;
+            L : Natural renames HT.Lock;
+         begin
+            B := B - 1;
+            L := L - 1;
+         end;
+
+         Control.Container := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -1926,7 +1969,20 @@ 
             raise Program_Error with "Node has no element";
          end if;
 
-         return (Element => Node.Element.all'Access);
+         declare
+            HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
+            B : Natural renames HT.Busy;
+            L : Natural renames HT.Lock;
+         begin
+            return R : constant Constant_Reference_Type :=
+                         (Element => Node.Element.all'Access,
+                          Control =>
+                            (Controlled with Container'Unrestricted_Access))
+            do
+               B := B + 1;
+               L := L + 1;
+            end return;
+         end;
       end Constant_Reference;
 
       --------------
Index: a-cihase.ads
===================================================================
--- a-cihase.ads	(revision 184330)
+++ a-cihase.ads	(working copy)
@@ -152,6 +152,7 @@ 
    function Constant_Reference
      (Container : aliased Set;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    procedure Assign (Target : in out Set; Source : Set);
 
@@ -507,8 +508,22 @@ 
 
    for Cursor'Read use Read;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : Set_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-     (Element : not null access constant Element_Type) is null record;
+     (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
Index: a-cohama.adb
===================================================================
--- a-cohama.adb	(revision 184330)
+++ a-cohama.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, 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- --
@@ -135,6 +135,20 @@ 
       HT_Ops.Adjust (Container.HT);
    end Adjust;
 
+   procedure Adjust (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            HT : Hash_Table_Type renames Control.Container.all.HT;
+            B  : Natural renames HT.Busy;
+            L  : Natural renames HT.Lock;
+         begin
+            B := B + 1;
+            L := L + 1;
+         end;
+      end if;
+   end Adjust;
+
    ------------
    -- Assign --
    ------------
@@ -211,7 +225,19 @@ 
         (Vet (Position),
          "Position cursor in Constant_Reference is bad");
 
-      return (Element => Position.Node.Element'Access);
+      declare
+         HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
+         B  : Natural renames HT.Busy;
+         L  : Natural renames HT.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Position.Node.Element'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    function Constant_Reference
@@ -225,7 +251,20 @@ 
          raise Constraint_Error with "key not in map";
       end if;
 
-      return (Element => Node.Element'Access);
+      declare
+         HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
+         B  : Natural renames HT.Busy;
+         L  : Natural renames HT.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Node.Element'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -439,6 +478,22 @@ 
       end if;
    end Finalize;
 
+   procedure Finalize (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            HT : Hash_Table_Type renames Control.Container.all.HT;
+            B  : Natural renames HT.Busy;
+            L  : Natural renames HT.Lock;
+         begin
+            B := B - 1;
+            L := L - 1;
+         end;
+
+         Control.Container := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -920,7 +975,19 @@ 
         (Vet (Position),
          "Position cursor in function Reference is bad");
 
-      return (Element => Position.Node.Element'Access);
+      declare
+         HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
+         B  : Natural renames HT.Busy;
+         L  : Natural renames HT.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => Position.Node.Element'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    function Reference
@@ -934,7 +1001,20 @@ 
          raise Constraint_Error with "key not in map";
       end if;
 
-      return (Element => Node.Element'Access);
+      declare
+         HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
+         B  : Natural renames HT.Busy;
+         L  : Natural renames HT.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => Node.Element'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    ---------------
Index: a-cohama.ads
===================================================================
--- a-cohama.ads	(revision 184330)
+++ a-cohama.ads	(working copy)
@@ -148,18 +148,22 @@ 
    function Constant_Reference
      (Container : aliased Map;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Map;
       Position  : Cursor) return Reference_Type;
+   pragma Inline (Reference);
 
    function Constant_Reference
      (Container : aliased Map;
       Key       : Key_Type) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Map;
       Key       : Key_Type) return Reference_Type;
+   pragma Inline (Reference);
 
    procedure Assign (Target : in out Map; Source : Map);
 
@@ -369,8 +373,22 @@ 
 
    for Cursor'Write use Write;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : Map_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-      (Element : not null access constant Element_Type) is null record;
+      (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
@@ -385,7 +403,10 @@ 
    for Constant_Reference_Type'Read use Read;
 
    type Reference_Type
-      (Element : not null access Element_Type) is null record;
+      (Element : not null access Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
Index: a-coorse.adb
===================================================================
--- a-coorse.adb	(revision 184330)
+++ a-coorse.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, 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- --
@@ -285,6 +285,20 @@ 
       Adjust (Container.Tree);
    end Adjust;
 
+   procedure Adjust (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            Tree : Tree_Type renames Control.Container.all.Tree;
+            B : Natural renames Tree.Busy;
+            L : Natural renames Tree.Lock;
+         begin
+            B := B + 1;
+            L := L + 1;
+         end;
+      end if;
+   end Adjust;
+
    ------------
    -- Assign --
    ------------
@@ -353,7 +367,20 @@ 
         (Vet (Container.Tree, Position.Node),
          "bad cursor in Constant_Reference");
 
-      return (Element => Position.Node.Element'Access);
+      declare
+         Tree : Tree_Type renames Position.Container.all.Tree;
+         B : Natural renames Tree.Busy;
+         L : Natural renames Tree.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Position.Node.Element'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -554,6 +581,22 @@ 
       end if;
    end Finalize;
 
+   procedure Finalize (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            Tree : Tree_Type renames Control.Container.all.Tree;
+            B : Natural renames Tree.Busy;
+            L : Natural renames Tree.Lock;
+         begin
+            B := B - 1;
+            L := L - 1;
+         end;
+
+         Control.Container := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -699,7 +742,20 @@ 
             raise Constraint_Error with "key not in set";
          end if;
 
-         return (Element => Node.Element'Access);
+         declare
+            Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
+            B : Natural renames Tree.Busy;
+            L : Natural renames Tree.Lock;
+         begin
+            return R : constant Constant_Reference_Type :=
+                         (Element => Node.Element'Access,
+                          Control =>
+                            (Controlled with Container'Unrestricted_Access))
+            do
+               B := B + 1;
+               L := L + 1;
+            end return;
+         end;
       end Constant_Reference;
 
       --------------
Index: a-coorse.ads
===================================================================
--- a-coorse.ads	(revision 184330)
+++ a-coorse.ads	(working copy)
@@ -100,6 +100,7 @@ 
    function Constant_Reference
      (Container : aliased Set;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    procedure Assign (Target : in out Set; Source : Set);
 
@@ -359,8 +360,22 @@ 
 
    for Cursor'Read use Read;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : Set_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-      (Element : not null access constant Element_Type) is null record;
+      (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
Index: a-comutr.adb
===================================================================
--- a-comutr.adb	(revision 184330)
+++ a-comutr.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, 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- --
@@ -206,6 +206,20 @@ 
       Container.Count := Source_Count;
    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;
+
    -------------------
    -- Ancestor_Find --
    -------------------
@@ -464,7 +478,20 @@ 
       --  pragma Assert (Vet (Position),
       --                 "Position cursor in Constant_Reference is bad");
 
-      return (Element => Position.Node.Element'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 => Position.Node.Element'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -957,6 +984,22 @@ 
       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 --
    ----------
@@ -2053,7 +2096,19 @@ 
       --  pragma Assert (Vet (Position),
       --                 "Position cursor in Constant_Reference is bad");
 
-      return (Element => Position.Node.Element'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 => Position.Node.Element'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    --------------------
Index: a-comutr.ads
===================================================================
--- a-comutr.ads	(revision 184330)
+++ a-comutr.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -111,10 +111,12 @@ 
    function Constant_Reference
      (Container : aliased Tree;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Tree;
       Position  : Cursor) return Reference_Type;
+   pragma Inline (Reference);
 
    procedure Assign (Target : in out Tree; Source : Tree);
 
@@ -423,8 +425,22 @@ 
 
    for Cursor'Read use Read;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : Tree_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-     (Element : not null access constant Element_Type) is null record;
+     (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
@@ -439,7 +455,10 @@ 
    for Constant_Reference_Type'Write use Write;
 
    type Reference_Type
-     (Element : not null access Element_Type) is null record;
+     (Element : not null access Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
Index: a-ciorma.adb
===================================================================
--- a-ciorma.adb	(revision 184330)
+++ a-ciorma.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, 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- --
@@ -291,6 +291,20 @@ 
       Adjust (Container.Tree);
    end Adjust;
 
+   procedure Adjust (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            T : Tree_Type renames Control.Container.all.Tree;
+            B : Natural renames T.Busy;
+            L : Natural renames T.Lock;
+         begin
+            B := B + 1;
+            L := L + 1;
+         end;
+      end if;
+   end Adjust;
+
    ------------
    -- Assign --
    ------------
@@ -379,7 +393,20 @@ 
       pragma Assert (Vet (Container.Tree, Position.Node),
                      "Position cursor in Constant_Reference is bad");
 
-      return (Element => Position.Node.Element.all'Access);
+      declare
+         T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
+         B : Natural renames T.Busy;
+         L : Natural renames T.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Position.Node.Element.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    function Constant_Reference
@@ -397,7 +424,20 @@ 
          raise Program_Error with "Node has no element";
       end if;
 
-      return (Element => Node.Element.all'Access);
+      declare
+         T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
+         B : Natural renames T.Busy;
+         L : Natural renames T.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Node.Element.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -586,6 +626,22 @@ 
       end if;
    end Finalize;
 
+   procedure Finalize (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            T : Tree_Type renames Control.Container.all.Tree;
+            B : Natural renames T.Busy;
+            L : Natural renames T.Lock;
+         begin
+            B := B - 1;
+            L := L - 1;
+         end;
+
+         Control.Container := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -1360,7 +1416,19 @@ 
       pragma Assert (Vet (Container.Tree, Position.Node),
                      "Position cursor in function Reference is bad");
 
-      return (Element => Position.Node.Element.all'Access);
+      declare
+         T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
+         B : Natural renames T.Busy;
+         L : Natural renames T.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => Position.Node.Element.all'Access,
+                       Control => (Controlled with Position.Container))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    function Reference
@@ -1378,7 +1446,20 @@ 
          raise Program_Error with "Node has no element";
       end if;
 
-      return (Element => Node.Element.all'Access);
+      declare
+         T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
+         B : Natural renames T.Busy;
+         L : Natural renames T.Lock;
+      begin
+         return R : constant Reference_Type :=
+                      (Element => Node.Element.all'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Reference;
 
    -------------
Index: a-ciorma.ads
===================================================================
--- a-ciorma.ads	(revision 184330)
+++ a-ciorma.ads	(working copy)
@@ -109,18 +109,22 @@ 
    function Constant_Reference
      (Container : aliased Map;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Map;
       Position  : Cursor) return Reference_Type;
+   pragma Inline (Reference);
 
    function Constant_Reference
      (Container : aliased Map;
       Key       : Key_Type) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Map;
       Key       : Key_Type) return Reference_Type;
+   pragma Inline (Reference);
 
    procedure Assign (Target : in out Map; Source : Map);
 
@@ -292,8 +296,22 @@ 
 
    for Cursor'Read use Read;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : Map_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-      (Element : not null access constant Element_Type) is null record;
+      (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
@@ -308,7 +326,10 @@ 
    for Constant_Reference_Type'Write use Write;
 
    type Reference_Type
-      (Element : not null access Element_Type) is null record;
+      (Element : not null access Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;
Index: a-convec.adb
===================================================================
--- a-convec.adb	(revision 184330)
+++ a-convec.adb	(working copy)
@@ -396,6 +396,20 @@ 
       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 --
    ------------
@@ -499,7 +513,21 @@ 
          raise Constraint_Error with "Position cursor is out of range";
       end if;
 
-      return (Element => Container.Elements.EA (Position.Index)'Access);
+      declare
+         C : Vector renames Position.Container.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+      begin
+         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;
    end Constant_Reference;
 
    function Constant_Reference
@@ -510,7 +538,20 @@ 
       if Index > Container.Last then
          raise Constraint_Error with "Index is out of range";
       else
-         return (Element => Container.Elements.EA (Index)'Access);
+         declare
+            C : Vector renames Container'Unrestricted_Access.all;
+            B : Natural renames C.Busy;
+            L : Natural renames C.Lock;
+         begin
+            return R : constant Constant_Reference_Type :=
+                         (Element => Container.Elements.EA (Index)'Access,
+                          Control =>
+                            (Controlled with Container'Unrestricted_Access))
+            do
+               B := B + 1;
+               L := L + 1;
+            end return;
+         end;
       end if;
    end Constant_Reference;
 
@@ -825,6 +866,22 @@ 
       B := B - 1;
    end Finalize;
 
+   procedure Finalize (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;
+
+         Control.Container := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -2601,7 +2658,20 @@ 
          raise Constraint_Error with "Position cursor is out of range";
       end if;
 
-      return (Element => Container.Elements.EA (Position.Index)'Access);
+      declare
+         C : Vector renames Position.Container.all;
+         B : Natural renames C.Busy;
+         L : Natural renames C.Lock;
+      begin
+         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;
    end Reference;
 
    function Reference
@@ -2612,7 +2682,20 @@ 
       if Index > Container.Last then
          raise Constraint_Error with "Index is out of range";
       else
-         return (Element => Container.Elements.EA (Index)'Access);
+         declare
+            C : Vector renames Container'Unrestricted_Access.all;
+            B : Natural renames C.Busy;
+            L : Natural renames C.Lock;
+         begin
+            return R : constant Reference_Type :=
+                         (Element => Container.Elements.EA (Index)'Access,
+                          Control =>
+                            (Controlled with Container'Unrestricted_Access))
+            do
+               B := B + 1;
+               L := L + 1;
+            end return;
+         end;
       end if;
    end Reference;
 
Index: a-convec.ads
===================================================================
--- a-convec.ads	(revision 184330)
+++ a-convec.ads	(working copy)
@@ -158,18 +158,22 @@ 
    function Constant_Reference
      (Container : aliased Vector;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Vector;
       Position  : Cursor) return Reference_Type;
+   pragma Inline (Reference);
 
    function Constant_Reference
      (Container : aliased Vector;
       Index     : Index_Type) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    function Reference
      (Container : aliased in out Vector;
       Index     : Index_Type) return Reference_Type;
+   pragma Inline (Reference);
 
    procedure Assign (Target : in out Vector; Source : Vector);
 
@@ -416,8 +420,22 @@ 
 
    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);
+
    type Constant_Reference_Type
-      (Element : not null access constant Element_Type) is null record;
+      (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
@@ -432,7 +450,10 @@ 
    for Constant_Reference_Type'Read use Read;
 
    type Reference_Type
-      (Element : not null access Element_Type) is null record;
+      (Element : not null access Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Write
      (Stream : not null access Root_Stream_Type'Class;
Index: a-cohase.adb
===================================================================
--- a-cohase.adb	(revision 184330)
+++ a-cohase.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, 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- --
@@ -161,6 +161,20 @@ 
       HT_Ops.Adjust (Container.HT);
    end Adjust;
 
+   procedure Adjust (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            HT : Hash_Table_Type renames Control.Container.all.HT;
+            B : Natural renames HT.Busy;
+            L : Natural renames HT.Lock;
+         begin
+            B := B + 1;
+            L := L + 1;
+         end;
+      end if;
+   end Adjust;
+
    ------------
    -- Assign --
    ------------
@@ -218,7 +232,20 @@ 
 
       pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
 
-      return (Element => Position.Node.Element'Access);
+      declare
+         HT : Hash_Table_Type renames Position.Container.all.HT;
+         B : Natural renames HT.Busy;
+         L : Natural renames HT.Lock;
+      begin
+         return R : constant Constant_Reference_Type :=
+                      (Element => Position.Node.Element'Access,
+                       Control =>
+                         (Controlled with Container'Unrestricted_Access))
+         do
+            B := B + 1;
+            L := L + 1;
+         end return;
+      end;
    end Constant_Reference;
 
    --------------
@@ -548,6 +575,22 @@ 
       HT_Ops.Finalize (Container.HT);
    end Finalize;
 
+   procedure Finalize (Control : in out Reference_Control_Type) is
+   begin
+      if Control.Container /= null then
+         declare
+            HT : Hash_Table_Type renames Control.Container.all.HT;
+            B : Natural renames HT.Busy;
+            L : Natural renames HT.Lock;
+         begin
+            B := B - 1;
+            L := L - 1;
+         end;
+
+         Control.Container := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -1746,7 +1789,20 @@ 
             raise Constraint_Error with "Key not in set";
          end if;
 
-         return (Element => Node.Element'Access);
+         declare
+            HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
+            B : Natural renames HT.Busy;
+            L : Natural renames HT.Lock;
+         begin
+            return R : constant Constant_Reference_Type :=
+                         (Element => Node.Element'Access,
+                          Control =>
+                            (Controlled with Container'Unrestricted_Access))
+            do
+               B := B + 1;
+               L := L + 1;
+            end return;
+         end;
       end Constant_Reference;
 
       --------------
Index: a-cohase.ads
===================================================================
--- a-cohase.ads	(revision 184330)
+++ a-cohase.ads	(working copy)
@@ -153,6 +153,7 @@ 
    function Constant_Reference
      (Container : aliased Set;
       Position  : Cursor) return Constant_Reference_Type;
+   pragma Inline (Constant_Reference);
 
    procedure Assign (Target : in out Set; Source : Set);
 
@@ -509,8 +510,22 @@ 
 
    for Cursor'Read use Read;
 
+   type Reference_Control_Type is
+      new Controlled with record
+         Container : Set_Access;
+      end record;
+
+   overriding procedure Adjust (Control : in out Reference_Control_Type);
+   pragma Inline (Adjust);
+
+   overriding procedure Finalize (Control : in out Reference_Control_Type);
+   pragma Inline (Finalize);
+
    type Constant_Reference_Type
-     (Element : not null access constant Element_Type) is null record;
+     (Element : not null access constant Element_Type) is
+      record
+         Control : Reference_Control_Type;
+      end record;
 
    procedure Read
      (Stream : not null access Root_Stream_Type'Class;