exp_ch13.adb: Add with and use clause for Targparm;

2011-08-03  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch13.adb: Add with and use clause for Targparm;
	(Expand_N_Free_Statement): Prevent the generation of a custom
	Deallocate on .NET/JVM targets since this requires pools and address
	arithmetic.
	* exp_ch4.adb (Expand_Allocator_Expression): When compiling for
	.NET/JVM targets, attach the newly allocated object to the access
	type's finalization collection. Do not generate a call to
	Set_Finalize_Address_Ptr on .NET/JVM because this routine does not
	exist in the runtime.
	(Expand_N_Allocator): When compiling for .NET/JVM targets, do not
	create a custom Allocate for object that do not require initialization.
	Attach a newly allocated object to the access type's finalization
	collection on .NET/JVM.
	* exp_ch5.adb (Make_Tag_Ctrl_Assignment): Add special processing for
	assignment of controlled types on .NET/JVM. The two hidden pointers
	Prev and Next and stored and later restored after the assignment takes
	place.
	* exp_ch6.adb (Expand_Call): Add local constant Curr_S. Add specialized
	kludge for .NET/JVM to recognize a particular piece of code coming from
	Heap_Management and change the call to Finalize into Deep_Finalize.
	* exp_ch7.adb (Build_Finalization_Collection): Allow the creation of
	finalization collections on .NET/JVM only for types derived from
	Controlled. Separate the association of storage pools with a collection
	and only allow it on non-.NET/JVM targets.
	(Make_Attach_Call): New routine.
	(Make_Detach_Call): New routine.
	(Process_Object_Declarations): Suppress the generation of
	build-in-place return object clean up code on .NET/JVM since it uses
	pools.
	* exp_ch7.ads (Make_Attach_Call): New routine.
	(Make_Detach_Call): New routine.
	* exp_intr.adb Add with and use clause for Targparm.
	(Expand_Unc_Deallocation): Detach a controlled object from a collection
	on .NET/JVM targets.
	* rtsfind.ads: Add entries RE_Attach, RE_Detach and
	RE_Root_Controlled_Ptr to tables RE_Id and RE_Unit_Table.
	* snames.ads-tmpl: Add name Name_Prev. Move Name_Prev to the special
	names used in finalization.

2011-08-03  Hristian Kirtchev  <kirtchev@adacore.com>

	* a-fihema.adb: Add with and use clauses for System.Soft_Links.
	(Attach, Detach): Lock the current task when chaining an object onto a
	collection.

From-SVN: r177276

gcc/ada/ChangeLog

 2011-08-03  Hristian Kirtchev  <kirtchev@adacore.com>
 
+	* exp_ch13.adb: Add with and use clause for Targparm;
+	(Expand_N_Free_Statement): Prevent the generation of a custom
+	Deallocate on .NET/JVM targets since this requires pools and address
+	arithmetic.
+	* exp_ch4.adb (Expand_Allocator_Expression): When compiling for
+	.NET/JVM targets, attach the newly allocated object to the access
+	type's finalization collection. Do not generate a call to
+	Set_Finalize_Address_Ptr on .NET/JVM because this routine does not
+	exist in the runtime.
+	(Expand_N_Allocator): When compiling for .NET/JVM targets, do not
+	create a custom Allocate for object that do not require initialization.
+	Attach a newly allocated object to the access type's finalization
+	collection on .NET/JVM.
+	* exp_ch5.adb (Make_Tag_Ctrl_Assignment): Add special processing for
+	assignment of controlled types on .NET/JVM. The two hidden pointers
+	Prev and Next and stored and later restored after the assignment takes
+	place.
+	* exp_ch6.adb (Expand_Call): Add local constant Curr_S. Add specialized
+	kludge for .NET/JVM to recognize a particular piece of code coming from
+	Heap_Management and change the call to Finalize into Deep_Finalize.
+	* exp_ch7.adb (Build_Finalization_Collection): Allow the creation of
+	finalization collections on .NET/JVM only for types derived from
+	Controlled. Separate the association of storage pools with a collection
+	and only allow it on non-.NET/JVM targets.
+	(Make_Attach_Call): New routine.
+	(Make_Detach_Call): New routine.
+	(Process_Object_Declarations): Suppress the generation of
+	build-in-place return object clean up code on .NET/JVM since it uses
+	pools.
+	* exp_ch7.ads (Make_Attach_Call): New routine.
+	(Make_Detach_Call): New routine.
+	* exp_intr.adb Add with and use clause for Targparm.
+	(Expand_Unc_Deallocation): Detach a controlled object from a collection
+	on .NET/JVM targets.
+	* rtsfind.ads: Add entries RE_Attach, RE_Detach and
+	RE_Root_Controlled_Ptr to tables RE_Id and RE_Unit_Table.
+	* snames.ads-tmpl: Add name Name_Prev. Move Name_Prev to the special
+	names used in finalization.
+
+2011-08-03  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* a-fihema.adb: Add with and use clauses for System.Soft_Links.
+	(Attach, Detach): Lock the current task when chaining an object onto a
+	collection.
+
+2011-08-03  Hristian Kirtchev  <kirtchev@adacore.com>
+
 	* a-except.adb, a-except-2005.adb (Raise_From_Controlled_Operation):
 	Rewritten to create the message strings when the exception is not
 	raised by an abort during finalization.

gcc/ada/a-fihema.adb

@@ -37,6 +37,7 @@ with GNAT.IO;                 use GNAT.IO;
 
 with System;                  use System;
 with System.Address_Image;
+with System.Soft_Links;       use System.Soft_Links;
 with System.Storage_Elements; use System.Storage_Elements;
 with System.Storage_Pools;    use System.Storage_Pools;
 
@@ -135,10 +136,18 @@ package body Ada.Finalization.Heap_Management is
 
    procedure Attach (N : Node_Ptr; L : Node_Ptr) is
    begin
+      Lock_Task.all;
+
       L.Next.Prev := N;
       N.Next := L.Next;
       L.Next := N;
       N.Prev := L;
+
+      Unlock_Task.all;
+   exception
+      when others =>
+         Unlock_Task.all;
+         raise;
    end Attach;
 
    ---------------
@@ -209,6 +218,8 @@ package body Ada.Finalization.Heap_Management is
 
    procedure Detach (N : Node_Ptr) is
    begin
+      Lock_Task.all;
+
       if N.Prev /= null
         and then N.Next /= null
       then
@@ -217,6 +228,12 @@ package body Ada.Finalization.Heap_Management is
          N.Prev := null;
          N.Next := null;
       end if;
+
+      Unlock_Task.all;
+   exception
+      when others =>
+         Unlock_Task.all;
+         raise;
    end Detach;
 
    --------------

gcc/ada/exp_ch13.adb

@@ -43,6 +43,7 @@ with Sem_Eval; use Sem_Eval;
 with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;
+with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
 with Validsw;  use Validsw;
@@ -214,6 +215,13 @@ package body Exp_Ch13 is
       Typ  : Entity_Id := Etype (Expr);
 
    begin
+      --  Do not create a specialized Deallocate since .NET/JVM compilers do
+      --  not support pools and address arithmetic.
+
+      if VM_Target /= No_VM then
+         return;
+      end if;
+
       --  Use the base type to perform the collection check
 
       if Ekind (Typ) = E_Access_Subtype then

gcc/ada/exp_ch4.adb

@@ -840,6 +840,22 @@ package body Exp_Ch4 is
                Complete_Controlled_Allocation (Temp_Decl);
                Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
 
+               --  Attach the object to the associated finalization collection.
+               --  This is done manually on .NET/JVM since those compilers do
+               --  no support pools and can't benefit from internally generated
+               --  Allocate / Deallocate procedures.
+
+               if VM_Target /= No_VM
+                 and then Is_Controlled (DesigT)
+                 and then Present (Associated_Collection (PtrT))
+               then
+                  Insert_Action (N,
+                    Make_Attach_Call (
+                      Obj_Ref =>
+                        New_Reference_To (Temp, Loc),
+                      Ptr_Typ => PtrT));
+               end if;
+
             else
                Node := Relocate_Node (N);
                Set_Analyzed (Node);
@@ -853,6 +869,22 @@ package body Exp_Ch4 is
 
                Insert_Action (N, Temp_Decl);
                Complete_Controlled_Allocation (Temp_Decl);
+
+               --  Attach the object to the associated finalization collection.
+               --  This is done manually on .NET/JVM since those compilers do
+               --  no support pools and can't benefit from internally generated
+               --  Allocate / Deallocate procedures.
+
+               if VM_Target /= No_VM
+                 and then Is_Controlled (DesigT)
+                 and then Present (Associated_Collection (PtrT))
+               then
+                  Insert_Action (N,
+                    Make_Attach_Call (
+                      Obj_Ref =>
+                        New_Reference_To (Temp, Loc),
+                      Ptr_Typ => PtrT));
+               end if;
             end if;
 
          --  Ada 2005 (AI-251): Handle allocators whose designated type is an
@@ -1040,7 +1072,12 @@ package body Exp_Ch4 is
             --    Set_Finalize_Address_Ptr
             --      (Collection, <Finalize_Address>'Unrestricted_Access)
 
-            if Present (Associated_Collection (PtrT)) then
+            --  Since .NET/JVM compilers do not support address arithmetic,
+            --  this call is skipped.
+
+            if VM_Target = No_VM
+              and then Present (Associated_Collection (PtrT))
+            then
                Insert_Action (N,
                  Make_Set_Finalize_Address_Ptr_Call (
                    Loc     => Loc,
@@ -1085,6 +1122,22 @@ package body Exp_Ch4 is
          Complete_Controlled_Allocation (Temp_Decl);
          Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
 
+         --  Attach the object to the associated finalization collection. This
+         --  is done manually on .NET/JVM since those compilers do no support
+         --  pools and cannot benefit from internally generated Allocate and
+         --  Deallocate procedures.
+
+         if VM_Target /= No_VM
+           and then Is_Controlled (DesigT)
+           and then Present (Associated_Collection (PtrT))
+         then
+            Insert_Action (N,
+              Make_Attach_Call (
+                Obj_Ref =>
+                  New_Reference_To (Temp, Loc),
+                Ptr_Typ => PtrT));
+         end if;
+
          Rewrite (N, New_Reference_To (Temp, Loc));
          Analyze_And_Resolve (N, PtrT);
 
@@ -3477,9 +3530,12 @@ package body Exp_Ch4 is
          if No_Initialization (N) then
 
             --  Even though this might be a simple allocation, create a custom
-            --  Allocate if the context requires it.
+            --  Allocate if the context requires it. Since .NET/JVM compilers
+            --  do not support pools, this step is skipped.
 
-            if Present (Associated_Collection (PtrT)) then
+            if VM_Target = No_VM
+              and then Present (Associated_Collection (PtrT))
+            then
                Build_Allocate_Deallocate_Proc
                  (N           => Parent (N),
                   Is_Allocate => True);
@@ -3759,7 +3815,8 @@ package body Exp_Ch4 is
                else
                   Insert_Action (N,
                     Make_Procedure_Call_Statement (Loc,
-                      Name                   => New_Reference_To (Init, Loc),
+                      Name =>
+                        New_Reference_To (Init, Loc),
                       Parameter_Associations => Args));
                end if;
 
@@ -3773,16 +3830,36 @@ package body Exp_Ch4 is
                       Obj_Ref => New_Copy_Tree (Init_Arg1),
                       Typ     => T));
 
-                  --  Generate:
-                  --    Set_Finalize_Address_Ptr
-                  --      (Pool, <Finalize_Address>'Unrestricted_Access)
-
                   if Present (Associated_Collection (PtrT)) then
-                     Insert_Action (N,
-                       Make_Set_Finalize_Address_Ptr_Call (
-                         Loc     => Loc,
-                         Typ     => T,
-                         Ptr_Typ => PtrT));
+
+                     --  Special processing for .NET/JVM, the allocated object
+                     --  is attached to the finalization collection. Generate:
+
+                     --    Attach (<PtrT>FC, Root_Controlled_Ptr (Init_Arg1));
+
+                     --  Types derived from [Limited_]Controlled are the only
+                     --  ones considered since they have fields Prev and Next.
+
+                     if VM_Target /= No_VM then
+                        if Is_Controlled (T) then
+                           Insert_Action (N,
+                             Make_Attach_Call (
+                               Obj_Ref => New_Copy_Tree (Init_Arg1),
+                               Ptr_Typ => PtrT));
+                        end if;
+
+                     --  Default case, generate:
+
+                     --    Set_Finalize_Address_Ptr
+                     --      (Pool, <Finalize_Address>'Unrestricted_Access)
+
+                     else
+                        Insert_Action (N,
+                          Make_Set_Finalize_Address_Ptr_Call (
+                            Loc     => Loc,
+                            Typ     => T,
+                            Ptr_Typ => PtrT));
+                     end if;
                   end if;
                end if;
 

gcc/ada/exp_ch5.adb

@@ -3496,7 +3496,9 @@ package body Exp_Ch5 is
       --  Tags are not saved and restored when VM_Target because VM tags are
       --  represented implicitly in objects.
 
-      Tag_Tmp : Entity_Id;
+      Next_Id : Entity_Id;
+      Prev_Id : Entity_Id;
+      Tag_Id  : Entity_Id;
 
    begin
       --  Finalize the target of the assignment when controlled
@@ -3535,14 +3537,14 @@ package body Exp_Ch5 is
              Typ     => Etype (L)));
       end if;
 
-      --  Save the Tag in a local variable Tag_Tmp
+      --  Save the Tag in a local variable Tag_Id
 
       if Save_Tag then
-         Tag_Tmp := Make_Temporary (Loc, 'A');
+         Tag_Id := Make_Temporary (Loc, 'A');
 
          Append_To (Res,
            Make_Object_Declaration (Loc,
-             Defining_Identifier => Tag_Tmp,
+             Defining_Identifier => Tag_Id,
              Object_Definition =>
                New_Reference_To (RTE (RE_Tag), Loc),
              Expression =>
@@ -3552,10 +3554,52 @@ package body Exp_Ch5 is
                  Selector_Name =>
                    New_Reference_To (First_Tag_Component (T), Loc))));
 
-      --  Otherwise Tag_Tmp not used
+      --  Otherwise Tag_Id is not used
 
       else
-         Tag_Tmp := Empty;
+         Tag_Id := Empty;
+      end if;
+
+      --  Save the Prev and Next fields on .NET/JVM. This is not needed on non
+      --  VM targets since the fields are not part of the object.
+
+      if VM_Target /= No_VM
+        and then Is_Controlled (T)
+      then
+         Prev_Id := Make_Temporary (Loc, 'P');
+         Next_Id := Make_Temporary (Loc, 'N');
+
+         --  Generate:
+         --    Pnn : Root_Controlled_Ptr := Root_Controlled (L).Prev;
+
+         Append_To (Res,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Prev_Id,
+             Object_Definition =>
+               New_Reference_To (RTE (RE_Root_Controlled_Ptr), Loc),
+             Expression =>
+               Make_Selected_Component (Loc,
+                 Prefix =>
+                   Unchecked_Convert_To
+                     (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+                 Selector_Name =>
+                   Make_Identifier (Loc, Name_Prev))));
+
+         --  Generate:
+         --    Nnn : Root_Controlled_Ptr := Root_Controlled (L).Next;
+
+         Append_To (Res,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Next_Id,
+             Object_Definition =>
+               New_Reference_To (RTE (RE_Root_Controlled_Ptr), Loc),
+             Expression =>
+               Make_Selected_Component (Loc,
+                 Prefix =>
+                   Unchecked_Convert_To
+                     (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+                 Selector_Name =>
+                   Make_Identifier (Loc, Name_Next))));
       end if;
 
       --  If the tagged type has a full rep clause, expand the assignment into
@@ -3577,10 +3621,48 @@ package body Exp_Ch5 is
            Make_Assignment_Statement (Loc,
              Name =>
                Make_Selected_Component (Loc,
-                 Prefix        => Duplicate_Subexpr_No_Checks (L),
-                 Selector_Name => New_Reference_To (First_Tag_Component (T),
-                                                    Loc)),
-             Expression => New_Reference_To (Tag_Tmp, Loc)));
+                 Prefix =>
+                   Duplicate_Subexpr_No_Checks (L),
+                 Selector_Name =>
+                   New_Reference_To (First_Tag_Component (T), Loc)),
+             Expression =>
+               New_Reference_To (Tag_Id, Loc)));
+      end if;
+
+      --  Restore the Prev and Next fields on .NET/JVM
+
+      if VM_Target /= No_VM
+        and then Is_Controlled (T)
+      then
+         --  Generate:
+         --    Root_Controlled (L).Prev := Prev_Id;
+
+         Append_To (Res,
+           Make_Assignment_Statement (Loc,
+             Name =>
+               Make_Selected_Component (Loc,
+                 Prefix =>
+                   Unchecked_Convert_To
+                     (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+                 Selector_Name =>
+                   Make_Identifier (Loc, Name_Prev)),
+             Expression =>
+               New_Reference_To (Prev_Id, Loc)));
+
+         --  Generate:
+         --    Root_Controlled (L).Next := Next_Id;
+
+         Append_To (Res,
+           Make_Assignment_Statement (Loc,
+             Name =>
+               Make_Selected_Component (Loc,
+                 Prefix =>
+                   Unchecked_Convert_To
+                     (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+                 Selector_Name =>
+                   Make_Identifier (Loc, Name_Next)),
+             Expression =>
+               New_Reference_To (Next_Id, Loc)));
       end if;
 
       --  Adjust the target after the assignment when controlled (not in the

gcc/ada/exp_ch6.adb

@@ -2015,7 +2015,8 @@ package body Exp_Ch6 is
 
       --  Local variables
 
-      Remote        : constant Boolean := Is_Remote_Call (Call_Node);
+      Curr_S        : constant Entity_Id := Current_Scope;
+      Remote        : constant Boolean   := Is_Remote_Call (Call_Node);
       Actual        : Node_Id;
       Formal        : Entity_Id;
       Orig_Subp     : Entity_Id := Empty;
@@ -2105,6 +2106,52 @@ package body Exp_Ch6 is
          end if;
       end if;
 
+      --  Detect the following code in Ada.Finalization.Heap_Management only
+      --  on .NET/JVM targets:
+      --
+      --    procedure Finalize (Collection : in out Finalization_Collection) is
+      --    begin
+      --       . . .
+      --       begin
+      --          Finalize (Curr_Ptr.all);
+      --
+      --  Since .NET/JVM compilers lack address arithmetic and Deep_Finalize
+      --  cannot be named in library or user code, the compiler has to install
+      --  a kludge and transform the call to Finalize into Deep_Finalize.
+
+      if VM_Target /= No_VM
+        and then Chars (Subp) = Name_Finalize
+        and then Ekind (Curr_S) = E_Block
+        and then Ekind (Scope (Curr_S)) = E_Procedure
+        and then Chars (Scope (Curr_S)) = Name_Finalize
+        and then Etype (First_Formal (Scope (Curr_S))) =
+                   RTE (RE_Finalization_Collection)
+      then
+         declare
+            Deep_Fin : constant Entity_Id :=
+                         Find_Prim_Op (RTE (RE_Root_Controlled),
+                                       TSS_Deep_Finalize);
+         begin
+            --  Since Root_Controlled is a tagged type, the compiler should
+            --  always generate Deep_Finalize for it.
+
+            pragma Assert (Present (Deep_Fin));
+
+            --  Generate:
+            --    Deep_Finalize (Curr_Ptr.all);
+
+            Rewrite (N,
+              Make_Procedure_Call_Statement (Loc,
+                Name =>
+                  New_Reference_To (Deep_Fin, Loc),
+                Parameter_Associations =>
+                  New_Copy_List_Tree (Parameter_Associations (N))));
+
+            Analyze (N);
+            return;
+         end;
+      end if;
+
       --  Ada 2005 (AI-345): We have a procedure call as a triggering
       --  alternative in an asynchronous select or as an entry call in
       --  a conditional or timed select. Check whether the procedure call

gcc/ada/exp_ch7.adb

@@ -896,9 +896,13 @@ package body Exp_Ch7 is
       then
          return;
 
-      --  Do not process access-to-controlled types on .NET/JVM targets
+      --  For .NET/JVM targets, allow the processing of access-to-controlled
+      --  types where the designated type is explicitly derived from [Limited_]
+      --  Controlled.
 
-      elsif VM_Target /= No_VM then
+      elsif VM_Target /= No_VM
+        and then not Is_Controlled (Desig_Typ)
+      then
          return;
       end if;
 
@@ -933,47 +937,54 @@ package body Exp_Ch7 is
              Object_Definition =>
                New_Reference_To (RTE (RE_Finalization_Collection), Loc)));
 
-         --  If the access type has a user-defined pool, use it as the base
-         --  storage medium for the finalization pool.
+         --  Storage pool selection and attribute decoration of the generated
+         --  collection. Since .NET/JVM compilers do not support pools, this
+         --  step is skipped.
 
-         if Present (Associated_Storage_Pool (Typ)) then
-            Pool_Id := Associated_Storage_Pool (Typ);
+         if VM_Target = No_VM then
 
-         --  Access subtypes must use the storage pool of their base type
+            --  If the access type has a user-defined pool, use it as the base
+            --  storage medium for the finalization pool.
 
-         elsif Ekind (Typ) = E_Access_Subtype then
-            declare
-               Base_Typ : constant Entity_Id := Base_Type (Typ);
+            if Present (Associated_Storage_Pool (Typ)) then
+               Pool_Id := Associated_Storage_Pool (Typ);
 
-            begin
-               if No (Associated_Storage_Pool (Base_Typ)) then
-                  Pool_Id := RTE (RE_Global_Pool_Object);
-                  Set_Associated_Storage_Pool (Base_Typ, Pool_Id);
-               else
-                  Pool_Id := Associated_Storage_Pool (Base_Typ);
-               end if;
-            end;
+            --  Access subtypes must use the storage pool of their base type
 
-         --  The default choice is the global pool
+            elsif Ekind (Typ) = E_Access_Subtype then
+               declare
+                  Base_Typ : constant Entity_Id := Base_Type (Typ);
 
-         else
-            Pool_Id := RTE (RE_Global_Pool_Object);
-            Set_Associated_Storage_Pool (Typ, Pool_Id);
-         end if;
+               begin
+                  if No (Associated_Storage_Pool (Base_Typ)) then
+                     Pool_Id := RTE (RE_Global_Pool_Object);
+                     Set_Associated_Storage_Pool (Base_Typ, Pool_Id);
+                  else
+                     Pool_Id := Associated_Storage_Pool (Base_Typ);
+                  end if;
+               end;
 
-         --  Generate:
-         --    Set_Storage_Pool_Ptr (Fnn, Pool_Id'Unchecked_Access);
+            --  The default choice is the global pool
 
-         Append_To (Actions,
-           Make_Procedure_Call_Statement (Loc,
-             Name =>
-               New_Reference_To (RTE (RE_Set_Storage_Pool_Ptr), Loc),
-             Parameter_Associations => New_List (
-               New_Reference_To (Coll_Id, Loc),
-               Make_Attribute_Reference (Loc,
-                 Prefix =>
-                   New_Reference_To (Pool_Id, Loc),
-                 Attribute_Name => Name_Unrestricted_Access))));
+            else
+               Pool_Id := RTE (RE_Global_Pool_Object);
+               Set_Associated_Storage_Pool (Typ, Pool_Id);
+            end if;
+
+            --  Generate:
+            --    Set_Storage_Pool_Ptr (Fnn, Pool_Id'Unchecked_Access);
+
+            Append_To (Actions,
+              Make_Procedure_Call_Statement (Loc,
+                Name =>
+                  New_Reference_To (RTE (RE_Set_Storage_Pool_Ptr), Loc),
+                Parameter_Associations => New_List (
+                  New_Reference_To (Coll_Id, Loc),
+                  Make_Attribute_Reference (Loc,
+                    Prefix =>
+                      New_Reference_To (Pool_Id, Loc),
+                    Attribute_Name => Name_Unrestricted_Access))));
+         end if;
 
          Set_Associated_Collection (Typ, Coll_Id);
 
@@ -2586,6 +2597,8 @@ package body Exp_Ch7 is
             --  caller finalization chain and deallocates the object. This is
             --  disabled on .NET/JVM because pools are not supported.
 
+            --  H505-021 This needs to be revisited on .NET/JVM
+
             if VM_Target = No_VM
               and then Is_Return_Object (Obj_Id)
             then
@@ -4429,6 +4442,42 @@ package body Exp_Ch7 is
       end if;
    end Make_Adjust_Call;
 
+   ----------------------
+   -- Make_Attach_Call --
+   ----------------------
+
+   function Make_Attach_Call
+     (Obj_Ref : Node_Id;
+      Ptr_Typ : Entity_Id) return Node_Id
+   is
+      Loc : constant Source_Ptr := Sloc (Obj_Ref);
+
+   begin
+      return
+        Make_Procedure_Call_Statement (Loc,
+          Name =>
+            New_Reference_To (RTE (RE_Attach), Loc),
+          Parameter_Associations => New_List (
+            New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
+            Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
+   end Make_Attach_Call;
+
+   ----------------------
+   -- Make_Detach_Call --
+   ----------------------
+
+   function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
+      Loc : constant Source_Ptr := Sloc (Obj_Ref);
+
+   begin
+      return
+        Make_Procedure_Call_Statement (Loc,
+          Name =>
+            New_Reference_To (RTE (RE_Detach), Loc),
+          Parameter_Associations => New_List (
+            Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
+   end Make_Detach_Call;
+
    ---------------
    -- Make_Call --
    ---------------

gcc/ada/exp_ch7.ads

@@ -93,6 +93,24 @@ package Exp_Ch7 is
    --  adjusted. Typ is the expected type of Obj_Ref. Flag For_Parent must be
    --  set when an adjustment call is being created for field _parent.
 
+   function Make_Attach_Call
+     (Obj_Ref : Node_Id;
+      Ptr_Typ : Entity_Id) return Node_Id;
+   --  Create a call to prepend an object to a finalization collection. Obj_Ref
+   --  is the object, Ptr_Typ is the access type that owns the collection.
+   --  Generate the following:
+
+   --    Ada.Finalization.Heap_Managment.Attach
+   --      (<Ptr_Typ>FC,
+   --       System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref));
+
+   function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id;
+   --  Create a call to unhook an object from an arbitrary list. Obj_Ref is the
+   --  object. Generate the following:
+
+   --    Ada.Finalization.Heap_Management.Detach
+   --      (System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref));
+
    function Make_Final_Call
      (Obj_Ref    : Node_Id;
       Typ        : Entity_Id;

gcc/ada/exp_intr.adb

@@ -53,6 +53,7 @@ with Sinput;   use Sinput;
 with Snames;   use Snames;
 with Stand;    use Stand;
 with Stringt;  use Stringt;
+with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
 with Urealp;   use Urealp;
@@ -1009,6 +1010,16 @@ package body Exp_Intr is
                                          (RTE (RE_Get_Current_Excep),
                                           Loc))))))))))));
 
+         --  For .NET/JVM, detach the object from the containing finalization
+         --  collection before finalizing it.
+
+         if VM_Target /= No_VM
+           and then Is_Controlled (Desig_T)
+         then
+            Prepend_To (Final_Code,
+              Make_Detach_Call (New_Copy_Tree (Arg)));
+         end if;
+
          --  If aborts are allowed, then the finalization code must be
          --  protected by an abort defer/undefer pair.
 

gcc/ada/rtsfind.ads

@@ -517,8 +517,10 @@ package Rtsfind is
 
      RE_Add_Offset_To_Address,           -- Ada.Finalization.Heap_Management
      RE_Allocate,                        -- Ada.Finalization.Heap_Management
+     RE_Attach,                          -- Ada.Finalization.Heap_Management
      RE_Base_Pool,                       -- Ada.Finalization.Heap_Management
      RE_Deallocate,                      -- Ada.Finalization.Heap_Management
+     RE_Detach,                          -- Ada.Finalization.Heap_Management
      RE_Finalization_Collection,         -- Ada.Finalization.Heap_Management
      RE_Finalization_Collection_Ptr,     -- Ada.Finalization.Heap_Management
      RE_Set_Finalize_Address_Ptr,        -- Ada.Finalization.Heap_Management
@@ -796,8 +798,7 @@ package Rtsfind is
      RE_Fat_VAX_G,                       -- System.Fat_VAX_G_Float
 
      RE_Root_Controlled,                 -- System.Finalization_Root
-     RE_Finalizable,                     -- System.Finalization_Root
-     RE_Finalizable_Ptr,                 -- System.Finalization_Root
+     RE_Root_Controlled_Ptr,             -- System.Finalization_Root
 
      RE_Fore,                            -- System.Fore
 
@@ -1694,8 +1695,10 @@ package Rtsfind is
 
      RE_Add_Offset_To_Address            => Ada_Finalization_Heap_Management,
      RE_Allocate                         => Ada_Finalization_Heap_Management,
+     RE_Attach                           => Ada_Finalization_Heap_Management,
      RE_Base_Pool                        => Ada_Finalization_Heap_Management,
      RE_Deallocate                       => Ada_Finalization_Heap_Management,
+     RE_Detach                           => Ada_Finalization_Heap_Management,
      RE_Finalization_Collection          => Ada_Finalization_Heap_Management,
      RE_Finalization_Collection_Ptr      => Ada_Finalization_Heap_Management,
      RE_Set_Finalize_Address_Ptr         => Ada_Finalization_Heap_Management,
@@ -1973,8 +1976,7 @@ package Rtsfind is
      RE_Fat_VAX_G                        => System_Fat_VAX_G_Float,
 
      RE_Root_Controlled                  => System_Finalization_Root,
-     RE_Finalizable                      => System_Finalization_Root,
-     RE_Finalizable_Ptr                  => System_Finalization_Root,
+     RE_Root_Controlled_Ptr              => System_Finalization_Root,
 
      RE_Fore                             => System_Fore,
 

gcc/ada/snames.ads-tmpl

@@ -195,6 +195,8 @@ package Snames is
    Name_Adjust                         : constant Name_Id := N + $;
    Name_Finalize                       : constant Name_Id := N + $;
    Name_Finalize_Address               : constant Name_Id := N + $;
+   Name_Next                           : constant Name_Id := N + $;
+   Name_Prev                           : constant Name_Id := N + $;
 
    --  Names of allocation routines, also needed by expander
 
@@ -1202,7 +1204,6 @@ package Snames is
    Name_Cursor                           : constant Name_Id := N + $;
    Name_Element                          : constant Name_Id := N + $;
    Name_Element_Type                     : constant Name_Id := N + $;
-   Name_Next                             : constant Name_Id := N + $;
    Name_No_Element                       : constant Name_Id := N + $;
    Name_Previous                         : constant Name_Id := N + $;