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

1 files changed, 84 insertions, 35 deletions

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 4fd7d2a..ad48e5a 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/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 --
    ---------------