From: Arnaud Charlet Date: Thu, 4 Aug 2011 13:45:00 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=f46faa08530f834488a7ab292af8946005d3b153;p=gcc.git [multiple changes] 2011-08-04 Javier Miranda * 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 * gnatlink.adb (Gnatlink): Correct missleading error message displayed when dotnet-ld cannot be found. 2011-08-04 Arnaud Charlet * 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ec696b94f1b..9e1dd4078a0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,42 @@ +2011-08-04 Javier Miranda + + * 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 + + * gnatlink.adb (Gnatlink): Correct missleading error message displayed + when dotnet-ld cannot be found. + +2011-08-04 Arnaud Charlet + + * 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 * sem_prag.adb, sem.ads: Code cleanup. diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index f2714cdd895..47e1d1b7f8f 100644 --- a/gcc/ada/bindgen.adb +++ b/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 diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index a5038a992a6..eafb238a6ed 100644 --- a/gcc/ada/exp_ch3.adb +++ b/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 diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d99157ab4d0..d2852e3dd80 100644 --- a/gcc/ada/exp_ch4.adb +++ b/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 diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index dfa5b3f9643..cb6a6543ca4 100644 --- a/gcc/ada/exp_ch6.adb +++ b/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. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 452b9e5b2e4..c31682caec7 100644 --- a/gcc/ada/exp_ch7.adb +++ b/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 diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 4df6eff6021..a9ae2c55172 100644 --- a/gcc/ada/exp_disp.adb +++ b/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 diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 82a9d9abc15..306cec228ef 100644 --- a/gcc/ada/exp_disp.ads +++ b/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; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index c2e2de74f49..946c7b54177 100644 --- a/gcc/ada/gnatlink.adb +++ b/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 diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 1d545dfe596..d60de40b643 100644 --- a/gcc/ada/rtsfind.ads +++ b/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, diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 98b6d91c4ff..986a1e867f2 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index b58f8c0e1a7..66fcb07e0ab 100644 --- a/gcc/ada/sem_disp.adb +++ b/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));