This patch improves the support for interface conversions in the .NET/JVM
compiler extending the current support for attribute 'tag and adding the
missing runtime checks required in interface conversions when the tag of
the source is unknown at compile time. After this patch the following test
compiles and executes well.
with GNAT.IO; use GNAT.IO;
procedure Main is
package Pkg is
type Iface is interface;
procedure Print (Obj : in out Iface) is abstract;
type Parent is tagged record
Id : Natural := 1;
end record;
type Child is new Parent and Iface with null record;
procedure Print (Obj : in out Child);
function New_Child return Iface'Class;
end Pkg;
package body Pkg is
procedure Print (Obj : in out Child) is
begin
Put_Line ("child" & Obj.Id'Img);
end Print;
function New_Child return Iface'Class is
begin
return Obj : Child do
Obj.Id := 3;
end return;
end New_Child;
end Pkg;
use Pkg;
C : Iface'Class := New_Child;
begin
Print (C);
end Main;
Command: dotnet-gnatmake -gnat05 main; ./main.exe
Output: child 3
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-04 Javier Miranda <mira...@adacore.com>
* exp_ch7.adb (Expand_N_Package_Body, Expand_N_Package_Declaration):
Remove code which takes care of building TSDs.
* rtsfind.ads (RE_Check_Interface_Conversion): New entity.
* exp_ch4.adb (Apply_Accessibility_Check): Add support for generating
the accessibility check in VM targets.
* exp_disp.adb (Make_VM_TSD): Spec moved to exp_disp.ads
(Building_Static_DT): Now returns false for VM targets.
(Build_VM_TSDs): Removed.
(Expand_Interface_Conversion): Generate missing runtime check for
conversions to interface types whose target type is unknown at compile
time.
(Make_VM_TSD): Add missing code to disable the generation of calls to
Check_TSD if the tagged type is not defined at library level, or not
has a representation clause specifying its external tag, or -gnatdQ is
active.
* exp_disp.ads (Build_VM_TSDs): Removed.
(Make_VM_TSDs): Spec relocated from exp_disp.adb
* sem_disp.adb (Check_Dispatching_Operation): No code required to
register primitives in the dispatch tables in VM targets.
* exp_ch3.adb (Expand_N_Object_Declaration): Remove wrong expansion of
initialization of class-wide interface objects in VM targets.
(Expand_Freeze_Record_Type): For VM targets call Make_VM_TSD (instead
of Make_DT).
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 177386)
+++ exp_ch7.adb (working copy)
@@ -1261,7 +1261,7 @@
-- objects that need finalization. When flag Preprocess is set, the
-- routine will simply count the total number of controlled objects in
-- Decls. Flag Top_Level denotes whether the processing is done for
- -- objects in nested package decparations or instances.
+ -- objects in nested package declarations or instances.
procedure Process_Object_Declaration
(Decl : Node_Id;
@@ -3810,24 +3810,10 @@
-- Build dispatch tables of library level tagged types
- if Is_Library_Level_Entity (Spec_Ent) then
- 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
-
- -- If the runtime package Ada_Tags has not been loaded then
- -- this package does not have tagged type declarations and
- -- there is no need to search for tagged types to generate
- -- their TSDs.
-
- if RTU_Loaded (Ada_Tags) then
- Build_VM_TSDs (N);
- end if;
- end if;
+ if Tagged_Type_Expansion
+ and then Is_Library_Level_Entity (Spec_Ent)
+ then
+ Build_Static_Dispatch_Tables (N);
end if;
Build_Task_Activation_Call (N);
@@ -3948,42 +3934,12 @@
-- Build dispatch tables of library level tagged types
- if Is_Compilation_Unit (Id)
- or else (Is_Generic_Instance (Id)
- and then Is_Library_Level_Entity (Id))
+ if Tagged_Type_Expansion
+ and then (Is_Compilation_Unit (Id)
+ or else (Is_Generic_Instance (Id)
+ and then Is_Library_Level_Entity (Id)))
then
- 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
-
- -- If the runtime package Ada_Tags has not been loaded then
- -- this package does not have tagged types and there is no need
- -- to search for tagged types to generate their TSDs.
-
- if RTU_Loaded (Ada_Tags) 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;
+ Build_Static_Dispatch_Tables (N);
end if;
-- Note: it is not necessary to worry about generating a subprogram
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 177378)
+++ rtsfind.ads (working copy)
@@ -561,6 +561,7 @@
RE_Address_Array, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags
RE_Base_Address, -- Ada.Tags
+ RE_Check_Interface_Conversion, -- Ada.Tags
RE_Check_TSD, -- Ada.Tags
RE_Cstring_Ptr, -- Ada.Tags
RE_Descendant_Tag, -- Ada.Tags
@@ -1743,6 +1744,7 @@
RE_Address_Array => Ada_Tags,
RE_Addr_Ptr => Ada_Tags,
RE_Base_Address => Ada_Tags,
+ RE_Check_Interface_Conversion => Ada_Tags,
RE_Check_TSD => Ada_Tags,
RE_Cstring_Ptr => Ada_Tags,
RE_Descendant_Tag => Ada_Tags,
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 177365)
+++ exp_ch4.adb (working copy)
@@ -629,14 +629,10 @@
(Ref : Node_Id;
Built_In_Place : Boolean := False)
is
- Ref_Node : Node_Id;
+ New_Node : Node_Id;
begin
- -- Note: we skip the accessibility check for the VM case, since
- -- there does not seem to be any practical way of implementing it.
-
if Ada_Version >= Ada_2005
- and then Tagged_Type_Expansion
and then Is_Class_Wide_Type (DesigT)
and then not Scope_Suppress (Accessibility_Check)
and then
@@ -652,20 +648,37 @@
-- address of the allocated object.
if Built_In_Place then
- Ref_Node := New_Copy (Ref);
+ New_Node := New_Copy (Ref);
else
- Ref_Node := New_Reference_To (Ref, Loc);
+ New_Node := New_Reference_To (Ref, Loc);
end if;
+ New_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Node,
+ Attribute_Name => Name_Tag);
+
+ if Tagged_Type_Expansion then
+ New_Node :=
+ Build_Get_Access_Level (Loc, New_Node);
+
+ elsif VM_Target /= No_VM then
+ New_Node :=
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (RE_Get_Access_Level), Loc),
+ Parameter_Associations => New_List (New_Node));
+
+ -- Cannot generate the runtime check
+
+ else
+ return;
+ end if;
+
Insert_Action (N,
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
- Left_Opnd =>
- Build_Get_Access_Level (Loc,
- Make_Attribute_Reference (Loc,
- Prefix => Ref_Node,
- Attribute_Name => Name_Tag)),
+ Left_Opnd => New_Node,
Right_Opnd =>
Make_Integer_Literal (Loc, Type_Access_Level (PtrT))),
Reason => PE_Accessibility_Check_Failed));
@@ -2594,6 +2607,8 @@
Clen : Node_Id;
Set : Boolean;
+ -- Start of processing for Expand_Concatenate
+
begin
-- Choose an appropriate computational type
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 177351)
+++ exp_ch6.adb (working copy)
@@ -5382,21 +5382,6 @@
-- 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 now generate the Type Specific Data record of all the
- -- enclosing tagged type declarations.
-
- -- If the runtime package Ada_Tags has not been loaded then this
- -- subprogram does not have tagged type declarations and there is no
- -- need to search for tagged types to generate their TSDs.
-
- if not Tagged_Type_Expansion
- and then Unit (Cunit (Main_Unit)) = N
- and then RTU_Loaded (Ada_Tags)
- 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.
Index: exp_disp.adb
===================================================================
--- exp_disp.adb (revision 177378)
+++ exp_disp.adb (working copy)
@@ -61,6 +61,7 @@
with Stand; use Stand;
with Stringt; use Stringt;
with SCIL_LL; use SCIL_LL;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
@@ -82,10 +83,6 @@
-- Returns true if Prim is not a predefined dispatching primitive but it is
-- an alias of a predefined dispatching primitive (i.e. through a renaming)
- function Make_VM_TSD (Typ : Entity_Id) return List_Id;
- -- Build the Type Specific Data record associated with tagged type Typ.
- -- Invoked only when generating code for VM targets.
-
function New_Value (From : Node_Id) return Node_Id;
-- From is the original Expression. New_Value is equivalent to a call
-- to Duplicate_Subexpr with an explicit dereference when From is an
@@ -298,6 +295,7 @@
return Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Typ)
+ and then VM_Target = No_VM
-- If the type is derived from a CPP class we cannot statically
-- build the dispatch tables because we must inherit primitives
@@ -468,156 +466,6 @@
end if;
end Build_Static_Dispatch_Tables;
- -------------------
- -- Build_VM_TSDs --
- -------------------
-
- procedure Build_VM_TSDs (N : Entity_Id) is
- Target_List : List_Id := No_List;
-
- procedure Build_TSDs (List : List_Id);
- -- Build the static dispatch table of tagged types found in the list of
- -- declarations. Add the generated nodes to the end of Target_List.
-
- procedure Build_Package_TSDs (N : Node_Id);
- -- Build static dispatch tables associated with package declaration N
-
- ---------------------------
- -- Build_Dispatch_Tables --
- ---------------------------
-
- procedure Build_TSDs (List : List_Id) is
- D : Node_Id;
-
- begin
- D := First (List);
- while Present (D) loop
-
- -- Handle nested packages and package bodies recursively. The
- -- generated code is placed on the Target_List established for
- -- the enclosing compilation unit.
-
- if Nkind (D) = N_Package_Declaration then
- Build_Package_TSDs (D);
-
- elsif Nkind_In (D, N_Package_Body,
- N_Subprogram_Body)
- then
- Build_TSDs (Declarations (D));
-
- elsif Nkind (D) = N_Package_Body_Stub
- and then Present (Library_Unit (D))
- then
- Build_TSDs
- (Declarations (Proper_Body (Unit (Library_Unit (D)))));
-
- -- Handle full type declarations and derivations of library
- -- level tagged types
-
- elsif Nkind_In (D, N_Full_Type_Declaration,
- N_Derived_Type_Definition)
- and then Ekind (Defining_Entity (D)) /= E_Record_Subtype
- and then Is_Tagged_Type (Defining_Entity (D))
- and then not Is_Private_Type (Defining_Entity (D))
- then
- -- Do not generate TSDs for the internal types created for
- -- a type extension with unknown discriminants. The needed
- -- information is shared with the source type.
- -- See Expand_N_Record_Extension.
-
- if Is_Underlying_Record_View (Defining_Entity (D))
- or else
- (not Comes_From_Source (Defining_Entity (D))
- and then
- Has_Unknown_Discriminants (Etype (Defining_Entity (D)))
- and then
- not Comes_From_Source
- (First_Subtype (Defining_Entity (D))))
- then
- null;
-
- else
- if No (Target_List) then
- Target_List := New_List;
- end if;
-
- Append_List_To (Target_List,
- Make_VM_TSD (Defining_Entity (D)));
- end if;
- end if;
-
- Next (D);
- end loop;
- end Build_TSDs;
-
- ------------------------
- -- Build_Package_TSDs --
- ------------------------
-
- procedure Build_Package_TSDs (N : Node_Id) is
- Spec : constant Node_Id := Specification (N);
- Vis_Decls : constant List_Id := Visible_Declarations (Spec);
- Priv_Decls : constant List_Id := Private_Declarations (Spec);
-
- begin
- if Present (Priv_Decls) then
- Build_TSDs (Vis_Decls);
- Build_TSDs (Priv_Decls);
-
- elsif Present (Vis_Decls) then
- Build_TSDs (Vis_Decls);
- end if;
- end Build_Package_TSDs;
-
- -- Start of processing for Build_VM_TSDs
-
- begin
- if not Expander_Active
- or else No_Run_Time_Mode
- or else Tagged_Type_Expansion
- or else not RTE_Available (RE_Type_Specific_Data)
- then
- return;
- end if;
-
- if Nkind (N) = N_Package_Declaration then
- declare
- Spec : constant Node_Id := Specification (N);
- Vis_Decls : constant List_Id := Visible_Declarations (Spec);
- Priv_Decls : constant List_Id := Private_Declarations (Spec);
-
- begin
- Build_Package_TSDs (N);
-
- if Present (Target_List) then
- Analyze_List (Target_List);
-
- if Present (Priv_Decls)
- and then Is_Non_Empty_List (Priv_Decls)
- then
- Append_List (Target_List, Priv_Decls);
- else
- Append_List (Target_List, Vis_Decls);
- end if;
- end if;
- end;
-
- elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then
- if Is_Non_Empty_List (Declarations (N)) then
- Build_TSDs (Declarations (N));
-
- if Nkind (N) = N_Subprogram_Body then
- Build_TSDs (Statements (Handled_Statement_Sequence (N)));
- end if;
-
- if Present (Target_List) then
- Analyze_List (Target_List);
- Append_List (Target_List, Declarations (N));
- end if;
- end if;
- end if;
- end Build_VM_TSDs;
-
------------------------------
-- Convert_Tag_To_Interface --
------------------------------
@@ -1278,11 +1126,37 @@
and then Is_Interface (Iface_Typ)));
if not Tagged_Type_Expansion then
+ if VM_Target /= No_VM then
+ if Is_Access_Type (Operand_Typ) then
+ Operand_Typ := Designated_Type (Operand_Typ);
+ end if;
- -- For VM, just do a conversion ???
+ if Is_Class_Wide_Type (Operand_Typ) then
+ Operand_Typ := Root_Type (Operand_Typ);
+ end if;
- Rewrite (N, Unchecked_Convert_To (Etype (N), N));
- Analyze (N);
+ if not Is_Static
+ and then Operand_Typ /= Iface_Typ
+ then
+ Insert_Action (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_Check_Interface_Conversion), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Expression (N)),
+ Attribute_Name => Name_Tag),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Iface_Typ, Loc),
+ Attribute_Name => Name_Tag))));
+ end if;
+
+ -- Just do a conversion ???
+
+ Rewrite (N, Unchecked_Convert_To (Etype (N), N));
+ Analyze (N);
+ end if;
+
return;
end if;
@@ -6764,13 +6638,20 @@
-- Check_TSD
-- (TSD => TSD'Unrestricted_Access);
- Append_To (Result,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (TSD, Loc),
- Attribute_Name => Name_Unrestricted_Access))));
+ if Ada_Version >= Ada_2005
+ and then Is_Library_Level_Entity (Typ)
+ and then Has_External_Tag_Rep_Clause (Typ)
+ and then RTE_Available (RE_Check_TSD)
+ and then not Debug_Flag_QQ
+ then
+ Append_To (Result,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (TSD, Loc),
+ Attribute_Name => Name_Unrestricted_Access))));
+ end if;
-- Generate:
-- Register_TSD (TSD'Unrestricted_Access);
@@ -7653,6 +7534,7 @@
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+ pragma Assert (VM_Target = No_VM);
-- Do not register in the dispatch table eliminated primitives
Index: exp_disp.ads
===================================================================
--- exp_disp.ads (revision 177274)
+++ exp_disp.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -186,11 +186,6 @@
-- 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);
@@ -353,6 +348,10 @@
-- tagged types this routine imports the forward declaration of the tag
-- entity, that will be declared and exported by Make_DT.
+ function Make_VM_TSD (Typ : Entity_Id) return List_Id;
+ -- Build the Type Specific Data record associated with tagged type Typ.
+ -- Invoked only when generating code for VM targets.
+
function Register_Primitive
(Loc : Source_Ptr;
Prim : Entity_Id) return List_Id;
Index: sem_disp.adb
===================================================================
--- sem_disp.adb (revision 177320)
+++ sem_disp.adb (working copy)
@@ -49,6 +49,7 @@
with Sem_Util; use Sem_Util;
with Snames; use Snames;
with Sinfo; use Sinfo;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
@@ -1028,6 +1029,12 @@
" the type!", Subp);
end if;
+ -- No code required to register primitives in VM
+ -- targets
+
+ elsif VM_Target /= No_VM then
+ null;
+
else
Insert_Actions_After (Subp_Body,
Register_Primitive (Sloc (Subp_Body),
@@ -1158,10 +1165,13 @@
while Present (Elmt) loop
Prim := Node (Elmt);
+ -- No code required to register primitives in VM targets
+
if Present (Alias (Prim))
and then Present (Interface_Alias (Prim))
and then Alias (Prim) = Subp
and then not Building_Static_DT (Tagged_Type)
+ and then VM_Target = No_VM
then
Insert_Actions_After (Subp_Body,
Register_Primitive (Sloc (Subp_Body), Prim => Prim));
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 177328)
+++ exp_ch3.adb (working copy)
@@ -5022,27 +5022,6 @@
Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
Exchange_Entities (Defining_Identifier (N), Def_Id);
end;
-
- -- Handle initialization of class-wide interface object in VM
- -- targets
-
- elsif not Tagged_Type_Expansion then
-
- -- Replace
- -- CW : I'Class := Obj;
- -- by
- -- CW : I'Class;
- -- CW := I'Class (Obj); [1]
-
- -- The assignment [1] is later expanded in a dispatching
- -- call to _assign
-
- Set_Expression (N, Empty);
-
- Insert_Action (N,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Def_Id, Loc),
- Expression => Convert_To (Typ, Relocate_Node (Expr))));
end if;
return;
@@ -6170,6 +6149,9 @@
if not Building_Static_DT (Def_Id) then
Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
end if;
+
+ elsif VM_Target /= No_VM then
+ Append_Freeze_Actions (Def_Id, Make_VM_TSD (Def_Id));
end if;
-- If the type has unknown discriminants, propagate dispatching
