+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.
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"");");
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
-- 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;");
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;");
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," &
end if;
WBI (" begin");
-
WBI (" if Is_Elaborated then");
WBI (" return;");
WBI (" end if;");
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
-- 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
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);
------------------------
procedure Gen_Elab_Calls_Ada is
+ Check_Elab_Flag : Boolean;
begin
for E in Elab_Order.First .. Elab_Order.Last loop
declare
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);
-- 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");
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");
-- 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);
-- 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 ("");
-- 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;
-- 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;");
-- 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;");
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
-- 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;
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");
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
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;
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
(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
-- 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));
Clen : Node_Id;
Set : Boolean;
+ -- Start of processing for Expand_Concatenate
+
begin
-- Choose an appropriate computational type
-- 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.
-- 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;
-- 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);
-- 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
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;
-- 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
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
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 --
------------------------------
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;
-- 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);
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
+ pragma Assert (VM_Target = No_VM);
-- Do not register in the dispatch table eliminated primitives
-- --
-- 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- --
-- 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);
-- 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;
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
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
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,
-- 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);
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;
" 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),
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));
projects / gcc.git / commitdiff