Skip to content

R
riscv-gcc-1
Commit f46faa08 by Arnaud Charlet
Options

[multiple changes] 

2011-08-04  Javier Miranda  <miranda@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).

2011-08-04  Jerome Lambourg  <lambourg@adacore.com>

	* gnatlink.adb (Gnatlink): Correct missleading error message displayed
	when dotnet-ld cannot be found.

2011-08-04  Arnaud Charlet  <charlet@adacore.com>

	* bindgen.adb: Simplify significantly generation of binder body file in
	CodePeer mode.
	* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Prevent assert failure
	when compiling binder generated file in CodePeer mode (xxx'Elab_Spec
	not expanded).

From-SVN: r177387
parent 2ba7e31e
Showing with 279 additions and 354 deletions
gcc/ada/ChangeLog
2011-08-04 Javier Miranda <miranda@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).
2011-08-04 Jerome Lambourg <lambourg@adacore.com>
* gnatlink.adb (Gnatlink): Correct missleading error message displayed
when dotnet-ld cannot be found.
2011-08-04 Arnaud Charlet <charlet@adacore.com>
* bindgen.adb: Simplify significantly generation of binder body file in
CodePeer mode.
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Prevent assert failure
when compiling binder generated file in CodePeer mode (xxx'Elab_Spec
not expanded).
2011-08-04 Yannick Moy <moy@adacore.com>
* sem_prag.adb, sem.ads: Code cleanup.
......
gcc/ada/bindgen.adb
......@@ -435,7 +435,10 @@ package body Bindgen is
begin
WBI (" procedure " & Ada_Final_Name.all & " is");
if VM_Target = No_VM and then Bind_Main_Program then
if VM_Target = No_VM
and Bind_Main_Program
and not CodePeer_Mode
then
WBI (" procedure s_stalib_adafinal;");
Set_String (" pragma Import (C, s_stalib_adafinal, ");
Set_String ("""system__standard_library__adafinal"");");
......@@ -443,15 +446,18 @@ package body Bindgen is
end if;
WBI (" begin");
WBI (" if not Is_Elaborated then");
WBI (" return;");
WBI (" end if;");
WBI (" Is_Elaborated := False;");
if not CodePeer_Mode then
WBI (" if not Is_Elaborated then");
WBI (" return;");
WBI (" end if;");
WBI (" Is_Elaborated := False;");
end if;
-- On non-virtual machine targets, finalization is done differently
-- depending on whether this is the main program or a library.
if VM_Target = No_VM then
if VM_Target = No_VM and then not CodePeer_Mode then
if Bind_Main_Program then
WBI (" s_stalib_adafinal;");
elsif Lib_Final_Built then
......@@ -462,6 +468,7 @@ package body Bindgen is
-- Pragma Import C cannot be used on virtual machine targets, therefore
-- call the runtime finalization routine directly.
-- Similarly in CodePeer mode, where imported functions are ignored.
else
WBI (" System.Standard_Library.Adafinal;");
......@@ -516,6 +523,7 @@ package body Bindgen is
if not Suppress_Standard_Library_On_Target
and then VM_Target = No_VM
and then not CodePeer_Mode
and then not Configurable_Run_Time_On_Target
then
WBI (" type No_Param_Proc is access procedure;");
......@@ -524,11 +532,17 @@ package body Bindgen is
WBI (" procedure " & Ada_Init_Name.all & " is");
-- In CodePeer mode, simplify adainit procedure by only calling
-- elaboration procedures.
if CodePeer_Mode then
WBI (" begin");
-- If the standard library is suppressed, then the only global variables
-- that might be needed (by the Ravenscar profile) are the priority and
-- the processor for the environment task.
if Suppress_Standard_Library_On_Target then
elsif Suppress_Standard_Library_On_Target then
if Main_Priority /= No_Main_Priority then
WBI (" Main_Priority : Integer;");
WBI (" pragma Import (C, Main_Priority," &
......@@ -717,7 +731,6 @@ package body Bindgen is
end if;
WBI (" begin");
WBI (" if Is_Elaborated then");
WBI (" return;");
WBI (" end if;");
......@@ -904,12 +917,17 @@ package body Bindgen is
WBI (" Initialize_Stack_Limit;");
end if;
-- On CodePeer, the finalization of library objects is not relevant
if CodePeer_Mode then
null;
-- On virtual machine targets, or on non-virtual machine ones if this
-- is the main program case, attach finalize_library to the soft link.
-- Do it only when not using a restricted run time, in which case tasks
-- are non-terminating, so we do not want library-level finalization.
if (VM_Target /= No_VM or else Bind_Main_Program)
elsif (VM_Target /= No_VM or else Bind_Main_Program)
and then not Configurable_Run_Time_On_Target
and then not Suppress_Standard_Library_On_Target
then
......@@ -942,7 +960,10 @@ package body Bindgen is
-- Generate elaboration calls
WBI ("");
if not CodePeer_Mode then
WBI ("");
end if;
Gen_Elab_Calls_Ada;
-- Case of main program is CIL function or procedure
......@@ -1257,6 +1278,10 @@ package body Bindgen is
procedure Gen_Elab_Externals_Ada is
begin
if CodePeer_Mode then
return;
end if;
for E in Elab_Order.First .. Elab_Order.Last loop
declare
Unum : constant Unit_Id := Elab_Order.Table (E);
......@@ -1380,6 +1405,7 @@ package body Bindgen is
------------------------
procedure Gen_Elab_Calls_Ada is
Check_Elab_Flag : Boolean;
begin
for E in Elab_Order.First .. Elab_Order.Last loop
declare
......@@ -1420,6 +1446,7 @@ package body Bindgen is
if U.Utype = Is_Body
and then Units.Table (Unum_Spec).Set_Elab_Entity
and then not CodePeer_Mode
then
Set_String (" E");
Set_Unit_Number (Unum_Spec);
......@@ -1449,10 +1476,13 @@ package body Bindgen is
-- elaboration subprogram is needed by CodePeer.
elsif U.Unit_Kind /= 's' or else not CodePeer_Mode then
if Force_Checking_Of_Elaboration_Flags
or Interface_Library_Unit
or not Bind_Main_Program
then
Check_Elab_Flag :=
not CodePeer_Mode
and then (Force_Checking_Of_Elaboration_Flags
or Interface_Library_Unit
or not Bind_Main_Program);
if Check_Elab_Flag then
Set_String (" if E");
Set_Unit_Number (Unum_Spec);
Set_String (" = 0 then");
......@@ -1491,14 +1521,13 @@ package body Bindgen is
Set_Char (';');
Write_Statement_Buffer;
if Force_Checking_Of_Elaboration_Flags
or Interface_Library_Unit
or not Bind_Main_Program
then
if Check_Elab_Flag then
WBI (" end if;");
end if;
if U.Utype /= Is_Spec then
if U.Utype /= Is_Spec
and then not CodePeer_Mode
then
Set_String (" E");
Set_Unit_Number (Unum_Spec);
Set_String (" := E");
......@@ -1717,6 +1746,10 @@ package body Bindgen is
-- Start of processing for Gen_Finalize_Library_Ada
begin
if CodePeer_Mode then
return;
end if;
for E in reverse Elab_Order.First .. Elab_Order.Last loop
Unum := Elab_Order.Table (E);
U := Units.Table (Unum);
......@@ -2211,7 +2244,9 @@ package body Bindgen is
-- Initialize and Finalize
if not Cumulative_Restrictions.Set (No_Finalization) then
if not CodePeer_Mode
and then not Cumulative_Restrictions.Set (No_Finalization)
then
WBI (" procedure Initialize (Addr : System.Address);");
WBI (" pragma Import (C, Initialize, ""__gnat_initialize"");");
WBI ("");
......@@ -2238,44 +2273,50 @@ package body Bindgen is
-- Deal with declarations for main program case
if not No_Main_Subprogram then
if CodePeer_Mode then
if ALIs.Table (ALIs.First).Main_Program = Func then
WBI (" Result : Integer;");
end if;
else
-- To call the main program, we declare it using a pragma Import
-- Ada with the right link name.
-- To call the main program, we declare it using a pragma Import
-- Ada with the right link name.
-- It might seem more obvious to "with" the main program, and call
-- it in the normal Ada manner. We do not do this for three reasons:
-- 1. It is more efficient not to recompile the main program
-- 2. We are not entitled to assume the source is accessible
-- 3. We don't know what options to use to compile it
-- It might seem more obvious to "with" the main program, and call
-- it in the normal Ada manner. We do not do this for three
-- reasons:
-- It is really reason 3 that is most critical (indeed we used
-- to generate the "with", but several regression tests failed).
-- 1. It is more efficient not to recompile the main program
-- 2. We are not entitled to assume the source is accessible
-- 3. We don't know what options to use to compile it
WBI ("");
-- It is really reason 3 that is most critical (indeed we used
-- to generate the "with", but several regression tests failed).
if ALIs.Table (ALIs.First).Main_Program = Func then
WBI (" Result : Integer;");
WBI ("");
WBI (" function Ada_Main_Program return Integer;");
else
WBI (" procedure Ada_Main_Program;");
end if;
if ALIs.Table (ALIs.First).Main_Program = Func then
WBI (" Result : Integer;");
WBI ("");
WBI (" function Ada_Main_Program return Integer;");
Set_String (" pragma Import (Ada, Ada_Main_Program, """);
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
Set_Main_Program_Name;
Set_String (""");");
else
WBI (" procedure Ada_Main_Program;");
end if;
Write_Statement_Buffer;
WBI ("");
Set_String (" pragma Import (Ada, Ada_Main_Program, """);
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
Set_Main_Program_Name;
Set_String (""");");
if Bind_Main_Program
and then not Suppress_Standard_Library_On_Target
then
WBI (" SEH : aliased array (1 .. 2) of Integer;");
Write_Statement_Buffer;
WBI ("");
if Bind_Main_Program
and then not Suppress_Standard_Library_On_Target
then
WBI (" SEH : aliased array (1 .. 2) of Integer;");
WBI ("");
end if;
end if;
end if;
......@@ -2289,7 +2330,7 @@ package body Bindgen is
-- with a pragma Volatile in order to tell the compiler to preserve
-- this variable at any level of optimization.
if Bind_Main_Program then
if Bind_Main_Program and then not CodePeer_Mode then
WBI
(" Ensure_Reference : aliased System.Address := " &
"Ada_Main_Program_Name'Address;");
......@@ -2301,7 +2342,10 @@ package body Bindgen is
-- Acquire command line arguments if present on target
if Command_Line_Args_On_Target then
if CodePeer_Mode then
null;
elsif Command_Line_Args_On_Target then
WBI (" gnat_argc := argc;");
WBI (" gnat_argv := argv;");
WBI (" gnat_envp := envp;");
......@@ -2339,7 +2383,9 @@ package body Bindgen is
Write_Statement_Buffer;
end if;
if not Cumulative_Restrictions.Set (No_Finalization) then
if not Cumulative_Restrictions.Set (No_Finalization)
and then not CodePeer_Mode
then
if not No_Main_Subprogram
and then Bind_Main_Program
and then not Suppress_Standard_Library_On_Target
......@@ -2383,7 +2429,9 @@ package body Bindgen is
-- Finalize is only called if we have a run time
if not Cumulative_Restrictions.Set (No_Finalization) then
if not Cumulative_Restrictions.Set (No_Finalization)
and then not CodePeer_Mode
then
WBI (" Finalize;");
end if;
......@@ -2986,13 +3034,16 @@ package body Bindgen is
Resolve_Binder_Options;
-- Usually, adafinal is called using a pragma Import C. Since Import C
-- doesn't have the same semantics for JGNAT, we use standard Ada.
-- doesn't have the same semantics for VMs or CodePeer, use standard
-- Ada.
if VM_Target /= No_VM
and then not Suppress_Standard_Library_On_Target
then
WBI ("with System.Soft_Links;");
WBI ("with System.Standard_Library;");
if not Suppress_Standard_Library_On_Target then
if CodePeer_Mode then
WBI ("with System.Standard_Library;");
elsif VM_Target /= No_VM then
WBI ("with System.Soft_Links;");
WBI ("with System.Standard_Library;");
end if;
end if;
WBI ("package " & Ada_Main & " is");
......@@ -3212,38 +3263,41 @@ package body Bindgen is
Gen_Elab_Externals_Ada;
if not Suppress_Standard_Library_On_Target then
if not CodePeer_Mode then
if not Suppress_Standard_Library_On_Target then
-- Generate Priority_Specific_Dispatching pragma string
-- Generate Priority_Specific_Dispatching pragma string
Set_String
(" Local_Priority_Specific_Dispatching : constant String := """);
Set_String
(" Local_Priority_Specific_Dispatching : " &
"constant String := """);
for J in 0 .. PSD_Pragma_Settings.Last loop
Set_Char (PSD_Pragma_Settings.Table (J));
end loop;
for J in 0 .. PSD_Pragma_Settings.Last loop
Set_Char (PSD_Pragma_Settings.Table (J));
end loop;
Set_String (""";");
Write_Statement_Buffer;
Set_String (""";");
Write_Statement_Buffer;
-- Generate Interrupt_State pragma string
-- Generate Interrupt_State pragma string
Set_String (" Local_Interrupt_States : constant String := """);
Set_String (" Local_Interrupt_States : constant String := """);
for J in 0 .. IS_Pragma_Settings.Last loop
Set_Char (IS_Pragma_Settings.Table (J));
end loop;
for J in 0 .. IS_Pragma_Settings.Last loop
Set_Char (IS_Pragma_Settings.Table (J));
end loop;
Set_String (""";");
Write_Statement_Buffer;
WBI ("");
end if;
Set_String (""";");
Write_Statement_Buffer;
WBI ("");
end if;
-- The B.1 (39) implementation advice says that the adainit/adafinal
-- routines should be idempotent. Generate a flag to ensure that.
-- The B.1 (39) implementation advice says that the adainit/adafinal
-- routines should be idempotent. Generate a flag to ensure that.
WBI (" Is_Elaborated : Boolean := False;");
WBI ("");
WBI (" Is_Elaborated : Boolean := False;");
WBI ("");
end if;
-- Generate the adafinal routine unless there is no finalization to do
......
gcc/ada/exp_ch3.adb
......@@ -5022,27 +5022,6 @@ package body Exp_Ch3 is
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 @@ package body Exp_Ch3 is
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
......
gcc/ada/exp_ch4.adb
......@@ -629,14 +629,10 @@ package body Exp_Ch4 is
(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 @@ package body Exp_Ch4 is
-- 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 @@ package body Exp_Ch4 is
Clen : Node_Id;
Set : Boolean;
-- Start of processing for Expand_Concatenate
begin
-- Choose an appropriate computational type
......
gcc/ada/exp_ch6.adb
......@@ -5382,21 +5382,6 @@ 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 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.
......
gcc/ada/exp_ch7.adb
......@@ -1261,7 +1261,7 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
-- 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
......
gcc/ada/exp_disp.adb
......@@ -61,6 +61,7 @@ with Snames; use Snames;
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 @@ package body Exp_Disp is
-- 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 @@ package body Exp_Disp is
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 @@ package body Exp_Disp is
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 @@ package body Exp_Disp is
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;
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;
Rewrite (N, Unchecked_Convert_To (Etype (N), N));
Analyze (N);
return;
end if;
......@@ -6764,13 +6638,20 @@ package body Exp_Disp is
-- 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 @@ package body Exp_Disp is
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
pragma Assert (VM_Target = No_VM);
-- Do not register in the dispatch table eliminated primitives
......
gcc/ada/exp_disp.ads
......@@ -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 @@ 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);
......@@ -353,6 +348,10 @@ package Exp_Disp is
-- 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;
......
gcc/ada/gnatlink.adb
......@@ -1717,7 +1717,7 @@ begin
Linker_Path := System.OS_Lib.Locate_Exec_On_Path ("dotnet-ld");
if Linker_Path = null then
Exit_With_Error ("Couldn't locate ilasm");
Exit_With_Error ("Couldn't locate dotnet-ld");
end if;
elsif RTX_RTSS_Kernel_Module_On_Target then
......
gcc/ada/rtsfind.ads
......@@ -561,6 +561,7 @@ package Rtsfind is
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 @@ package Rtsfind is
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,
......
gcc/ada/sem_ch6.adb
......@@ -2849,7 +2849,8 @@ package body Sem_Ch6 is
-- raises an exception, but in any case it is not coming
-- back here, so turn on the flag.
if Ekind (Ent) = E_Procedure
if Present (Ent)
and then Ekind (Ent) = E_Procedure
and then No_Return (Ent)
then
Set_Trivial_Subprogram (Stm);
......
gcc/ada/sem_disp.adb
......@@ -49,6 +49,7 @@ with Sem_Type; use Sem_Type;
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 @@ package body Sem_Disp is
" 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 @@ package body Sem_Disp is
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));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment