2007-09-26 Javier Miranda <miranda@adacore.com>

	    Eric Botcazou  <ebotcazou@adacore.com>

	* a-tags.adb: 
	(Get_HT_Link/Set_HT_Link): Updated to handle the additional level of
	 indirection added to the HT_Link component of the TSD. This is required
	 to statically allocate the TSD.

	* a-tags.ads: 
	Minor reordering of the declarations in the private part. Required to
	add a level of indirection to the contents of the TSD component HT_Link.
	This is required to statically allocate the TSD.

	* decl.c (gnat_to_gnu_entity) <object>: Do not exclude objects with
	Is_Statically_Allocated set from constant objects.
	Do not make exported constants created by the compiler volatile.
	(gnat_to_gnu_param): Do not treat an IN parameter whose address is taken
	as read-only.

	* trans.c (Identifier_to_gnu): For constants, unshare initializers
	before returning them.

	* exp_disp.ads, exp_disp.adb (Building_Static_DT): Spec moved to the
	public part of the package.
	(Make_DT): Move HT_Link component out of the TSD record. For this
	purpose Make_DT now declares a separate object that stores the
	HT_Link value, and initializes the TSD component with the address
	of this new object. The addition of this level of indirection is
	required to statically allocate the TSD because the TSD cannot
	have variable components.
	(Expand_Interface_Conversion): Improve the expanded code.
	(Expand_Interface_Thunk): Set Is_Thunk in the thunk entity.

	* sem_disp.adb (Check_Dispatching_Operation): In case of a body
	declaring a primitive operation ---allowed by RM 3.9.2 (13.e/2)---,
	if we are building static dispatch tables then we must not generate
	extra code to register the primitive because the dispatch table will
	be built at the end of the library package; otherwise we notify that
	we cannot build the static dispatch table.



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

1 files changed, 50 insertions, 45 deletions

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 2d663baf6c2..54e08c6142c 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -66,10 +66,6 @@ package body Exp_Disp is
    -- Local Subprograms --
    -----------------------
 
-   function Building_Static_DT (Typ : Entity_Id) return Boolean;
-   pragma Inline (Building_Static_DT);
-   --  Returns true when building statically allocated dispatch tables
-
    function Default_Prim_Op_Position (E : Entity_Id) return Uint;
    --  Ada 2005 (AI-251): Returns the fixed position in the dispatch table
    --  of the default primitive operations.
@@ -104,7 +100,13 @@ package body Exp_Disp is
    function Building_Static_DT (Typ : Entity_Id) return Boolean is
    begin
       return Static_Dispatch_Tables
-               and then Is_Library_Level_Tagged_Type (Typ);
+        and then Is_Library_Level_Tagged_Type (Typ)
+
+         --  If the type is derived from a CPP class we cannot statically
+         --  build the dispatch tables because we must inherit primitives
+         --  from the CPP side.
+
+        and then not Is_CPP_Class (Root_Type (Typ));
    end Building_Static_DT;
 
    ----------------------------------
@@ -742,7 +744,7 @@ package body Exp_Disp is
          Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
       end if;
 
-      --  Handle access types to interfaces
+      --  Handle access to class-wide interface types
 
       if Is_Access_Type (Iface_Typ) then
          Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
@@ -881,11 +883,9 @@ package body Exp_Disp is
          --     end Func;
 
          declare
-            Decls        : List_Id;
             Desig_Typ    : Entity_Id;
             Fent         : Entity_Id;
             New_Typ_Decl : Node_Id;
-            New_Obj_Decl : Node_Id;
             Stats        : List_Id;
 
          begin
@@ -895,6 +895,10 @@ package body Exp_Disp is
                Desig_Typ := Directly_Designated_Type (Desig_Typ);
             end if;
 
+            if Is_Concurrent_Type (Desig_Typ) then
+               Desig_Typ := Base_Type (Corresponding_Record_Type (Desig_Typ));
+            end if;
+
             New_Typ_Decl :=
               Make_Full_Type_Declaration (Loc,
                 Defining_Identifier =>
@@ -907,22 +911,6 @@ package body Exp_Disp is
                     Subtype_Indication     =>
                       New_Reference_To (Desig_Typ, Loc)));
 
-            New_Obj_Decl :=
-              Make_Object_Declaration (Loc,
-                Defining_Identifier =>
-                  Make_Defining_Identifier (Loc,
-                    New_Internal_Name ('S')),
-                Constant_Present => True,
-                Object_Definition =>
-                  New_Reference_To (Defining_Identifier (New_Typ_Decl), Loc),
-                Expression =>
-                  Unchecked_Convert_To (Defining_Identifier (New_Typ_Decl),
-                    Make_Identifier (Loc, Name_uO)));
-
-            Decls := New_List (
-              New_Typ_Decl,
-              New_Obj_Decl);
-
             Stats := New_List (
               Make_Simple_Return_Statement (Loc,
                 Unchecked_Convert_To (Etype (N),
@@ -930,9 +918,9 @@ package body Exp_Disp is
                     Prefix =>
                       Make_Selected_Component (Loc,
                         Prefix =>
-                          New_Reference_To
-                            (Defining_Identifier (New_Obj_Decl),
-                             Loc),
+                          Unchecked_Convert_To
+                            (Defining_Identifier (New_Typ_Decl),
+                             Make_Identifier (Loc, Name_uO)),
                         Selector_Name =>
                           New_Occurrence_Of (Iface_Tag, Loc)),
                     Attribute_Name => Name_Address))));
@@ -975,7 +963,7 @@ package body Exp_Disp is
                     Result_Definition =>
                       New_Reference_To (Etype (N), Loc)),
 
-                Declarations => Decls,
+                Declarations => New_List (New_Typ_Decl),
 
                 Handled_Statement_Sequence =>
                   Make_Handled_Sequence_Of_Statements (Loc, Stats));
@@ -991,20 +979,17 @@ package body Exp_Disp is
 
             if Is_Access_Type (Etype (Expression (N))) then
 
-               --  Generate: Operand_Typ!(Expression.all)'Address
+               --  Generate: Func (Address!(Expression))
 
                Rewrite (N,
                  Make_Function_Call (Loc,
                    Name => New_Reference_To (Fent, Loc),
                    Parameter_Associations => New_List (
-                     Make_Attribute_Reference (Loc,
-                       Prefix  => Unchecked_Convert_To (Operand_Typ,
-                                    Make_Explicit_Dereference (Loc,
-                                      Relocate_Node (Expression (N)))),
-                       Attribute_Name => Name_Address))));
+                     Unchecked_Convert_To (RTE (RE_Address),
+                       Relocate_Node (Expression (N))))));
 
             else
-               --  Generate: Operand_Typ!(Expression)'Address
+               --  Generate: Func (Operand_Typ!(Expression)'Address)
 
                Rewrite (N,
                  Make_Function_Call (Loc,
@@ -1409,6 +1394,8 @@ package body Exp_Disp is
         Make_Defining_Identifier (Loc,
           Chars => New_Internal_Name ('T'));
 
+      Set_Is_Thunk (Thunk_Id);
+
       if Ekind (Target) = E_Procedure then
          Thunk_Code :=
            Make_Subprogram_Body (Loc,
@@ -3064,6 +3051,8 @@ package body Exp_Disp is
                             New_External_Name (Tname, 'T', Suffix_Index => -1);
       Name_Exname       : constant Name_Id :=
                             New_External_Name (Tname, 'E', Suffix_Index => -1);
+      Name_HT_Link      : constant Name_Id :=
+                            New_External_Name (Tname, 'H', Suffix_Index => -1);
       Name_Predef_Prims : constant Name_Id :=
                             New_External_Name (Tname, 'R', Suffix_Index => -1);
       Name_SSD          : constant Name_Id :=
@@ -3077,6 +3066,8 @@ package body Exp_Disp is
                        Make_Defining_Identifier (Loc, Name_DT);
       Exname       : constant Entity_Id :=
                        Make_Defining_Identifier (Loc, Name_Exname);
+      HT_Link      : constant Entity_Id :=
+                       Make_Defining_Identifier (Loc, Name_HT_Link);
       Predef_Prims : constant Entity_Id :=
                        Make_Defining_Identifier (Loc, Name_Predef_Prims);
       SSD          : constant Entity_Id :=
@@ -3213,6 +3204,7 @@ package body Exp_Disp is
       Set_Is_Statically_Allocated (DT);
       Set_Is_Statically_Allocated (SSD);
       Set_Is_Statically_Allocated (TSD);
+      Set_Is_Statically_Allocated (Predef_Prims);
 
       --  Generate code to define the boolean that controls registration, in
       --  order to avoid multiple registrations for tagged types defined in
@@ -3353,6 +3345,15 @@ package body Exp_Disp is
       Set_Is_Statically_Allocated (Exname);
       Set_Is_True_Constant (Exname);
 
+      --  Declare the object used by Ada.Tags.Register_Tag
+
+      if RTE_Available (RE_Register_Tag) then
+         Append_To (Result,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => HT_Link,
+             Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc)));
+      end if;
+
       --  Generate code to create the storage for the type specific data object
       --  with enough space to store the tags of the ancestors plus the tags
       --  of all the implemented interfaces (as described in a-tags.adb).
@@ -3362,7 +3363,7 @@ package body Exp_Disp is
       --            Access_Level       => Type_Access_Level (Typ),
       --            Expanded_Name      => Cstring_Ptr!(Exname'Address))
       --            External_Tag       => Cstring_Ptr!(Exname'Address))
-      --            HT_Link            => null,
+      --            HT_Link            => HT_Link'Address,
       --            Transportable      => <<boolean-value>>,
       --            RC_Offset          => <<integer-value>>,
       --            [ Interfaces_Table  => <<access-value>> ]
@@ -3590,9 +3591,17 @@ package body Exp_Disp is
 
       --  HT_Link
 
-      Append_To (TSD_Aggr_List,
-        Unchecked_Convert_To (RTE (RE_Tag),
-          New_Reference_To (RTE (RE_Null_Address), Loc)));
+      if RTE_Available (RE_Register_Tag) then
+         Append_To (TSD_Aggr_List,
+           Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+             Make_Attribute_Reference (Loc,
+               Prefix => New_Reference_To (HT_Link, Loc),
+               Attribute_Name => Name_Address)));
+      else
+         Append_To (TSD_Aggr_List,
+           Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+             New_Reference_To (RTE (RE_Null_Address), Loc)));
+      end if;
 
       --  Transportable: Set for types that can be used in remote calls
       --  with respect to E.4(18) legality rules.
@@ -4734,9 +4743,7 @@ package body Exp_Disp is
       --  Import the forward declaration of the Dispatch Table wrapper record
       --  (Make_DT will take care of its exportation)
 
-      if Building_Static_DT (Typ)
-        and then not Is_CPP_Class (Typ)
-      then
+      if Building_Static_DT (Typ) then
          DT := Make_Defining_Identifier (Loc,
                  New_External_Name (Tname, 'T'));
 
@@ -4746,9 +4753,6 @@ package body Exp_Disp is
 
          Set_Is_Imported (DT);
 
-         --  Set_Is_True_Constant (DT);
-         --  Why is the above commented out???
-
          --  The scope must be set now to call Get_External_Name
 
          Set_Scope (DT, Current_Scope);
@@ -4840,6 +4844,7 @@ package body Exp_Disp is
          end if;
 
          Set_Is_True_Constant (DT_Ptr);
+         Set_Is_Statically_Allocated (DT_Ptr);
       end if;
 
       pragma Assert (No (Access_Disp_Table (Typ)));