exp_disp.ads (Build_VM_TSDs): Build the runtime Type Specific Data record of all…

exp_disp.ads (Build_VM_TSDs): Build the runtime Type Specific Data record of all the tagged types declared...

2011-08-02  Javier Miranda  <miranda@adacore.com>

	* exp_disp.ads (Build_VM_TSDs): Build the runtime Type Specific Data
	record of all the tagged types declared inside library level package
	declarations, library level package bodies or library level subprograms.
	* exp_disp.adb (Make_VM_TSD): New subprogram that builds the TSD
	associated with a given tagged type.
	(Build_VM_TSDs): New subprogram.
	* exp_ch6.adb (Expand_N_Subprogram_Body): Generate TSDs records of main
	compilation units that are subprograms.
	* exp_ch7.adb (Expand_N_Package_Body): Generate TSDs of main
	compilation units that are package bodies.
	(Expand_N_Package_Declaration): Generate TSDs of the main compilation
	units that are a package declaration or a package instantiation.
	* exp_intr.adb (Expand_Dispatching_Constructor_Call): Minor code
	reorganization to improve the error generated by the frontend when the
	function Ada.Tags.Secondary_Tag is not available.
	* rtsfind.ads (RE_Register_TSD): New runtime entity.
	* exp_ch4.adb (Expand_N_Type_Conversion): Minor code cleanup.

From-SVN: r177163

gcc/ada/ChangeLog

 2011-08-02  Javier Miranda  <miranda@adacore.com>
 
+	* exp_disp.ads (Build_VM_TSDs): Build the runtime Type Specific Data
+	record of all the tagged types declared inside library level package
+	declarations, library level package bodies or library level subprograms.
+	* exp_disp.adb (Make_VM_TSD): New subprogram that builds the TSD
+	associated with a given tagged type.
+	(Build_VM_TSDs): New subprogram.
+	* exp_ch6.adb (Expand_N_Subprogram_Body): Generate TSDs records of main
+	compilation units that are subprograms.
+	* exp_ch7.adb (Expand_N_Package_Body): Generate TSDs of main
+	compilation units that are package bodies.
+	(Expand_N_Package_Declaration): Generate TSDs of the main compilation
+	units that are a package declaration or a package instantiation.
+	* exp_intr.adb (Expand_Dispatching_Constructor_Call): Minor code
+	reorganization to improve the error generated by the frontend when the
+	function Ada.Tags.Secondary_Tag is not available.
+	* rtsfind.ads (RE_Register_TSD): New runtime entity.
+	* exp_ch4.adb (Expand_N_Type_Conversion): Minor code cleanup.
+
+2011-08-02  Javier Miranda  <miranda@adacore.com>
+
 	* exp_disp.adb (Make_DT): Generate call to Check_TSD in Ada 2005 mode.
 
 2011-08-02  Robert Dewar  <dewar@adacore.com>

gcc/ada/exp_ch4.adb

@@ -8606,16 +8606,19 @@ package body Exp_Ch4 is
          --  Start of processing for Tagged_Conversion
 
          begin
-            if Is_Access_Type (Target_Type) then
-
-               --  Handle entities from the limited view
+            --  Handle entities from the limited view
 
+            if Is_Access_Type (Operand_Type) then
                Actual_Op_Typ :=
                  Available_View (Designated_Type (Operand_Type));
+            else
+               Actual_Op_Typ := Operand_Type;
+            end if;
+
+            if Is_Access_Type (Target_Type) then
                Actual_Targ_Typ :=
                  Available_View (Designated_Type (Target_Type));
             else
-               Actual_Op_Typ   := Operand_Type;
                Actual_Targ_Typ := Target_Type;
             end if;
 

gcc/ada/exp_ch6.adb

@@ -5121,6 +5121,16 @@ package body Exp_Ch6 is
    --  Start of processing for Expand_N_Subprogram_Body
 
    begin
+      --  If this is the main compilation unit and we are generating code for
+      --  VM targets we generate now the Type Specific Data record of all the
+      --  enclosing tagged type declarations
+
+      if not Tagged_Type_Expansion
+        and then Unit (Cunit (Main_Unit)) = N
+      then
+         Build_VM_TSDs (N);
+      end if;
+
       --  Set L to either the list of declarations if present, or to the list
       --  of statements if no declarations are present. This is used to insert
       --  new stuff at the start.

gcc/ada/exp_ch7.adb

@@ -1553,7 +1553,15 @@ package body Exp_Ch7 is
          --  Build dispatch tables of library level tagged types
 
          if Is_Library_Level_Entity (Ent) then
-            Build_Static_Dispatch_Tables (N);
+            if Tagged_Type_Expansion then
+               Build_Static_Dispatch_Tables (N);
+
+            --  In VM targets there is no need to build dispatch tables but
+            --  we must generate the corresponding Type Specific Data record
+
+            elsif Unit (Cunit (Main_Unit)) = N then
+               Build_VM_TSDs (N);
+            end if;
          end if;
 
          Build_Task_Activation_Call (N);
@@ -1654,7 +1662,31 @@ package body Exp_Ch7 is
         or else (Is_Generic_Instance (Id)
                    and then Is_Library_Level_Entity (Id))
       then
-         Build_Static_Dispatch_Tables (N);
+         if Tagged_Type_Expansion then
+            Build_Static_Dispatch_Tables (N);
+
+         --  In VM targets there is no need to build dispatch tables but
+         --  we must generate the corresponding Type Specific Data record
+
+         elsif Unit (Cunit (Main_Unit)) = N then
+
+            --  Enter the scope of the package because the new declarations
+            --  are appended at the end of the package and must be analyzed
+            --  in that context.
+
+            Push_Scope (Id);
+
+            if Is_Generic_Instance (Main_Unit_Entity) then
+               if Package_Instantiation (Main_Unit_Entity) = N then
+                  Build_VM_TSDs (N);
+               end if;
+
+            else
+               Build_VM_TSDs (N);
+            end if;
+
+            Pop_Scope;
+         end if;
       end if;
 
       --  Note: it is not necessary to worry about generating a subprogram

gcc/ada/exp_disp.ads

@@ -186,6 +186,11 @@ package Exp_Disp is
    --  bodies they are added to the end of the list of declarations of the
    --  package body.
 
+   procedure Build_VM_TSDs (N : Entity_Id);
+   --  N is a library level package declaration, a library level package body
+   --  or a library level subprogram body. Build the runtime Type Specific
+   --  Data record of all the tagged types declared inside N.
+
    function Convert_Tag_To_Interface
      (Typ : Entity_Id; Expr : Node_Id) return Node_Id;
    pragma Inline (Convert_Tag_To_Interface);

gcc/ada/exp_intr.adb

@@ -234,23 +234,33 @@ package body Exp_Intr is
          if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),
                              Use_Full_View => True)
          then
-            pragma Assert (not Is_Interface (Etype (Tag_Arg)));
-
-            Iface_Tag :=
-              Make_Object_Declaration (Loc,
-                Defining_Identifier => Make_Temporary (Loc, 'V'),
-                Object_Definition   =>
-                  New_Reference_To (RTE (RE_Tag), Loc),
-                Expression          =>
-                  Make_Function_Call (Loc,
-                    Name => New_Reference_To (RTE (RE_Secondary_Tag), Loc),
-                    Parameter_Associations => New_List (
-                      Relocate_Node (Tag_Arg),
-                      New_Reference_To
-                        (Node (First_Elmt (Access_Disp_Table
-                                            (Etype (Etype (Act_Constr))))),
-                         Loc))));
-            Insert_Action (N, Iface_Tag);
+            --  Obtain the reference to the Ada.Tags service before generating
+            --  the Object_Declaration node to ensure that if this service is
+            --  not available in the runtime then we generate a clear error.
+
+            declare
+               Fname : constant Node_Id :=
+                         New_Reference_To (RTE (RE_Secondary_Tag), Loc);
+
+            begin
+               pragma Assert (not Is_Interface (Etype (Tag_Arg)));
+
+               Iface_Tag :=
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Make_Temporary (Loc, 'V'),
+                   Object_Definition   =>
+                     New_Reference_To (RTE (RE_Tag), Loc),
+                   Expression          =>
+                     Make_Function_Call (Loc,
+                       Name => Fname,
+                       Parameter_Associations => New_List (
+                         Relocate_Node (Tag_Arg),
+                         New_Reference_To
+                           (Node (First_Elmt (Access_Disp_Table
+                                               (Etype (Etype (Act_Constr))))),
+                            Loc))));
+               Insert_Action (N, Iface_Tag);
+            end;
          end if;
       end if;
 

gcc/ada/rtsfind.ads

@@ -607,6 +607,7 @@ package Rtsfind is
      RE_Type_Specific_Data,              -- Ada.Tags
      RE_Register_Interface_Offset,       -- Ada.Tags
      RE_Register_Tag,                    -- Ada.Tags
+     RE_Register_TSD,                    -- Ada.Tags
      RE_Transportable,                   -- Ada.Tags
      RE_Secondary_DT,                    -- Ada.Tags
      RE_Secondary_Tag,                   -- Ada.Tags
@@ -1786,6 +1787,7 @@ package Rtsfind is
      RE_Type_Specific_Data               => Ada_Tags,
      RE_Register_Interface_Offset        => Ada_Tags,
      RE_Register_Tag                     => Ada_Tags,
+     RE_Register_TSD                     => Ada_Tags,
      RE_Transportable                    => Ada_Tags,
      RE_Secondary_DT                     => Ada_Tags,
      RE_Secondary_Tag                    => Ada_Tags,