===================================================================
@@ -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
===================================================================
@@ -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,
===================================================================
@@ -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
===================================================================
@@ -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.
===================================================================
@@ -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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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;
===================================================================
@@ -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));
===================================================================
@@ -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