diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2015-10-16 11:01:53 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2015-10-16 11:01:53 +0000 |
| commit | 36ac5fbb86ae5778529b8bbebaf0e0e1744eb6be (patch) | |
| tree | 84ccc871dc5fdb6b16df1277042294ec753ecebe | |
| parent | 14fd9219039e56e8b14cf366555ecaae127c4a20 (diff) | |
| download | gcc-36ac5fbb86ae5778529b8bbebaf0e0e1744eb6be.tar.gz | |
2015-10-16 Arnaud Charlet <charlet@adacore.com>
* exp_ch5.adb, sem_ch3.adb, frontend.adb, exp_ch7.adb, exp_ch7.ads,
sem_ch5.adb, sem_type.adb, exp_util.adb, exp_util.ads, comperr.adb,
exp_attr.adb, sinfo.ads, exp_ch9.adb, make.adb, usage.adb,
lib-writ.adb, sem_ch9.adb, bindgen.adb, debug.adb, einfo.adb,
einfo.ads, types.ads, checks.adb, sem_prag.adb, s-tasini.adb,
rtsfind.ads, freeze.adb, sem_util.adb, sem_util.ads, exp_dbug.adb,
gnatlink.adb, gnat1drv.adb, targparm.adb, targparm.ads, exp_ch4.adb,
exp_ch11.adb, repinfo.adb, s-soflin.adb, s-soflin.ads, exp_ch6.adb,
exp_ch13.adb, sem_mech.adb, sem_ch6.adb, par-prag.adb, exp_disp.adb,
sem_ch8.adb, exp_disp.ads, snames.adb-tmpl, exp_aggr.adb, sem_eval.adb,
exp_intr.adb, sem_ch13.adb, snames.ads-tmpl, sem_disp.adb, exp_ch3.adb:
Code clean up: remove special handling for .NET and JVM.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@228874 138bc75d-0d04-0410-961f-82ee72b054a4
56 files changed, 470 insertions, 2759 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3c1f20746f6..c44a267a771 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,20 @@ 2015-10-16 Arnaud Charlet <charlet@adacore.com> + * exp_ch5.adb, sem_ch3.adb, frontend.adb, exp_ch7.adb, exp_ch7.ads, + sem_ch5.adb, sem_type.adb, exp_util.adb, exp_util.ads, comperr.adb, + exp_attr.adb, sinfo.ads, exp_ch9.adb, make.adb, usage.adb, + lib-writ.adb, sem_ch9.adb, bindgen.adb, debug.adb, einfo.adb, + einfo.ads, types.ads, checks.adb, sem_prag.adb, s-tasini.adb, + rtsfind.ads, freeze.adb, sem_util.adb, sem_util.ads, exp_dbug.adb, + gnatlink.adb, gnat1drv.adb, targparm.adb, targparm.ads, exp_ch4.adb, + exp_ch11.adb, repinfo.adb, s-soflin.adb, s-soflin.ads, exp_ch6.adb, + exp_ch13.adb, sem_mech.adb, sem_ch6.adb, par-prag.adb, exp_disp.adb, + sem_ch8.adb, exp_disp.ads, snames.adb-tmpl, exp_aggr.adb, sem_eval.adb, + exp_intr.adb, sem_ch13.adb, snames.ads-tmpl, sem_disp.adb, exp_ch3.adb: + Code clean up: remove special handling for .NET and JVM. + +2015-10-16 Arnaud Charlet <charlet@adacore.com> + * sem_ch12.adb: Minor punctuation fix in comment * s-rident.ads: Minor consistency fix in comment * exp_attr.adb, g-spipat.ads: punctuation fixes in comments. diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 798db09dd40..76e9dc35346 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -352,13 +352,10 @@ package body Bindgen is -- characters of S. The caller must ensure that these characters do in fact -- exist in the Statement_Buffer. - type Qualification_Mode is (Dollar_Sign, Dot, Double_Underscores); - - procedure Set_Unit_Name (Mode : Qualification_Mode := Double_Underscores); + procedure Set_Unit_Name; -- Given a unit name in the Name_Buffer, copy it into Statement_Buffer, -- starting at the Last + 1 position and update Last past the value. - -- Depending on parameter Mode, a dot (.) can be qualified into double - -- underscores (__), a dollar sign ($) or left as is. + -- Each dot (.) will be qualified into double underscores (__). procedure Set_Unit_Number (U : Unit_Id); -- Sets unit number (first unit is 1, leading zeroes output to line up all @@ -380,10 +377,7 @@ package body Bindgen is begin WBI (" procedure " & Ada_Final_Name.all & " is"); - if VM_Target = No_VM - and Bind_Main_Program - and not CodePeer_Mode - then + if 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"");"); @@ -406,10 +400,10 @@ package body Bindgen is WBI (" Runtime_Finalize;"); - -- On non-virtual machine targets, finalization is done differently - -- depending on whether this is the main program or a library. + -- By default (real targets), finalization is done differently depending + -- on whether this is the main program or a library. - if VM_Target = No_VM and then not CodePeer_Mode then + if not CodePeer_Mode then if Bind_Main_Program then WBI (" s_stalib_adafinal;"); elsif Lib_Final_Built then @@ -418,9 +412,9 @@ package body Bindgen is WBI (" null;"); end if; - -- 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. + -- Pragma Import C cannot be used on virtual targets, therefore call the + -- runtime finalization routine directly in CodePeer mode, where + -- imported functions are ignored. else WBI (" System.Standard_Library.Adafinal;"); @@ -443,12 +437,11 @@ package body Bindgen is -- of __gnat_finalize_library_objects. This is declared at library -- level for compatibility with the type used in System.Soft_Links. -- The import of the soft link which performs library-level object - -- finalization is not needed for VM targets; regular Ada is used in + -- finalization does not work for CodePeer, so regular Ada is used in -- that case. For restricted run-time libraries (ZFP and Ravenscar) -- tasks are non-terminating, so we do not want finalization. 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 @@ -638,12 +631,10 @@ package body Bindgen is " ""__gnat_activate_all_tasks"");"); end if; - -- The import of the soft link which performs library-level object - -- finalization is not needed for VM targets; regular Ada is used in - -- that case. For restricted run-time libraries (ZFP and Ravenscar) + -- For restricted run-time libraries (ZFP and Ravenscar) -- tasks are non-terminating, so we do not want finalization. - if VM_Target = No_VM and then not Configurable_Run_Time_On_Target then + if not Configurable_Run_Time_On_Target then WBI (""); WBI (" Finalize_Library_Objects : No_Param_Proc;"); WBI (" pragma Import (C, Finalize_Library_Objects, " & @@ -662,38 +653,6 @@ package body Bindgen is """__gnat_initialize_stack_limit"");"); end if; - -- Special processing when main program is CIL function/procedure - - if VM_Target = CLI_Target - and then Bind_Main_Program - and then not No_Main_Subprogram - then - WBI (""); - - -- Function case, use Set_Exit_Status to report the returned - -- status code, since that is the only mechanism available. - - if ALIs.Table (ALIs.First).Main_Program = Func then - WBI (" Result : Integer;"); - WBI (" procedure Set_Exit_Status (Code : Integer);"); - WBI (" pragma Import (C, Set_Exit_Status, " & - """__gnat_set_exit_status"");"); - WBI (""); - WBI (" function Ada_Main_Program return Integer;"); - - -- Procedure case - - else - WBI (" procedure Ada_Main_Program;"); - end if; - - Get_Name_String (Units.Table (First_Unit_Entry).Uname); - Name_Len := Name_Len - 2; - WBI (" pragma Import (CIL, Ada_Main_Program, """ - & Name_Buffer (1 .. Name_Len) & "." - & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);"); - end if; - -- When dispatching domains are used then we need to signal it -- before calling the main procedure. @@ -836,18 +795,8 @@ package body Bindgen is -- Generate call to Install_Handler - -- In .NET, when binding with -z, we don't install the signal handler - -- to let the caller handle the last exception handler. - WBI (""); - - if VM_Target /= CLI_Target - or else Bind_Main_Program - then - WBI (" Runtime_Initialize (1);"); - else - WBI (" Runtime_Initialize (0);"); - end if; + WBI (" Runtime_Initialize (1);"); end if; -- Generate call to set Initialize_Scalar values if active @@ -888,37 +837,22 @@ package body Bindgen is 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 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. - elsif (VM_Target /= No_VM or else Bind_Main_Program) + elsif Bind_Main_Program and then not Configurable_Run_Time_On_Target and then not Suppress_Standard_Library_On_Target then WBI (""); - if VM_Target = No_VM then - if Lib_Final_Built then - Set_String (" Finalize_Library_Objects := "); - Set_String ("finalize_library'access;"); - else - Set_String (" Finalize_Library_Objects := null;"); - end if; - - -- On VM targets use regular Ada to set the soft link - + if Lib_Final_Built then + Set_String (" Finalize_Library_Objects := "); + Set_String ("finalize_library'access;"); else - if Lib_Final_Built then - Set_String - (" System.Soft_Links.Finalize_Library_Objects"); - Set_String (" := finalize_library'access;"); - else - Set_String - (" System.Soft_Links.Finalize_Library_Objects"); - Set_String (" := null;"); - end if; + Set_String (" Finalize_Library_Objects := null;"); end if; Write_Statement_Buffer; @@ -959,25 +893,6 @@ package body Bindgen is end if; end if; - -- Case of main program is CIL function or procedure - - if VM_Target = CLI_Target - and then Bind_Main_Program - and then not No_Main_Subprogram - then - -- For function case, use Set_Exit_Status to set result - - if ALIs.Table (ALIs.First).Main_Program = Func then - WBI (" Result := Ada_Main_Program;"); - WBI (" Set_Exit_Status (Result);"); - - -- Procedure case - - else - WBI (" Ada_Main_Program;"); - end if; - end if; - WBI (" end " & Ada_Init_Name.all & ";"); WBI (""); end Gen_Adainit; @@ -1188,37 +1103,24 @@ package body Bindgen is Set_String (" "); Get_Decoded_Name_String_With_Brackets (U.Uname); - if VM_Target = CLI_Target and then U.Unit_Kind /= 's' then - if Name_Buffer (Name_Len) = 's' then - Name_Buffer (Name_Len - 1 .. Name_Len + 12) := - "_pkg'elab_spec"; - else - Name_Buffer (Name_Len - 1 .. Name_Len + 12) := - "_pkg'elab_body"; - end if; - - Name_Len := Name_Len + 12; - - else - if Name_Buffer (Name_Len) = 's' then - Name_Buffer (Name_Len - 1 .. Name_Len + 8) := - "'elab_spec"; - Name_Len := Name_Len + 8; + if Name_Buffer (Name_Len) = 's' then + Name_Buffer (Name_Len - 1 .. Name_Len + 8) := + "'elab_spec"; + Name_Len := Name_Len + 8; - -- Special case in CodePeer mode for subprogram bodies - -- which correspond to CodePeer 'Elab_Subp_Body special - -- init procedure. + -- Special case in CodePeer mode for subprogram bodies + -- which correspond to CodePeer 'Elab_Subp_Body special + -- init procedure. - elsif U.Unit_Kind = 's' and CodePeer_Mode then - Name_Buffer (Name_Len - 1 .. Name_Len + 13) := - "'elab_subp_body"; - Name_Len := Name_Len + 13; + elsif U.Unit_Kind = 's' and CodePeer_Mode then + Name_Buffer (Name_Len - 1 .. Name_Len + 13) := + "'elab_subp_body"; + Name_Len := Name_Len + 13; - else - Name_Buffer (Name_Len - 1 .. Name_Len + 8) := - "'elab_body"; - Name_Len := Name_Len + 8; - end if; + else + Name_Buffer (Name_Len - 1 .. Name_Len + 8) := + "'elab_body"; + Name_Len := Name_Len + 8; end if; Set_Casing (U.Icasing); @@ -1294,51 +1196,10 @@ package body Bindgen is Set_String (" "); Set_String ("E"); Set_Unit_Number (Unum); - - case VM_Target is - when No_VM | JVM_Target => - Set_String (" : Short_Integer; pragma Import (Ada, "); - when CLI_Target => - Set_String (" : Short_Integer; pragma Import (CIL, "); - end case; - - Set_String ("E"); + Set_String (" : Short_Integer; pragma Import (Ada, E"); Set_Unit_Number (Unum); Set_String (", """); Get_Name_String (U.Uname); - - -- In the case of JGNAT we need to emit an Import name that - -- includes the class name (using '$' separators in the case - -- of a child unit name). - - if VM_Target /= No_VM then - for J in 1 .. Name_Len - 2 loop - if VM_Target = CLI_Target - or else Name_Buffer (J) /= '.' - then - Set_Char (Name_Buffer (J)); - else - Set_String ("$"); - end if; - end loop; - - if VM_Target /= CLI_Target or else U.Unit_Kind = 's' then - Set_String ("."); - else - Set_String ("_pkg."); - end if; - - -- If the unit name is very long, then split the - -- Import link name across lines using "&" (occurs - -- in some C2 tests). - - if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then - Set_String (""" &"); - Write_Statement_Buffer; - Set_String (" """); - end if; - end if; - Set_Unit_Name; Set_String ("_E"");"); Write_Statement_Buffer; @@ -1467,46 +1328,15 @@ package body Bindgen is Write_Statement_Buffer; -- Generate: - -- pragma Import (CIL, F<Count>, - -- "xx.yy_pkg.xx__yy__finalize_[body|spec]"); - -- -- for .NET targets - - -- pragma Import (Java, F<Count>, - -- "xx$yy.xx__yy__finalize_[body|spec]"); - -- -- for JVM targets - -- pragma Import (Ada, F<Count>, -- "xx__yy__finalize_[body|spec]"); - -- -- for default targets - - if VM_Target = CLI_Target then - Set_String (" pragma Import (CIL, F"); - elsif VM_Target = JVM_Target then - Set_String (" pragma Import (Java, F"); - else - Set_String (" pragma Import (Ada, F"); - end if; + Set_String (" pragma Import (Ada, F"); Set_Int (Count); Set_String (", """); -- Perform name construction - -- .NET xx.yy_pkg.xx__yy__finalize - - if VM_Target = CLI_Target then - Set_Unit_Name (Mode => Dot); - Set_String ("_pkg."); - - -- JVM xx$yy.xx__yy__finalize - - elsif VM_Target = JVM_Target then - Set_Unit_Name (Mode => Dollar_Sign); - Set_Char ('.'); - end if; - - -- Default xx__yy__finalize - Set_Unit_Name; Set_String ("__finalize_"); @@ -1586,31 +1416,17 @@ package body Bindgen is -- raised an exception. In that case import the actual exception -- and the routine necessary to raise it. - if VM_Target = No_VM then - WBI (" declare"); - WBI (" procedure Reraise_Library_Exception_If_Any;"); - - Set_String (" pragma Import (Ada, "); - Set_String ("Reraise_Library_Exception_If_Any, "); - Set_String ("""__gnat_reraise_library_exception_if_any"");"); - Write_Statement_Buffer; - - WBI (" begin"); - WBI (" Reraise_Library_Exception_If_Any;"); - WBI (" end;"); - - -- VM-specific code, use regular Ada to produce the desired behavior + WBI (" declare"); + WBI (" procedure Reraise_Library_Exception_If_Any;"); - else - WBI (" if System.Soft_Links.Library_Exception_Set then"); - - Set_String (" Ada.Exceptions.Reraise_Occurrence ("); - Set_String ("System.Soft_Links.Library_Exception);"); - Write_Statement_Buffer; - - WBI (" end if;"); - end if; + Set_String (" pragma Import (Ada, "); + Set_String ("Reraise_Library_Exception_If_Any, "); + Set_String ("""__gnat_reraise_library_exception_if_any"");"); + Write_Statement_Buffer; + WBI (" begin"); + WBI (" Reraise_Library_Exception_If_Any;"); + WBI (" end;"); WBI (" end finalize_library;"); WBI (""); end if; @@ -1980,18 +1796,16 @@ package body Bindgen is -- Add a "-Ldir" for each directory in the object path - if VM_Target /= CLI_Target then - for J in 1 .. Nb_Dir_In_Obj_Search_Path loop - declare - Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J); - begin - Name_Len := 0; - Add_Str_To_Name_Buffer ("-L"); - Add_Str_To_Name_Buffer (Dir.all); - Write_Linker_Option; - end; - end loop; - end if; + for J in 1 .. Nb_Dir_In_Obj_Search_Path loop + declare + Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J); + begin + Name_Len := 0; + Add_Str_To_Name_Buffer ("-L"); + Add_Str_To_Name_Buffer (Dir.all); + Write_Linker_Option; + end; + end loop; if not (Opt.No_Run_Time_Mode or Opt.No_Stdlib) then Name_Len := 0; @@ -2117,12 +1931,6 @@ package body Bindgen is Set_PSD_Pragma_Table; - -- For JGNAT the main program is already generated by the compiler - - if VM_Target = JVM_Target then - Bind_Main_Program := False; - end if; - -- Override time slice value if -T switch is set if Time_Slice_Set then @@ -2219,9 +2027,6 @@ package body Bindgen is 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; @@ -2231,45 +2036,42 @@ package body Bindgen is -- Main program case if Bind_Main_Program then - if VM_Target = No_VM then + -- Generate argc/argv stuff unless suppressed - -- Generate argc/argv stuff unless suppressed + if Command_Line_Args_On_Target + or not Configurable_Run_Time_On_Target + then + WBI (""); + WBI (" gnat_argc : Integer;"); + WBI (" gnat_argv : System.Address;"); + WBI (" gnat_envp : System.Address;"); - if Command_Line_Args_On_Target - or not Configurable_Run_Time_On_Target - then + -- If the standard library is not suppressed, these variables + -- are in the run-time data area for easy run time access. + + if not Suppress_Standard_Library_On_Target then WBI (""); - WBI (" gnat_argc : Integer;"); - WBI (" gnat_argv : System.Address;"); - WBI (" gnat_envp : System.Address;"); - - -- If the standard library is not suppressed, these variables - -- are in the run-time data area for easy run time access. - - if not Suppress_Standard_Library_On_Target then - WBI (""); - WBI (" pragma Import (C, gnat_argc);"); - WBI (" pragma Import (C, gnat_argv);"); - WBI (" pragma Import (C, gnat_envp);"); - end if; + WBI (" pragma Import (C, gnat_argc);"); + WBI (" pragma Import (C, gnat_argv);"); + WBI (" pragma Import (C, gnat_envp);"); end if; + end if; - -- Define exit status. Again in normal mode, this is in the - -- run-time library, and is initialized there, but in the - -- configurable runtime case, the variable is declared and - -- initialized in this file. - - WBI (""); + -- Define exit status. Again in normal mode, this is in the + -- run-time library, and is initialized there, but in the + -- configurable runtime case, the variable is declared and + -- initialized in this file. - if Configurable_Run_Time_Mode then - if Exit_Status_Supported_On_Target then - WBI (" gnat_exit_status : Integer := 0;"); - end if; + WBI (""); - else - WBI (" gnat_exit_status : Integer;"); - WBI (" pragma Import (C, gnat_exit_status);"); + if Configurable_Run_Time_Mode then + if Exit_Status_Supported_On_Target then + WBI (" gnat_exit_status : Integer := 0;"); end if; + + else + WBI (" gnat_exit_status : Integer;"); + WBI (" pragma Import (C, gnat_exit_status);"); end if; -- Generate the GNAT_Version and Ada_Main_Program_Name info only for @@ -2289,12 +2091,8 @@ package body Bindgen is Set_String (" Ada_Main_Program_Name : constant String := """); Get_Name_String (Units.Table (First_Unit_Entry).Uname); - if VM_Target = No_VM then - Set_Main_Program_Name; - Set_String (""" & ASCII.NUL;"); - else - Set_String (Name_Buffer (1 .. Name_Len - 2) & """;"); - end if; + Set_Main_Program_Name; + Set_String (""" & ASCII.NUL;"); Write_Statement_Buffer; @@ -2326,7 +2124,7 @@ package body Bindgen is end if; end if; - if Bind_Main_Program and then VM_Target = No_VM then + if Bind_Main_Program then WBI (""); @@ -2505,7 +2303,7 @@ package body Bindgen is Gen_Adainit; - if Bind_Main_Program and then VM_Target = No_VM then + if Bind_Main_Program then Gen_Main; end if; @@ -2706,17 +2504,11 @@ package body Bindgen is Nlen : Natural; begin - -- The main program generated by JGNAT expects a package called - -- ada_<main procedure>. - if VM_Target /= No_VM then - Get_Name_String (Units.Table (First_Unit_Entry).Uname); - return "ada_" & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2)); - end if; - -- For CodePeer, we want reproducible names (independent of other -- mains that may or may not be present) that don't collide -- when analyzing multiple mains and which are easily recognizable -- as "ada_main" names. + if CodePeer_Mode then Get_Name_String (Units.Table (First_Unit_Entry).Uname); return "ada_main_for_" & @@ -3122,17 +2914,11 @@ package body Bindgen is -- Set_Unit_Name -- ------------------- - procedure Set_Unit_Name (Mode : Qualification_Mode := Double_Underscores) is + procedure Set_Unit_Name is begin for J in 1 .. Name_Len - 2 loop if Name_Buffer (J) = '.' then - if Mode = Double_Underscores then - Set_String ("__"); - elsif Mode = Dot then - Set_Char ('.'); - else - Set_Char ('$'); - end if; + Set_String ("__"); else Set_Char (Name_Buffer (J)); end if; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index b2e779c99e6..929bdc535d9 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1037,17 +1037,12 @@ package body Checks is -- operation on signed integers on which the expander can promote -- later the operands to type Integer (see Expand_N_Type_Conversion). - -- Special case CLI target, where arithmetic overflow checks can be - -- performed for integer and long_integer - if Backend_Overflow_Checks_On_Target or else not Do_Overflow_Check (N) or else not Expander_Active or else (Present (Parent (N)) and then Nkind (Parent (N)) = N_Type_Conversion and then Integer_Promotion_Possible (Parent (N))) - or else - (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size) then return; end if; @@ -5903,11 +5898,6 @@ package body Checks is elsif Nkind_In (Expr, N_Integer_Literal, N_Character_Literal) then return True; - -- Real literals are assumed to be valid in VM targets - - elsif VM_Target /= No_VM and then Nkind (Expr) = N_Real_Literal then - return True; - -- If we have a type conversion or a qualification of a known valid -- value, then the result will always be valid. diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index cabc028417b..f32db3267b8 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -40,7 +40,6 @@ with Sinfo; use Sinfo; with Sinput; use Sinput; with Sprint; use Sprint; with Sdefault; use Sdefault; -with Targparm; use Targparm; with Treepr; use Treepr; with Types; use Types; @@ -116,35 +115,19 @@ package body Comperr is Abort_In_Progress := True; -- Generate a "standard" error message instead of a bug box in case - -- of .NET compiler, since we do not support all constructs of the - -- language. Of course ideally, we should detect this before bombing on - -- e.g. an assertion error, but in practice most of these bombs are due - -- to a legitimate case of a construct not being supported (in a sense - -- they all are, since for sure we are not supporting something if we - -- bomb). By giving this message, we provide a more reasonable practical - -- interface, since giving scary bug boxes on unsupported features is - -- definitely not helpful. - - -- Similarly if we are generating SCIL, an error message is sufficient - -- instead of generating a bug box. + -- of CodePeer rather than generating a bug box, friendlier. -- Note that the call to Error_Msg_N below sets Serious_Errors_Detected -- to 1, so we use the regular mechanism below in order to display a -- "compilation abandoned" message and exit, so we still know we have -- this case (and -gnatdk can still be used to get the bug box). - if (VM_Target = CLI_Target or else CodePeer_Mode) + if CodePeer_Mode and then Serious_Errors_Detected = 0 and then not Debug_Flag_K and then Sloc (Current_Error_Node) > No_Location then - if VM_Target = CLI_Target then - Error_Msg_N - ("unsupported construct in this context", - Current_Error_Node); - else - Error_Msg_N ("cannot generate 'S'C'I'L", Current_Error_Node); - end if; + Error_Msg_N ("cannot generate 'S'C'I'L", Current_Error_Node); end if; -- If we are in CodePeer mode, we must also delete SCIL files diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 7f70bfa0217..60c06f62bab 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -105,8 +105,8 @@ package body Debug is -- d.l Use Ada 95 semantics for limited function returns -- d.m For -gnatl, print full source only for main unit -- d.n Print source file names - -- d.o Generate .NET listing of CIL code - -- d.p Enable the .NET CIL verifier + -- d.o + -- d.p -- d.q -- d.r Enable OK_To_Reorder_Components in non-variant records -- d.s Disable expansion of slice move, use memmove @@ -560,13 +560,6 @@ package body Debug is -- compiler has a bug -- these are the files that need to be included -- in a bug report. - -- d.o Generate listing showing the IL instructions generated by the .NET - -- compiler for each subprogram. - - -- d.p Enable the .NET CIL verifier. During development the verifier is - -- disabled by default and this flag is used to enable it. In the - -- future we will reverse this functionality. - -- d.r Forces the flag OK_To_Reorder_Components to be set in all record -- base types that have no discriminants. @@ -597,10 +590,10 @@ package body Debug is -- d.z Restore previous front-end support for Inline_Always. In default -- mode, for targets that use the GCC back end (i.e. currently all - -- targets except AAMP, .NET, JVM, and GNATprove), Inline_Always is - -- handled by the back end. Use of this switch restores the previous - -- handling of Inline_Always by the front end on such targets. For the - -- targets that do not use the GCC back end, this switch is ignored. + -- targets except AAMP and GNATprove), Inline_Always is handled by the + -- back end. Use of this switch restores the previous handling of + -- Inline_Always by the front end on such targets. For the targets + -- that do not use the GCC back end, this switch is ignored. -- d.A There seems to be a problem with ASIS if we activate the circuit -- for reading and writing the aspect specification hash table, so diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index eb57b6996d8..6dd5c96abc2 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -516,7 +516,6 @@ package body Einfo is -- Has_Pragma_Unreferenced_Objects Flag212 -- Requires_Overriding Flag213 -- Has_RACW Flag214 - -- Has_Uplevel_Reference Flag215 -- Universal_Aliasing Flag216 -- Suppress_Value_Tracking_On_Call Flag217 -- Is_Primitive Flag218 @@ -1847,11 +1846,6 @@ package body Einfo is return Flag72 (Id); end Has_Unknown_Discriminants; - function Has_Uplevel_Reference (Id : E) return B is - begin - return Flag215 (Id); - end Has_Uplevel_Reference; - function Has_Visible_Refinement (Id : E) return B is begin pragma Assert (Ekind (Id) = E_Abstract_State); @@ -4756,11 +4750,6 @@ package body Einfo is Set_Flag72 (Id, V); end Set_Has_Unknown_Discriminants; - procedure Set_Has_Uplevel_Reference (Id : E; V : B := True) is - begin - Set_Flag215 (Id, V); - end Set_Has_Uplevel_Reference; - procedure Set_Has_Visible_Refinement (Id : E; V : B := True) is begin pragma Assert (Ekind (Id) = E_Abstract_State); @@ -8770,7 +8759,6 @@ package body Einfo is W ("Has_Thunks", Flag228 (Id)); W ("Has_Unchecked_Union", Flag123 (Id)); W ("Has_Unknown_Discriminants", Flag72 (Id)); - W ("Has_Uplevel_Reference", Flag215 (Id)); W ("Has_Visible_Refinement", Flag263 (Id)); W ("Has_Volatile_Components", Flag87 (Id)); W ("Has_Xref_Entry", Flag182 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 49d26fb5078..9f291909431 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2029,15 +2029,6 @@ package Einfo is -- on the partial view, to insure that discriminants are properly -- inherited in certain contexts. --- Has_Uplevel_Reference (Flag215) --- Defined in all entities. Indicates that the entity is locally defined --- within a subprogram P, and there is a reference to the entity within --- a subprogram nested within P (at any depth). Set only for the VM case --- (where it is set for variables, constants, and loop parameters). Note --- that this is similar in usage to Is_Uplevel_Referenced_Entity (which --- is used when we are unnesting subprograms), but the usages are a bit --- different and it is cleaner to leave the old VM usage unchanged. - -- Has_Visible_Refinement (Flag263) -- Defined in E_Abstract_State entities. Set when a state has at least -- one refinement constituent and analysis is in the region between @@ -2425,7 +2416,7 @@ package Einfo is -- Defined in all entities. Set if the entity is exported. For now we -- only allow the export of constants, exceptions, functions, procedures -- and variables, but that may well change later on. Exceptions can only --- be exported in the Java VM implementation of GNAT. +-- be exported in the Java VM implementation of GNAT, which is retired. -- Is_External_State (synthesized) -- Applies to all entities, true for abstract states that are subject to @@ -2549,7 +2540,7 @@ package Einfo is -- Defined in all entities. Set if the entity is imported. For now we -- only allow the import of exceptions, functions, procedures, packages. -- and variables. Exceptions, packages and types can only be imported in --- the Java VM implementation. +-- the Java VM implementation, which is retired. -- Is_Incomplete_Or_Private_Type (synthesized) -- Applies to all entities, true for private and incomplete types @@ -3035,9 +3026,7 @@ package Einfo is -- static bounds, a record all of whose component types are static types, -- or an array, all of whose bounds are of a static type, and also have -- a component type that is a static type). See Set_Uplevel_Type for more --- information on how this flag is used. Note that if Is_Static_Type is --- True, then it is never the case that the Has_Uplevel_Reference flag is --- set for the same type. +-- information on how this flag is used. -- Is_Statically_Allocated (Flag28) -- Defined in all entities. This can only be set for exception, @@ -3162,10 +3151,6 @@ package Einfo is -- the cases where the reference is implicit (e.g. the type of an array -- used for computing the location of an element in an array. This is -- used internally in Exp_Unst, see this package for further details. --- Note that this is similar to the Has_Uplevel_Reference flag which --- is used in the VM case but we prefer to keep the two cases entirely --- separated, so that the VM usage is not disturbed by work on the --- Unnesting_Subprograms mode. -- Is_Valued_Procedure (Flag127) -- Defined in procedure entities. Set if an Import_Valued_Procedure @@ -5311,7 +5296,6 @@ package Einfo is -- Has_Qualified_Name (Flag161) -- Has_Stream_Size_Clause (Flag184) -- Has_Unknown_Discriminants (Flag72) - -- Has_Uplevel_Reference (Flag215) -- Has_Xref_Entry (Flag182) -- In_Private_Part (Flag45) -- Is_Ada_2005_Only (Flag185) @@ -6868,7 +6852,6 @@ package Einfo is function Has_Thunks (Id : E) return B; function Has_Unchecked_Union (Id : E) return B; function Has_Unknown_Discriminants (Id : E) return B; - function Has_Uplevel_Reference (Id : E) return B; function Has_Visible_Refinement (Id : E) return B; function Has_Volatile_Components (Id : E) return B; function Has_Xref_Entry (Id : E) return B; @@ -7524,7 +7507,6 @@ package Einfo is procedure Set_Has_Thunks (Id : E; V : B := True); procedure Set_Has_Unchecked_Union (Id : E; V : B := True); procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True); - procedure Set_Has_Uplevel_Reference (Id : E; V : B := True); procedure Set_Has_Visible_Refinement (Id : E; V : B := True); procedure Set_Has_Volatile_Components (Id : E; V : B := True); procedure Set_Has_Xref_Entry (Id : E; V : B := True); @@ -8299,7 +8281,6 @@ package Einfo is pragma Inline (Has_Thunks); pragma Inline (Has_Unchecked_Union); pragma Inline (Has_Unknown_Discriminants); - pragma Inline (Has_Uplevel_Reference); pragma Inline (Has_Visible_Refinement); pragma Inline (Has_Volatile_Components); pragma Inline (Has_Xref_Entry); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 6cdd290bd9e..cbb15811075 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -664,16 +664,6 @@ package body Exp_Aggr is return False; end if; - -- Checks 11: Array aggregates with aliased components are currently - -- not well supported by the VM backend; disable temporarily this - -- backend processing until it is definitely supported. - - if VM_Target /= No_VM - and then Has_Aliased_Components (Base_Type (Typ)) - then - return False; - end if; - -- Backend processing is possible Set_Size_Known_At_Compile_Time (Etype (N), True); @@ -2534,8 +2524,8 @@ package body Exp_Aggr is Set_No_Ctrl_Actions (First (Assign)); -- Assign the tag now to make sure that the dispatching call in - -- the subsequent deep_adjust works properly (unless VM_Target, - -- where tags are implicit). + -- the subsequent deep_adjust works properly (unless + -- Tagged_Type_Expansion where tags are implicit). if Tagged_Type_Expansion then Instr := @@ -5475,7 +5465,6 @@ package body Exp_Aggr is -- then we could go into an infinite recursion. if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK) - and then VM_Target = No_VM and then not AAMP_On_Target and then not Generate_SCIL and then not Possible_Bit_Aligned_Component (Target) @@ -5851,7 +5840,8 @@ package body Exp_Aggr is -- These are cases where the source expression may have a tag that -- could differ from the component tag (e.g., can occur for type -- conversions and formal parameters). (Tag adjustment not needed - -- if VM_Target because object tags are implicit in the machine.) + -- if Tagged_Type_Expansion because object tags are implicit in + -- the machine.) if Is_Tagged_Type (Etype (Expr_Q)) and then (Nkind (Expr_Q) = N_Type_Conversion diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index bc85ea3485d..ed10ccda8f1 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2223,14 +2223,7 @@ package body Exp_Attr is Prefix => Pref, Attribute_Name => Name_Tag); - if VM_Target = No_VM then - New_Node := Build_Get_Alignment (Loc, New_Node); - else - New_Node := - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Get_Alignment), Loc), - Parameter_Associations => New_List (New_Node)); - end if; + New_Node := Build_Get_Alignment (Loc, New_Node); -- Case where the context is a specific integer type with which -- the original attribute was compatible. The function has a @@ -2901,17 +2894,8 @@ package body Exp_Attr is begin if Nkind (Nod) = N_Selected_Component then Make_Elab_String (Prefix (Nod)); - - case VM_Target is - when JVM_Target => - Store_String_Char ('$'); - when CLI_Target => - Store_String_Char ('.'); - when No_VM => - Store_String_Char ('_'); - Store_String_Char ('_'); - end case; - + Store_String_Char ('_'); + Store_String_Char ('_'); Get_Name_String (Chars (Selector_Name (Nod))); else @@ -2930,14 +2914,8 @@ package body Exp_Attr is Start_String; Make_Elab_String (Pref); - - if VM_Target = No_VM then - Store_String_Chars ("___elab"); - Lang := Make_Identifier (Loc, Name_C); - else - Store_String_Chars ("._elab"); - Lang := Make_Identifier (Loc, Name_Ada); - end if; + Store_String_Chars ("___elab"); + Lang := Make_Identifier (Loc, Name_C); if Id = Attribute_Elab_Body then Store_String_Char ('b'); @@ -4189,11 +4167,7 @@ package body Exp_Attr is -- are not part of the actual type. Transform the attribute reference -- into a runtime expression to add the size of the hidden header. - -- Do not perform this expansion on .NET/JVM targets because the - -- two pointers are already present in the type. - - if VM_Target = No_VM - and then Needs_Finalization (Ptyp) + if Needs_Finalization (Ptyp) and then not Header_Size_Added (Attr) then Set_Header_Size_Added (Attr); @@ -7554,9 +7528,6 @@ package body Exp_Attr is -- that appear in GNAT's library, but will generate calls via rtsfind -- to library routines for user code. - -- ??? For now, disable this code for JVM, since this generates a - -- VerifyError exception at run time on e.g. c330001. - -- This is disabled for AAMP, to avoid creating dependences on files not -- supported in the AAMP library (such as s-fileio.adb). @@ -7567,8 +7538,7 @@ package body Exp_Attr is -- instead. That is why we include the test Is_Available when dealing -- with these cases. - if VM_Target /= JVM_Target - and then not AAMP_On_Target + if not AAMP_On_Target and then not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) then @@ -8044,8 +8014,7 @@ package body Exp_Attr is function Is_GCC_Target return Boolean is begin - return VM_Target = No_VM and then not CodePeer_Mode - and then not AAMP_On_Target; + return not CodePeer_Mode and then not AAMP_On_Target; end Is_GCC_Target; -- Start of processing for Exp_Attr diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 6ffc8a02f50..798704502f9 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1094,33 +1094,14 @@ package body Exp_Ch11 is end; end if; - -- The processing at this point is rather different for the JVM - -- case, so we completely separate the processing. - - -- For the VM case, we unconditionally call Update_Exception, - -- passing a call to the intrinsic Current_Target_Exception - -- (see JVM/.NET versions of Ada.Exceptions for details). - - if VM_Target /= No_VM then - declare - Arg : constant Node_Id := - Make_Function_Call (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Current_Target_Exception), Loc)); - begin - Prepend_Call_To_Handler - (RE_Update_Exception, New_List (Arg)); - end; - - -- For the normal case, we have to worry about the state of - -- abort deferral. Generally, we defer abort during runtime - -- handling of exceptions. When control is passed to the - -- handler, then in the normal case we undefer aborts. In - -- any case this entire handling is relevant only if aborts - -- are allowed. - - elsif Abort_Allowed + -- For the normal case, we have to worry about the state of + -- abort deferral. Generally, we defer abort during runtime + -- handling of exceptions. When control is passed to the + -- handler, then in the normal case we undefer aborts. In + -- any case this entire handling is relevant only if aborts + -- are allowed. + + if Abort_Allowed and then Exception_Mechanism /= Back_End_Exceptions then -- There are some special cases in which we do not do the @@ -1269,14 +1250,6 @@ package body Exp_Ch11 is -- Start of processing for Expand_N_Exception_Declaration begin - -- There is no expansion needed when compiling for the JVM since the - -- JVM has a built-in exception mechanism. See cil/gnatlib/a-except.ads - -- for details. - - if VM_Target /= No_VM then - return; - end if; - -- Definition of the external name: nam : constant String := "A.B.NAME"; Ex_Id := @@ -1726,13 +1699,12 @@ package body Exp_Ch11 is else -- Bypass expansion to a run-time call when back-end exception - -- handling is active, unless the target is a VM, CodePeer or - -- GNATprove. In CodePeer, raising an exception is treated as an - -- error, while in GNATprove all code with exceptions falls outside - -- the subset of code which can be formally analyzed. + -- handling is active, unless the target is CodePeer or GNATprove. + -- In CodePeer, raising an exception is treated as an error, while in + -- GNATprove all code with exceptions falls outside the subset of + -- code which can be formally analyzed. - if VM_Target = No_VM - and then not CodePeer_Mode + if not CodePeer_Mode and then Exception_Mechanism = Back_End_Exceptions then return; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 65fa3238a49..6fd7dedfcae 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -47,7 +47,6 @@ with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Validsw; use Validsw; @@ -291,12 +290,6 @@ package body Exp_Ch13 is if Restriction_Active (No_Finalization) then return; - - -- Do not create a specialized Deallocate since .NET/JVM compilers do - -- not support pools and address arithmetic. - - elsif VM_Target /= No_VM then - return; end if; -- Use the base type to perform the check for finalization master diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 8574ba0fd46..8f8b6d741b2 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -671,14 +671,9 @@ package body Exp_Ch3 is -- Nothing to generate in the following cases: -- 1. Initialization is suppressed for the type - -- 2. The type is a value type, in the CIL sense. - -- 3. The type has CIL/JVM convention. - -- 4. An initialization already exists for the base type + -- 2. An initialization already exists for the base type if Initialization_Suppressed (A_Type) - or else Is_Value_Type (Comp_Type) - or else Convention (A_Type) = Convention_CIL - or else Convention (A_Type) = Convention_Java or else Present (Base_Init_Proc (A_Type)) then return; @@ -1480,13 +1475,8 @@ package body Exp_Ch3 is -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars -- is active (in which case we make the call anyway, since in the -- actual compiled client it may be non null). - -- Also nothing to do for value types. - if (Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars) - or else Is_Value_Type (Typ) - or else - (Is_Array_Type (Typ) and then Is_Value_Type (Component_Type (Typ))) - then + if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then return Empty_List; end if; @@ -1861,8 +1851,8 @@ package body Exp_Ch3 is Set_No_Ctrl_Actions (First (Res)); -- Adjust the tag if tagged (because of possible view conversions). - -- Suppress the tag adjustment when VM_Target because VM tags are - -- represented implicitly in objects. + -- Suppress the tag adjustment when not Tagged_Type_Expansion because + -- tags are represented implicitly in objects. if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then Append_To (Res, @@ -2174,8 +2164,8 @@ package body Exp_Ch3 is begin -- Offset_To_Top_Functions are built only for derivations of types -- with discriminants that cover interface types. - -- Nothing is needed either in case of virtual machines, since - -- interfaces are handled directly by the VM. + -- Nothing is needed either in case of virtual targets, since + -- interfaces are handled directly by the target. if not Is_Tagged_Type (Rec_Type) or else Etype (Rec_Type) = Rec_Type @@ -2439,10 +2429,10 @@ package body Exp_Ch3 is -- _Init._Tag := Typ'Tag; - -- Suppress the tag assignment when VM_Target because VM tags are - -- represented implicitly in objects. It is also suppressed in case - -- of CPP_Class types because in this case the tag is initialized in - -- the C++ side. + -- Suppress the tag assignment when not Tagged_Type_Expansion because + -- tags are represented implicitly in objects. It is also suppressed + -- in case of CPP_Class types because in this case the tag is + -- initialized in the C++ side. if Is_Tagged_Type (Rec_Type) and then Tagged_Type_Expansion @@ -2694,11 +2684,7 @@ package body Exp_Ch3 is -- list by Insert_Actions. and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement - and then VM_Target = No_VM then - -- Even though the init proc may be null at this time it might get - -- some stuff added to it later by the VM backend. - Set_Is_Null_Init_Proc (Proc_Id); end if; end Build_Init_Procedure; @@ -3525,14 +3511,8 @@ package body Exp_Ch3 is -- Start of processing for Build_Record_Init_Proc begin - -- Check for value type, which means no initialization required - Rec_Type := Defining_Identifier (N); - if Is_Value_Type (Rec_Type) then - return; - end if; - -- This may be full declaration of a private type, in which case -- the visible entity is a record, and the private entity has been -- exchanged with it in the private part of the current package. @@ -4761,24 +4741,6 @@ package body Exp_Ch3 is elsif Is_Limited_Class_Wide_Type (Desig_Typ) and then Tasking_Allowed - - -- Do not create a class-wide master for types whose convention is - -- Java since these types cannot embed Ada tasks anyway. Note that - -- the following test cannot catch the following case: - - -- package java.lang.Object is - -- type Typ is tagged limited private; - -- type Ref is access all Typ'Class; - -- private - -- type Typ is tagged limited ...; - -- pragma Convention (Typ, Java) - -- end; - - -- Because the convention appears after we have done the - -- processing for type Ref. - - and then Convention (Desig_Typ) /= Convention_Java - and then Convention (Desig_Typ) /= Convention_CIL then Build_Class_Wide_Master (Ptr_Typ); end if; @@ -5147,12 +5109,11 @@ package body Exp_Ch3 is -- Step 2: Initialize the components of the object -- Do not initialize the components if their initialization is - -- prohibited or the type represents a value type in a .NET VM. + -- prohibited. if Has_Non_Null_Base_Init_Proc (Typ) and then not No_Initialization (N) and then not Initialization_Suppressed (Typ) - and then not Is_Value_Type (Typ) then -- Do not initialize the components if No_Default_Initialization -- applies as the actual restriction check will occur later @@ -5898,10 +5859,10 @@ package body Exp_Ch3 is -- be re-initialized separately in order to avoid the propagation -- of a wrong tag coming from a view conversion unless the type -- is class wide (in this case the tag comes from the init value). - -- Suppress the tag assignment when VM_Target because VM tags are - -- represented implicitly in objects. Ditto for types that are - -- CPP_CLASS, and for initializations that are aggregates, because - -- they have to have the right tag. + -- Suppress the tag assignment when not Tagged_Type_Expansion + -- because tags are represented implicitly in objects. Ditto for + -- types that are CPP_CLASS, and for initializations that are + -- aggregates, because they have to have the right tag. -- The re-assignment of the tag has to be done even if the object -- is a constant. The assignment must be analyzed after the @@ -6500,18 +6461,10 @@ package body Exp_Ch3 is elsif Is_Concurrent_Type (Root) or else Is_C_Derivation (Root) - or else Convention (Typ) = Convention_CIL or else Convention (Typ) = Convention_CPP - or else Convention (Typ) = Convention_Java then return; - -- Do not create TSS routine Finalize_Address for .NET/JVM because these - -- targets do not support address arithmetic and unchecked conversions. - - elsif VM_Target /= No_VM then - return; - -- Do not create TSS routine Finalize_Address when compiling in CodePeer -- mode since the routine contains an Unchecked_Conversion. @@ -7034,14 +6987,6 @@ package body Exp_Ch3 is then null; - -- Do not add the spec of predefined primitives in case of - -- CIL and Java tagged types - - elsif Convention (Def_Id) = Convention_CIL - or else Convention (Def_Id) = Convention_Java - then - null; - -- Do not add the spec of the predefined primitives if we are -- compiling under restriction No_Dispatching_Calls. @@ -7098,8 +7043,8 @@ package body Exp_Ch3 is end if; -- Create and decorate the tags. Suppress their creation when - -- VM_Target because the dispatching mechanism is handled - -- internally by the VMs. + -- not Tagged_Type_Expansion because the dispatching mechanism is + -- handled internally by the virtual target. if Tagged_Type_Expansion then Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); @@ -7111,9 +7056,6 @@ 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 @@ -7240,8 +7182,8 @@ package body Exp_Ch3 is if Tagged_Type_Expansion or else not Is_Interface (Def_Id) then - -- Do not need init for interfaces on e.g. CIL since they're - -- abstract. Helps operation of peverify (the PE Verify tool). + -- Do not need init for interfaces on virtual targets since they're + -- abstract. Build_Record_Init_Proc (Type_Decl, Def_Id); end if; @@ -7262,14 +7204,6 @@ package body Exp_Ch3 is then null; - -- Do not add the body of predefined primitives in case of CIL and - -- Java tagged types. - - elsif Convention (Def_Id) = Convention_CIL - or else Convention (Def_Id) = Convention_Java - then - null; - -- Do not add the body of the predefined primitives if we are -- compiling under restriction No_Dispatching_Calls or if we are -- compiling a CPP tagged type. @@ -7345,75 +7279,62 @@ package body Exp_Ch3 is and then Needs_Finalization (Designated_Type (Comp_Typ)) and then Designated_Type (Comp_Typ) /= Def_Id then - if VM_Target = No_VM then - - -- Build a homogeneous master for the first anonymous - -- access-to-controlled component. This master may be - -- converted into a heterogeneous collection if more - -- components are to follow. + -- Build a homogeneous master for the first anonymous + -- access-to-controlled component. This master may be + -- converted into a heterogeneous collection if more + -- components are to follow. - if not Master_Built then - Master_Built := True; + if not Master_Built then + Master_Built := True; - -- All anonymous access-to-controlled types allocate - -- on the global pool. Note that the finalization - -- master and the associated storage pool must be set - -- on the root type (both are "root type only"). + -- All anonymous access-to-controlled types allocate + -- on the global pool. Note that the finalization + -- master and the associated storage pool must be set + -- on the root type (both are "root type only"). - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); + Set_Associated_Storage_Pool + (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - Build_Finalization_Master - (Typ => Root_Type (Comp_Typ), - For_Anonymous => True, - Context_Scope => Encl_Scope, - Insertion_Node => Ins_Node); + Build_Finalization_Master + (Typ => Root_Type (Comp_Typ), + For_Anonymous => True, + Context_Scope => Encl_Scope, + Insertion_Node => Ins_Node); - Fin_Mas_Id := Finalization_Master (Comp_Typ); + Fin_Mas_Id := Finalization_Master (Comp_Typ); - -- Subsequent anonymous access-to-controlled components - -- reuse the available master. + -- Subsequent anonymous access-to-controlled components + -- reuse the available master. - else - -- All anonymous access-to-controlled types allocate - -- on the global pool. Note that both the finalization - -- master and the associated storage pool must be set - -- on the root type (both are "root type only"). + else + -- All anonymous access-to-controlled types allocate + -- on the global pool. Note that both the finalization + -- master and the associated storage pool must be set + -- on the root type (both are "root type only"). - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); + Set_Associated_Storage_Pool + (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - -- Shared the master among multiple components + -- Shared the master among multiple components - Set_Finalization_Master - (Root_Type (Comp_Typ), Fin_Mas_Id); + Set_Finalization_Master + (Root_Type (Comp_Typ), Fin_Mas_Id); - -- Convert the master into a heterogeneous collection. - -- Generate: - -- Set_Is_Heterogeneous (<Fin_Mas_Id>); + -- Convert the master into a heterogeneous collection. + -- Generate: + -- Set_Is_Heterogeneous (<Fin_Mas_Id>); - if not Attributes_Set then - Attributes_Set := True; + if not Attributes_Set then + Attributes_Set := True; - Insert_Action (Ins_Node, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Set_Is_Heterogeneous), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Fin_Mas_Id, Loc)))); - end if; + Insert_Action (Ins_Node, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Set_Is_Heterogeneous), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Fin_Mas_Id, Loc)))); end if; - - -- Since .NET/JVM targets do not support heterogeneous - -- masters, each component must have its own master. - - else - Build_Finalization_Master - (Typ => Comp_Typ, - For_Anonymous => True, - Context_Scope => Encl_Scope, - Insertion_Node => Ins_Node); end if; end if; @@ -7747,10 +7668,6 @@ package body Exp_Ch3 is elsif Ada_Version >= Ada_2012 and then Present (Associated_Storage_Pool (Def_Id)) - -- Omit this check on .NET/JVM where pools are not supported - - and then VM_Target = No_VM - -- Omit this check for the case of a configurable run-time that -- does not provide package System.Storage_Pools.Subpools. @@ -9859,11 +9776,6 @@ package body Exp_Ch3 is if Restriction_Active (No_Finalization) then null; - -- Finalization is not available for CIL value types - - elsif Is_Value_Type (Tag_Typ) then - null; - else if not Is_Limited_Type (Tag_Typ) then Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index b7778da158b..3463d3aae33 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -544,37 +544,30 @@ package body Exp_Ch4 is -- Step 2: Initialization actions - -- Do not set the base pool and mode of operation on .NET/JVM since - -- those targets do not support pools and all VM masters defaulted to - -- heterogeneous. - - if VM_Target = No_VM then - - -- Generate: - -- Set_Base_Pool - -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access); + -- Generate: + -- Set_Base_Pool + -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access); - Insert_And_Analyze (Decls, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (FM_Id, Loc), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc), - Attribute_Name => Name_Unrestricted_Access)))); + Insert_And_Analyze (Decls, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (FM_Id, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc), + Attribute_Name => Name_Unrestricted_Access)))); - -- Generate: - -- Set_Is_Heterogeneous (<FM_Id>); + -- Generate: + -- Set_Is_Heterogeneous (<FM_Id>); - Insert_And_Analyze (Decls, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (FM_Id, Loc)))); - end if; + Insert_And_Analyze (Decls, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (FM_Id, Loc)))); Pop_Scope; return FM_Id; @@ -762,7 +755,7 @@ package body Exp_Ch4 is begin if Ada_Version >= Ada_2005 and then Is_Class_Wide_Type (DesigT) - and then (Tagged_Type_Expansion or else VM_Target /= No_VM) + and then Tagged_Type_Expansion and then not Scope_Suppress.Suppress (Accessibility_Check) and then (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT) @@ -1079,21 +1072,6 @@ package body Exp_Ch4 is Build_Allocate_Deallocate_Proc (Temp_Decl, True); Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); - -- Attach the object to the associated finalization master. - -- This is done manually on .NET/JVM since those compilers do - -- no support pools and can't benefit from internally generated - -- Allocate / Deallocate procedures. - - if VM_Target /= No_VM - and then Is_Controlled (DesigT) - and then Present (Finalization_Master (PtrT)) - then - Insert_Action (N, - Make_Attach_Call - (Obj_Ref => New_Occurrence_Of (Temp, Loc), - Ptr_Typ => PtrT)); - end if; - else Node := Relocate_Node (N); Set_Analyzed (Node); @@ -1107,21 +1085,6 @@ package body Exp_Ch4 is Insert_Action (N, Temp_Decl); Build_Allocate_Deallocate_Proc (Temp_Decl, True); - - -- Attach the object to the associated finalization master. - -- This is done manually on .NET/JVM since those compilers do - -- no support pools and can't benefit from internally generated - -- Allocate / Deallocate procedures. - - if VM_Target /= No_VM - and then Is_Controlled (DesigT) - and then Present (Finalization_Master (PtrT)) - then - Insert_Action (N, - Make_Attach_Call - (Obj_Ref => New_Occurrence_Of (Temp, Loc), - Ptr_Typ => PtrT)); - end if; end if; -- Ada 2005 (AI-251): Handle allocators whose designated type is an @@ -1223,7 +1186,7 @@ package body Exp_Ch4 is -- Generate the tag assignment - -- Suppress the tag assignment when VM_Target because VM tags are + -- Suppress the tag assignment for VM targets because VM tags are -- represented implicitly in objects. if not Tagged_Type_Expansion then @@ -1342,21 +1305,6 @@ package body Exp_Ch4 is Build_Allocate_Deallocate_Proc (Temp_Decl, True); Convert_Aggr_In_Allocator (N, Temp_Decl, Exp); - -- Attach the object to the associated finalization master. Thisis - -- done manually on .NET/JVM since those compilers do no support - -- pools and cannot benefit from internally generated Allocate and - -- Deallocate procedures. - - if VM_Target /= No_VM - and then Is_Controlled (DesigT) - and then Present (Finalization_Master (PtrT)) - then - Insert_Action (N, - Make_Attach_Call - (Obj_Ref => New_Occurrence_Of (Temp, Loc), - Ptr_Typ => PtrT)); - end if; - Rewrite (N, New_Occurrence_Of (Temp, Loc)); Analyze_And_Resolve (N, PtrT); @@ -1529,12 +1477,10 @@ package body Exp_Ch4 is begin -- Deal first with unpacked case, where we can call a runtime routine -- except that we avoid this for targets for which are not addressable - -- by bytes, and for the JVM/CIL, since they do not support direct - -- addressing of array components. + -- by bytes. if not Is_Bit_Packed_Array (Typ1) and then Byte_Addressable - and then VM_Target = No_VM then -- The call we generate is: @@ -4322,10 +4268,9 @@ package body Exp_Ch4 is end if; -- Anonymous access-to-controlled types allocate on the global pool. - -- Do not set this attribute on .NET/JVM since those targets do not - -- support pools. Note that this is a "root type only" attribute. + -- Note that this is a "root type only" attribute. - if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then + if No (Associated_Storage_Pool (PtrT)) then if Present (Rel_Typ) then Set_Associated_Storage_Pool (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ)); @@ -4361,9 +4306,7 @@ package body Exp_Ch4 is Set_Storage_Pool (N, Pool); if Is_RTE (Pool, RE_SS_Pool) then - if VM_Target = No_VM then - Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); - end if; + Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); -- In the case of an allocator for a simple storage pool, locate -- and save a reference to the pool type's Allocate routine. @@ -4563,12 +4506,9 @@ package body Exp_Ch4 is if No_Initialization (N) then -- Even though this might be a simple allocation, create a custom - -- Allocate if the context requires it. Since .NET/JVM compilers - -- do not support pools, this step is skipped. + -- Allocate if the context requires it. - if VM_Target = No_VM - and then Present (Finalization_Master (PtrT)) - then + if Present (Finalization_Master (PtrT)) then Build_Allocate_Deallocate_Proc (N => N, Is_Allocate => True); @@ -4870,24 +4810,6 @@ package body Exp_Ch4 is Make_Init_Call (Obj_Ref => New_Copy_Tree (Init_Arg1), Typ => T)); - - -- Special processing for .NET/JVM, the allocated object is - -- attached to the finalization master. Generate: - - -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1)); - - -- Types derived from [Limited_]Controlled are the only ones - -- considered since they have fields Prev and Next. - - if VM_Target /= No_VM - and then Is_Controlled (T) - and then Present (Finalization_Master (PtrT)) - then - Insert_Action (N, - Make_Attach_Call - (Obj_Ref => New_Copy_Tree (Init_Arg1), - Ptr_Typ => PtrT)); - end if; end if; Rewrite (N, New_Occurrence_Of (Temp, Loc)); @@ -5604,11 +5526,6 @@ package body Exp_Ch4 is and then Nkind (Rop) in N_Has_Entity and then Ltyp = Entity (Rop) - -- Skip in VM mode, where we have no sense of invalid values. The - -- warning still seems relevant, but not important enough to worry. - - and then VM_Target = No_VM - -- Skip this for predicated types, where such expressions are a -- reasonable way of testing if something meets the predicate. @@ -5684,10 +5601,6 @@ package body Exp_Ch4 is -- Relevant only for source cases and then Comes_From_Source (N) - - -- Omit for VM cases, where we don't have invalid values - - and then VM_Target = No_VM then Substitute_Valid_Check; goto Leave; @@ -5845,9 +5758,9 @@ package body Exp_Ch4 is if Is_Tagged_Type (Typ) then - -- No expansion will be performed when VM_Target, as the VM + -- No expansion will be performed for VM targets, as the VM -- back-ends will handle the membership tests directly (tags - -- are not explicitly represented in Java objects, so the + -- are not explicitly represented in VM objects, so the -- normal tagged membership expansion is not what we want). if Tagged_Type_Expansion then @@ -6105,10 +6018,10 @@ package body Exp_Ch4 is Left_Opnd => Obj, Right_Opnd => Make_Null (Loc)))); - -- No expansion will be performed when VM_Target, as + -- No expansion will be performed for VM targets, as -- the VM back-ends will handle the membership tests -- directly (tags are not explicitly represented in - -- Java objects, so the normal tagged membership + -- objects, so the normal tagged membership -- expansion is not what we want). if Tagged_Type_Expansion then @@ -11449,15 +11362,6 @@ package body Exp_Ch4 is or else Chars (Comp) = Name_uTag - -- The .NET/JVM version of type Root_Controlled contains two - -- fields which should not be considered part of the object. To - -- achieve proper equiality between two controlled objects on - -- .NET/JVM, skip _Parent whenever it has type Root_Controlled. - - or else (Chars (Comp) = Name_uParent - and then VM_Target /= No_VM - and then Etype (Comp) = RTE (RE_Root_Controlled)) - -- Skip interface elements (secondary tags???) or else Is_Interface (Etype (Comp))); @@ -13255,11 +13159,6 @@ package body Exp_Ch4 is if Component_Size (Etype (Lhs)) /= System_Storage_Unit then return False; - -- Cannot do in place stuff on VM_Target since cannot pass addresses - - elsif VM_Target /= No_VM then - return False; - -- Cannot do in place stuff if non-standard Boolean representation elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 3584202a6dc..c0cd6044180 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -387,14 +387,6 @@ package body Exp_Ch5 is and then (not Is_Constrained (Etype (Lhs)) or else not Is_First_Subtype (Etype (Lhs))) - - -- In the case of compiling for the Java or .NET Virtual Machine, - -- slices are always passed by making a copy, so we don't have to - -- worry about overlap. We also want to prevent generation of "<" - -- comparisons for array addresses, since that's a meaningless - -- operation on the VM. - - and then VM_Target = No_VM then Set_Forwards_OK (N, False); Set_Backwards_OK (N, False); @@ -764,7 +756,7 @@ package body Exp_Ch5 is -- The GCC back end can deal with all cases of overlap by falling -- back to memmove if it cannot use a more efficient approach. - if VM_Target = No_VM and not AAMP_On_Target then + if not AAMP_On_Target then return; -- Assume other back ends can handle it if Forwards_OK is set @@ -937,9 +929,9 @@ package body Exp_Ch5 is -- We normally compare addresses to find out which way round to -- do the loop, since this is reliable, and handles the cases of -- parameters, conversions etc. But we can't do that in the bit - -- packed case or the VM case, because addresses don't work there. + -- packed case, because addresses don't work there. - if not Is_Bit_Packed_Array (L_Type) and then VM_Target = No_VM then + if not Is_Bit_Packed_Array (L_Type) then Condition := Make_Op_Le (Loc, Left_Opnd => @@ -2165,14 +2157,6 @@ package body Exp_Ch5 is then Make_Build_In_Place_Call_In_Assignment (N, Rhs); - elsif Is_Tagged_Type (Typ) and then Is_Value_Type (Etype (Lhs)) then - - -- Nothing to do for valuetypes - -- ??? Set_Scope_Is_Transient (False); - - Ghost_Mode := Save_Ghost_Mode; - return; - elsif Is_Tagged_Type (Typ) or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ)) then @@ -2208,7 +2192,6 @@ package body Exp_Ch5 is -- generated. or else (Is_Tagged_Type (Typ) - and then not Is_Value_Type (Etype (Lhs)) and then Chars (Current_Scope) /= Name_uAssign and then Expand_Ctrl_Actions and then @@ -4577,11 +4560,6 @@ package body Exp_Ch5 is and then not Comp_Asn and then not No_Ctrl_Actions (N) and then Tagged_Type_Expansion; - -- Tags are not saved and restored when VM_Target because VM tags are - -- represented implicitly in objects. - - Next_Id : Entity_Id; - Prev_Id : Entity_Id; Tag_Id : Entity_Id; begin @@ -4642,48 +4620,6 @@ package body Exp_Ch5 is Tag_Id := Empty; end if; - -- Save the Prev and Next fields on .NET/JVM. This is not needed on non - -- VM targets since the fields are not part of the object. - - if VM_Target /= No_VM - and then Is_Controlled (T) - then - Prev_Id := Make_Temporary (Loc, 'P'); - Next_Id := Make_Temporary (Loc, 'N'); - - -- Generate: - -- Pnn : Root_Controlled_Ptr := Root_Controlled (L).Prev; - - Append_To (Res, - Make_Object_Declaration (Loc, - Defining_Identifier => Prev_Id, - Object_Definition => - New_Occurrence_Of (RTE (RE_Root_Controlled_Ptr), Loc), - Expression => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To - (RTE (RE_Root_Controlled), New_Copy_Tree (L)), - Selector_Name => - Make_Identifier (Loc, Name_Prev)))); - - -- Generate: - -- Nnn : Root_Controlled_Ptr := Root_Controlled (L).Next; - - Append_To (Res, - Make_Object_Declaration (Loc, - Defining_Identifier => Next_Id, - Object_Definition => - New_Occurrence_Of (RTE (RE_Root_Controlled_Ptr), Loc), - Expression => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To - (RTE (RE_Root_Controlled), New_Copy_Tree (L)), - Selector_Name => - Make_Identifier (Loc, Name_Next)))); - end if; - -- If the tagged type has a full rep clause, expand the assignment into -- component-wise assignments. Mark the node as unanalyzed in order to -- generate the proper code and propagate this scenario by setting a @@ -4709,39 +4645,6 @@ package body Exp_Ch5 is Expression => New_Occurrence_Of (Tag_Id, Loc))); end if; - -- Restore the Prev and Next fields on .NET/JVM - - if VM_Target /= No_VM - and then Is_Controlled (T) - then - -- Generate: - -- Root_Controlled (L).Prev := Prev_Id; - - Append_To (Res, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To - (RTE (RE_Root_Controlled), New_Copy_Tree (L)), - Selector_Name => - Make_Identifier (Loc, Name_Prev)), - Expression => New_Occurrence_Of (Prev_Id, Loc))); - - -- Generate: - -- Root_Controlled (L).Next := Next_Id; - - Append_To (Res, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To - (RTE (RE_Root_Controlled), New_Copy_Tree (L)), - Selector_Name => Make_Identifier (Loc, Name_Next)), - Expression => New_Occurrence_Of (Next_Id, Loc))); - end if; - -- Adjust the target after the assignment when controlled (not in the -- init proc since it is an initialization more than an assignment). diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index e6efc3ab80f..c2165438bf4 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -369,11 +369,9 @@ package body Exp_Ch6 is (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); -- Pass the Storage_Pool parameter. This parameter is omitted on - -- .NET/JVM/ZFP as those targets do not support pools. + -- ZFP as those targets do not support pools. - if VM_Target = No_VM - and then RTE_Available (RE_Root_Storage_Pool_Ptr) - then + if RTE_Available (RE_Root_Storage_Pool_Ptr) then Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool); Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal)); Add_Extra_Actual_To_Call @@ -2357,7 +2355,6 @@ package body Exp_Ch6 is -- Local variables - Curr_S : constant Entity_Id := Current_Scope; Remote : constant Boolean := Is_Remote_Call (Call_Node); Actual : Node_Id; Formal : Entity_Id; @@ -2458,52 +2455,6 @@ package body Exp_Ch6 is end if; end if; - -- Detect the following code in System.Finalization_Masters only on - -- .NET/JVM targets: - - -- procedure Finalize (Master : in out Finalization_Master) is - -- begin - -- . . . - -- begin - -- Finalize (Curr_Ptr.all); - - -- Since .NET/JVM compilers lack address arithmetic and Deep_Finalize - -- cannot be named in library or user code, the compiler has to deal - -- with this by transforming the call to Finalize into Deep_Finalize. - - if VM_Target /= No_VM - and then Chars (Subp) = Name_Finalize - and then Ekind (Curr_S) = E_Block - and then Ekind (Scope (Curr_S)) = E_Procedure - and then Chars (Scope (Curr_S)) = Name_Finalize - and then Etype (First_Formal (Scope (Curr_S))) = - RTE (RE_Finalization_Master) - then - declare - Deep_Fin : constant Entity_Id := - Find_Prim_Op (RTE (RE_Root_Controlled), - TSS_Deep_Finalize); - begin - -- Since Root_Controlled is a tagged type, the compiler should - -- always generate Deep_Finalize for it. - - pragma Assert (Present (Deep_Fin)); - - -- Generate: - -- Deep_Finalize (Curr_Ptr.all); - - Rewrite (N, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Deep_Fin, Loc), - Parameter_Associations => - New_Copy_List_Tree (Parameter_Associations (N)))); - - Analyze (N); - return; - end; - end if; - -- Ada 2005 (AI-345): We have a procedure call as a triggering -- alternative in an asynchronous select or as an entry call in -- a conditional or timed select. Check whether the procedure call @@ -2952,15 +2903,6 @@ package body Exp_Ch6 is elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then null; - -- Suppress null checks when passing to access parameters of Java - -- and CIL subprograms. (Should this be done for other foreign - -- conventions as well ???) - - elsif Convention (Subp) = Convention_Java - or else Convention (Subp) = Convention_CIL - then - null; - else Install_Null_Excluding_Check (Prev); end if; @@ -3291,7 +3233,7 @@ package body Exp_Ch6 is -- extra actuals since this will be done on the re-analysis of the -- dispatching call. Note that we do not try to shorten the actual list -- for a dispatching call, it would not make sense to do so. Expansion - -- of dispatching calls is suppressed when VM_Target, because the VM + -- of dispatching calls is suppressed for VM targets, because the VM -- back-ends directly handle the generation of dispatching calls and -- would have to undo any expansion to an indirect call. @@ -4068,12 +4010,9 @@ package body Exp_Ch6 is begin pragma Assert (Is_Build_In_Place_Function (Func_Id)); - -- Processing for build-in-place object allocation. This is disabled - -- on .NET/JVM because the targets do not support pools. + -- Processing for build-in-place object allocation. - if VM_Target = No_VM - and then Needs_Finalization (Ret_Typ) - then + if Needs_Finalization (Ret_Typ) then declare Decls : constant List_Id := New_List; Fin_Mas_Id : constant Entity_Id := @@ -4667,12 +4606,10 @@ package body Exp_Ch6 is Pool_Allocator := New_Copy_Tree (Heap_Allocator); -- Do not generate the renaming of the build-in-place - -- pool parameter on .NET/JVM/ZFP because the parameter - -- is not created in the first place. + -- pool parameter on ZFP because the parameter is not + -- created in the first place. - if VM_Target = No_VM - and then RTE_Available (RE_Root_Storage_Pool_Ptr) - then + if RTE_Available (RE_Root_Storage_Pool_Ptr) then Pool_Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Pool_Id, @@ -4721,29 +4658,26 @@ package body Exp_Ch6 is Set_Comes_From_Source (Pool_Allocator, True); end if; - -- The allocator is returned on the secondary stack. We - -- don't do this on VM targets, since the SS is not used. + -- The allocator is returned on the secondary stack. - if VM_Target = No_VM then - Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); - Set_Procedure_To_Call - (SS_Allocator, RTE (RE_SS_Allocate)); - - -- The allocator is returned on the secondary stack, - -- so indicate that the function return, as well as - -- the block that encloses the allocator, must not - -- release it. The flags must be set now because - -- the decision to use the secondary stack is done - -- very late in the course of expanding the return - -- statement, past the point where these flags are - -- normally set. - - Set_Sec_Stack_Needed_For_Return (Par_Func); - Set_Sec_Stack_Needed_For_Return - (Return_Statement_Entity (N)); - Set_Uses_Sec_Stack (Par_Func); - Set_Uses_Sec_Stack (Return_Statement_Entity (N)); - end if; + Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); + Set_Procedure_To_Call + (SS_Allocator, RTE (RE_SS_Allocate)); + + -- The allocator is returned on the secondary stack, + -- so indicate that the function return, as well as + -- the block that encloses the allocator, must not + -- release it. The flags must be set now because + -- the decision to use the secondary stack is done + -- very late in the course of expanding the return + -- statement, past the point where these flags are + -- normally set. + + Set_Sec_Stack_Needed_For_Return (Par_Func); + Set_Sec_Stack_Needed_For_Return + (Return_Statement_Entity (N)); + Set_Uses_Sec_Stack (Par_Func); + Set_Uses_Sec_Stack (Return_Statement_Entity (N)); -- Create an if statement to test the BIP_Alloc_Form -- formal and initialize the access object to either the @@ -6174,13 +6108,7 @@ package body Exp_Ch6 is else Check_Restriction (No_Secondary_Stack, N); Set_Storage_Pool (N, RTE (RE_SS_Pool)); - - -- If we are generating code for the VM do not use - -- SS_Allocate since everything is heap-allocated anyway. - - if VM_Target = No_VM then - Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); - end if; + Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); end if; end if; @@ -8178,8 +8106,8 @@ package body Exp_Ch6 is begin -- We suppress the initialization of the dispatch table entry when - -- VM_Target because the dispatching mechanism is handled internally - -- by the VM. + -- not Tagged_Type_Expansion because the dispatching mechanism is + -- handled internally by the target. if Is_Dispatching_Operation (Subp) and then not Is_Abstract_Subprogram (Subp) @@ -8454,9 +8382,7 @@ package body Exp_Ch6 is -- pool, and pass the pool. Use 'Unrestricted_Access because the -- pool may not be aliased. - if VM_Target = No_VM - and then Present (Associated_Storage_Pool (Acc_Type)) - then + if Present (Associated_Storage_Pool (Acc_Type)) then Alloc_Form := User_Storage_Pool; Pool := Make_Attribute_Reference (Loc, @@ -8983,14 +8909,12 @@ package body Exp_Ch6 is -- has an unconstrained or tagged result type). if Needs_BIP_Alloc_Form (Enclosing_Func) then - if VM_Target = No_VM and then - RTE_Available (RE_Root_Storage_Pool_Ptr) - then + if RTE_Available (RE_Root_Storage_Pool_Ptr) then Pool_Actual := New_Occurrence_Of (Build_In_Place_Formal (Enclosing_Func, BIP_Storage_Pool), Loc); - -- The build-in-place pool formal is not built on .NET/JVM + -- The build-in-place pool formal is not built on e.g. ZFP else Pool_Actual := Empty; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index a45b911d1ae..cc5948195ab 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -61,7 +61,6 @@ with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Snames; use Snames; with Stand; use Stand; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; @@ -458,16 +457,13 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); - -- Create TSS primitive Finalize_Address for non-VM targets. JVM and - -- .NET do not support address arithmetic and unchecked conversions. + -- Create TSS primitive Finalize_Address. - if VM_Target = No_VM then - Set_TSS (Typ, - Make_Deep_Proc - (Prim => Address_Case, - Typ => Typ, - Stmts => Make_Deep_Array_Body (Address_Case, Typ))); - end if; + Set_TSS (Typ, + Make_Deep_Proc + (Prim => Address_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Address_Case, Typ))); end if; end Build_Array_Deep_Procs; @@ -845,13 +841,11 @@ package body Exp_Ch7 is if Restriction_Active (No_Finalization) then return; - -- Do not process C, C++, CIL and Java types since it is assumend that - -- the non-Ada side will handle their clean up. + -- Do not process C, C++ types since it is assumed that the non-Ada side + -- will handle their clean up. elsif Convention (Desig_Typ) = Convention_C - or else Convention (Desig_Typ) = Convention_CIL or else Convention (Desig_Typ) = Convention_CPP - or else Convention (Desig_Typ) = Convention_Java then return; @@ -896,13 +890,6 @@ package body Exp_Ch7 is then return; - -- For .NET/JVM targets, allow the processing of access-to-controlled - -- types where the designated type is explicitly derived from [Limited_] - -- Controlled. - - elsif VM_Target /= No_VM and then not Is_Controlled (Desig_Typ) then - return; - -- Do not create finalization masters in GNATprove mode because this -- unwanted extra expansion. A compilation in this mode keeps the tree -- as close as possible to the original sources. @@ -948,85 +935,81 @@ package body Exp_Ch7 is New_Occurrence_Of (RTE (RE_Finalization_Master), Loc))); -- Set the associated pool and primitive Finalize_Address of the new - -- finalization master. This step is skipped on .NET/JVM because the - -- target does not support storage pools or address arithmetic. + -- finalization master. - if VM_Target = No_VM then + -- The access type has a user-defined storage pool, use it - -- The access type has a user-defined storage pool, use it + if Present (Associated_Storage_Pool (Ptr_Typ)) then + Pool_Id := Associated_Storage_Pool (Ptr_Typ); - if Present (Associated_Storage_Pool (Ptr_Typ)) then - Pool_Id := Associated_Storage_Pool (Ptr_Typ); + -- Otherwise the default choice is the global storage pool - -- Otherwise the default choice is the global storage pool - - else - Pool_Id := RTE (RE_Global_Pool_Object); - Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); - end if; + else + Pool_Id := RTE (RE_Global_Pool_Object); + Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); + end if; - -- Generate: - -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access); + -- Generate: + -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access); - Append_To (Actions, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Fin_Mas_Id, Loc), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Pool_Id, Loc), - Attribute_Name => Name_Unrestricted_Access)))); + Append_To (Actions, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Fin_Mas_Id, Loc), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Pool_Id, Loc), + Attribute_Name => Name_Unrestricted_Access)))); - -- Finalize_Address is not generated in CodePeer mode because the - -- body contains address arithmetic. Skip this step. + -- Finalize_Address is not generated in CodePeer mode because the + -- body contains address arithmetic. Skip this step. - if CodePeer_Mode then - null; + if CodePeer_Mode then + null; - -- Associate the Finalize_Address primitive of the designated type - -- with the finalization master of the access type. The designated - -- type must be forzen as Finalize_Address is generated when the - -- freeze node is expanded. + -- Associate the Finalize_Address primitive of the designated type + -- with the finalization master of the access type. The designated + -- type must be forzen as Finalize_Address is generated when the + -- freeze node is expanded. - elsif Is_Frozen (Desig_Typ) - and then Present (Finalize_Address (Desig_Typ)) + elsif Is_Frozen (Desig_Typ) + and then Present (Finalize_Address (Desig_Typ)) - -- The finalization master of an anonymous access type may need - -- to be inserted in a specific place in the tree. For instance: + -- The finalization master of an anonymous access type may need + -- to be inserted in a specific place in the tree. For instance: - -- type Comp_Typ; + -- type Comp_Typ; - -- <finalization master of "access Comp_Typ"> + -- <finalization master of "access Comp_Typ"> - -- type Rec_Typ is record - -- Comp : access Comp_Typ; - -- end record; + -- type Rec_Typ is record + -- Comp : access Comp_Typ; + -- end record; - -- <freeze node for Comp_Typ> - -- <freeze node for Rec_Typ> + -- <freeze node for Comp_Typ> + -- <freeze node for Rec_Typ> - -- Due to this oddity, the anonymous access type is stored for - -- later processing (see below). + -- Due to this oddity, the anonymous access type is stored for + -- later processing (see below). - and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type - then - -- Generate: - -- Set_Finalize_Address - -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); + and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type + then + -- Generate: + -- Set_Finalize_Address + -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); - Append_To (Actions, - Make_Set_Finalize_Address_Call - (Loc => Loc, - Ptr_Typ => Ptr_Typ)); + Append_To (Actions, + Make_Set_Finalize_Address_Call + (Loc => Loc, + Ptr_Typ => Ptr_Typ)); - -- Otherwise the designated type is either anonymous access or a - -- Taft-amendment type and has not been frozen. Store the access - -- type for later processing (see Freeze_Type). + -- Otherwise the designated type is either anonymous access or a + -- Taft-amendment type and has not been frozen. Store the access + -- type for later processing (see Freeze_Type). - else - Add_Pending_Access_Type (Desig_Typ, Ptr_Typ); - end if; + else + Add_Pending_Access_Type (Desig_Typ, Ptr_Typ); end if; -- A finalization master created for an anonymous access type or an @@ -2869,10 +2852,9 @@ package body Exp_Ch7 is -- end if; -- The generated code effectively detaches the temporary from the - -- caller finalization master and deallocates the object. This is - -- disabled on .NET/JVM because pools are not supported. + -- caller finalization master and deallocates the object. - if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then + if Is_Return_Object (Obj_Id) then declare Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id); begin @@ -3261,14 +3243,10 @@ package body Exp_Ch7 is -- order to detect this scenario, save the state of entry into the -- finalization code. - -- No need to do this for VM case, since VM version of Ada.Exceptions - -- does not include routine Raise_From_Controlled_Operation which is the - -- the sole user of flag Abort. - -- This is not needed for library-level finalizers as they are called by -- the environment task and cannot be aborted. - if VM_Target = No_VM and then not For_Package then + if not For_Package then if Abort_Allowed then Data.Abort_Id := Make_Temporary (Loc, 'A'); @@ -3294,7 +3272,7 @@ package body Exp_Ch7 is Data.Abort_Id := Empty; end if; - -- .NET/JVM or library-level finalizers + -- Library-level finalizers else Data.Abort_Id := Empty; @@ -3424,16 +3402,13 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); - -- Create TSS primitive Finalize_Address for non-VM targets. JVM and - -- .NET do not support address arithmetic and unchecked conversions. + -- Create TSS primitive Finalize_Address - if VM_Target = No_VM then - Set_TSS (Typ, - Make_Deep_Proc - (Prim => Address_Case, - Typ => Typ, - Stmts => Make_Deep_Record_Body (Address_Case, Typ))); - end if; + Set_TSS (Typ, + Make_Deep_Proc + (Prim => Address_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Address_Case, Typ))); end if; end Build_Record_Deep_Procs; @@ -3930,8 +3905,7 @@ package body Exp_Ch7 is Needs_Sec_Stack_Mark : constant Boolean := Uses_Sec_Stack (Scop) and then - not Sec_Stack_Needed_For_Return (Scop) - and then VM_Target = No_VM; + not Sec_Stack_Needed_For_Return (Scop); Needs_Custom_Cleanup : constant Boolean := Nkind (N) = N_Block_Statement and then Present (Cleanup_Actions (N)); @@ -4064,9 +4038,6 @@ package body Exp_Ch7 is -- -- Mnn : constant Mark_Id := SS_Mark; - -- Suppress calls to SS_Mark and SS_Release if VM_Target, since the - -- secondary stack is never used on a VM. - if Needs_Sec_Stack_Mark then Mark := Make_Temporary (Loc, 'M'); @@ -5193,27 +5164,6 @@ package body Exp_Ch7 is end Make_Adjust_Call; ---------------------- - -- Make_Attach_Call -- - ---------------------- - - function Make_Attach_Call - (Obj_Ref : Node_Id; - Ptr_Typ : Entity_Id) return Node_Id - is - pragma Assert (VM_Target /= No_VM); - - Loc : constant Source_Ptr := Sloc (Obj_Ref); - begin - return - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Attach), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc), - Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref))); - end Make_Attach_Call; - - ---------------------- -- Make_Detach_Call -- ---------------------- @@ -7928,8 +7878,7 @@ package body Exp_Ch7 is begin -- Case where only secondary stack use is involved - if VM_Target = No_VM - and then Uses_Sec_Stack (Current_Scope) + if Uses_Sec_Stack (Current_Scope) and then Nkind (Action) /= N_Simple_Return_Statement and then Nkind (Par) /= N_Exception_Handler then @@ -8144,8 +8093,7 @@ package body Exp_Ch7 is (N => N, Clean => True, Manage_SS => - VM_Target = No_VM - and then Uses_Sec_Stack (Curr_S) + Uses_Sec_Stack (Curr_S) and then Nkind (N) = N_Object_Declaration and then Ekind_In (Encl_S, E_Package, E_Package_Body) and then Is_Library_Level_Entity (Encl_S)); @@ -8157,10 +8105,9 @@ package body Exp_Ch7 is Transfer_Entities (Curr_S, Encl_S); -- Mark the enclosing dynamic scope to ensure that the secondary stack - -- is properly released upon exiting the said scope. This is not needed - -- for .NET/JVM as those do not support the secondary stack. + -- is properly released upon exiting the said scope. - if VM_Target = No_VM and then Uses_Sec_Stack (Curr_S) then + if Uses_Sec_Stack (Curr_S) then Curr_S := Enclosing_Dynamic_Scope (Curr_S); -- Do not mark a function that returns on the secondary stack as the diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 0fcc0458615..eac45dc0b63 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -169,18 +169,6 @@ package Exp_Ch7 is -- adjusted. Typ is the expected type of Obj_Ref. When Skip_Self is set, -- only the components (if any) are adjusted. - function Make_Attach_Call - (Obj_Ref : Node_Id; - Ptr_Typ : Entity_Id) return Node_Id; - -- Create a call to prepend an object to a finalization collection. Obj_Ref - -- is the object, Ptr_Typ is the access type that owns the collection. This - -- is used only for .NET/JVM, that is, when VM_Target /= No_VM. - -- Generate the following: - -- - -- Ada.Finalization.Heap_Management.Attach - -- (<Ptr_Typ>FC, - -- System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref)); - function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id; -- Create a call to unhook an object from an arbitrary list. Obj_Ref is the -- object. Generate the following: diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 72b83440c20..4c6962cddb5 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -4780,26 +4780,6 @@ package body Exp_Ch9 is Prefix => New_Occurrence_Of (Defining_Identifier (N_Node), Loc))); - -- If it is a VM_By_Copy_Actual, copy it to a new variable - - elsif Is_VM_By_Copy_Actual (Actual) then - N_Node := - Make_Object_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'J'), - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (Etype (Formal), Loc), - Expression => New_Copy_Tree (Actual)); - Set_Assignment_OK (N_Node); - - Append (N_Node, Decls); - - Append_To (Plist, - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Unchecked_Access, - Prefix => - New_Occurrence_Of (Defining_Identifier (N_Node), Loc))); - else -- Interface class-wide formal @@ -4950,8 +4930,7 @@ package body Exp_Ch9 is Set_Assignment_OK (Actual); while Present (Actual) loop - if (Is_By_Copy_Type (Etype (Actual)) - or else Is_VM_By_Copy_Actual (Actual)) + if Is_By_Copy_Type (Etype (Actual)) and then Ekind (Formal) /= E_In_Parameter then N_Node := @@ -7584,29 +7563,17 @@ package body Exp_Ch9 is Has_Created_Identifier => True, Is_Asynchronous_Call_Block => True); - -- For the VM call Update_Exception instead of Abort_Undefer. - -- See 4jexcept.ads for an explanation. - - if VM_Target = No_VM then - if Exception_Mechanism = Back_End_Exceptions then + if Exception_Mechanism = Back_End_Exceptions then - -- Aborts are not deferred at beginning of exception handlers - -- in ZCX. + -- Aborts are not deferred at beginning of exception handlers + -- in ZCX. - Handler_Stmt := Make_Null_Statement (Loc); + Handler_Stmt := Make_Null_Statement (Loc); - else - Handler_Stmt := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), - Parameter_Associations => No_List); - end if; else Handler_Stmt := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Update_Exception), Loc), - Parameter_Associations => New_List ( - Make_Function_Call (Loc, - Name => New_Occurrence_Of - (RTE (RE_Current_Target_Exception), Loc)))); + Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => No_List); end if; Stmts := New_List ( @@ -14218,31 +14185,17 @@ package body Exp_Ch9 is -- it's actually inside the init procedure for the record type that -- corresponds to the task type. - -- This processing is causing a crash in the .NET/JVM back ends that - -- is not yet understood, so skip it in these cases ??? - - if VM_Target = No_VM then - Set_Itype (Ref, Subp_Ptr_Typ); - Append_Freeze_Action (Task_Rec, Ref); - - Append_To (Args, - Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), - Make_Qualified_Expression (Loc, - Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Body_Proc, Loc), - Attribute_Name => Name_Unrestricted_Access)))); - - -- For the .NET/JVM cases revert to the original code below ??? + Set_Itype (Ref, Subp_Ptr_Typ); + Append_Freeze_Action (Task_Rec, Ref); - else - Append_To (Args, - Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Body_Proc, Loc), - Attribute_Name => Name_Address))); - end if; + Append_To (Args, + Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Body_Proc, Loc), + Attribute_Name => Name_Unrestricted_Access)))); end; -- Discriminants parameter. This is just the address of the task diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 1a05adb73c9..8151923d2c8 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -38,7 +38,6 @@ with Sinfo; use Sinfo; with Stand; use Stand; with Stringt; use Stringt; with Table; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Urealp; use Urealp; @@ -373,14 +372,6 @@ package body Exp_Dbug is return Empty; end if; - -- Do not output those local variables in VM case, as this does not - -- help debugging (they are just unused), and might lead to duplicated - -- local variable names. - - if VM_Target /= No_VM then - return Empty; - end if; - -- Get renamed entity and compute suffix Name_Len := 0; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 88965c71f26..d8ad4f8fd8c 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -62,7 +62,6 @@ 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; package body Exp_Disp is @@ -291,7 +290,6 @@ 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 @@ -1174,35 +1172,6 @@ package body Exp_Disp is end; 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; - - 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_Occurrence_Of (Iface_Typ, Loc), - Attribute_Name => Name_Tag)))); - end if; - - -- Just do a conversion ??? - - Rewrite (N, Unchecked_Convert_To (Etype (N), N)); - Analyze (N); - end if; - return; -- A static conversion to an interface type that is not classwide is @@ -4474,8 +4443,6 @@ package body Exp_Disp is if Has_Dispatch_Table (Typ) or else No (Access_Disp_Table (Typ)) or else Is_CPP_Class (Typ) - or else Convention (Typ) = Convention_CIL - or else Convention (Typ) = Convention_Java then Ghost_Mode := Save_Ghost_Mode; return Result; @@ -6254,537 +6221,6 @@ package body Exp_Disp is return Result; end Make_DT; - ----------------- - -- Make_VM_TSD -- - ----------------- - - function Make_VM_TSD (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Result : constant List_Id := New_List; - - function Count_Primitives (Typ : Entity_Id) return Nat; - -- Count the non-predefined primitive operations of Typ - - ---------------------- - -- Count_Primitives -- - ---------------------- - - function Count_Primitives (Typ : Entity_Id) return Nat is - Nb_Prim : Nat; - Prim_Elmt : Elmt_Id; - Prim : Entity_Id; - - begin - Nb_Prim := 0; - - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); - - if Is_Predefined_Dispatching_Operation (Prim) - or else Is_Predefined_Dispatching_Alias (Prim) - then - null; - - elsif Present (Interface_Alias (Prim)) then - null; - - else - Nb_Prim := Nb_Prim + 1; - end if; - - Next_Elmt (Prim_Elmt); - end loop; - - return Nb_Prim; - end Count_Primitives; - - -------------- - -- Make_OSD -- - -------------- - - function Make_OSD (Iface : Entity_Id) return Node_Id; - -- Generate the Object Specific Data table required to dispatch calls - -- through synchronized interfaces. Returns a node that references the - -- generated OSD object. - - function Make_OSD (Iface : Entity_Id) return Node_Id is - Nb_Prim : constant Nat := Count_Primitives (Iface); - OSD : Entity_Id; - OSD_Aggr_List : List_Id; - - begin - -- Generate - -- OSD : Ada.Tags.Object_Specific_Data (Nb_Prims) := - -- (OSD_Table => (1 => <value>, - -- ... - -- N => <value>)); - - if Nb_Prim = 0 - or else Is_Abstract_Type (Typ) - or else Is_Controlled (Typ) - or else Restriction_Active (No_Dispatching_Calls) - or else not Is_Limited_Type (Typ) - or else not Has_Interfaces (Typ) - or else not RTE_Record_Component_Available (RE_OSD_Table) - then - -- No OSD table required - - return Make_Null (Loc); - - else - OSD_Aggr_List := New_List; - - declare - Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id; - Prim : Entity_Id; - Prim_Alias : Entity_Id; - Prim_Elmt : Elmt_Id; - E : Entity_Id; - Count : Nat := 0; - Pos : Nat; - - begin - Prim_Table := (others => Empty); - Prim_Alias := Empty; - - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); - - if Present (Interface_Alias (Prim)) - and then Find_Dispatching_Type - (Interface_Alias (Prim)) = Iface - then - Prim_Alias := Interface_Alias (Prim); - E := Ultimate_Alias (Prim); - Pos := UI_To_Int (DT_Position (Prim_Alias)); - - if Present (Prim_Table (Pos)) then - pragma Assert (Prim_Table (Pos) = E); - null; - - else - Prim_Table (Pos) := E; - - Append_To (OSD_Aggr_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, - DT_Position (Prim_Alias))), - Expression => - Make_Integer_Literal (Loc, - DT_Position (Alias (Prim))))); - - Count := Count + 1; - end if; - end if; - - Next_Elmt (Prim_Elmt); - end loop; - - pragma Assert (Count = Nb_Prim); - end; - - OSD := Make_Temporary (Loc, 'I'); - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => OSD, - Aliased_Present => True, - Constant_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Nb_Prim)))), - - Expression => - Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), - Expression => - Make_Integer_Literal (Loc, Nb_Prim)), - - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_OSD_Table), Loc)), - Expression => Make_Aggregate (Loc, - Component_Associations => OSD_Aggr_List)))))); - - return - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (OSD, Loc), - Attribute_Name => Name_Unchecked_Access); - end if; - end Make_OSD; - - -- Local variables - - Nb_Prim : constant Nat := Count_Primitives (Typ); - AI : Elmt_Id; - I_Depth : Nat; - Iface_Table_Node : Node_Id; - Num_Ifaces : Nat; - TSD_Aggr_List : List_Id; - Typ_Ifaces : Elist_Id; - TSD_Tags_List : List_Id; - - Tname : constant Name_Id := Chars (Typ); - Name_SSD : constant Name_Id := - New_External_Name (Tname, 'S', Suffix_Index => -1); - Name_TSD : constant Name_Id := - New_External_Name (Tname, 'B', Suffix_Index => -1); - SSD : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_SSD); - TSD : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_TSD); - begin - -- Generate code to create the storage for the type specific data object - -- with enough space to store the tags of the ancestors plus the tags - -- of all the implemented interfaces (as described in a-tags.ads). - - -- TSD : Type_Specific_Data (I_Depth) := - -- (Idepth => I_Depth, - -- Tag_Kind => <tag_kind-value>, - -- Access_Level => Type_Access_Level (Typ), - -- Alignment => Typ'Alignment, - -- HT_Link => null, - -- Type_Is_Abstract => <<boolean-value>>, - -- Type_Is_Library_Level => <<boolean-value>>, - -- Interfaces_Table => <<access-value>> - -- SSD => SSD_Table'Address - -- Tags_Table => (0 => Typ'Tag, - -- 1 => Parent'Tag - -- ...)); - - TSD_Aggr_List := New_List; - - -- Idepth: Count ancestors to compute the inheritance depth. For private - -- extensions, always go to the full view in order to compute the real - -- inheritance depth. - - declare - Current_Typ : Entity_Id; - Parent_Typ : Entity_Id; - - begin - I_Depth := 0; - Current_Typ := Typ; - loop - Parent_Typ := Etype (Current_Typ); - - if Is_Private_Type (Parent_Typ) then - Parent_Typ := Full_View (Base_Type (Parent_Typ)); - end if; - - exit when Parent_Typ = Current_Typ; - - I_Depth := I_Depth + 1; - Current_Typ := Parent_Typ; - end loop; - end; - - -- I_Depth - - Append_To (TSD_Aggr_List, - Make_Integer_Literal (Loc, I_Depth)); - - -- Tag_Kind - - Append_To (TSD_Aggr_List, Tagged_Kind (Typ)); - - -- Access_Level - - Append_To (TSD_Aggr_List, - Make_Integer_Literal (Loc, Type_Access_Level (Typ))); - - -- Alignment - - -- For CPP types we cannot rely on the value of 'Alignment provided - -- by the backend to initialize this TSD field. Why not??? - - if Convention (Typ) = Convention_CPP - or else Is_CPP_Class (Root_Type (Typ)) - then - Append_To (TSD_Aggr_List, - Make_Integer_Literal (Loc, 0)); - else - Append_To (TSD_Aggr_List, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Alignment)); - end if; - - -- HT_Link - - Append_To (TSD_Aggr_List, - Make_Null (Loc)); - - -- Type_Is_Abstract (Ada 2012: AI05-0173) - - declare - Type_Is_Abstract : Entity_Id; - - begin - Type_Is_Abstract := - Boolean_Literals (Is_Abstract_Type (Typ)); - - Append_To (TSD_Aggr_List, - New_Occurrence_Of (Type_Is_Abstract, Loc)); - end; - - -- Type_Is_Library_Level - - declare - Type_Is_Library_Level : Entity_Id; - begin - Type_Is_Library_Level := - Boolean_Literals (Is_Library_Level_Entity (Typ)); - Append_To (TSD_Aggr_List, - New_Occurrence_Of (Type_Is_Library_Level, Loc)); - end; - - -- Interfaces_Table (required for AI-405) - - if RTE_Record_Component_Available (RE_Interfaces_Table) then - - -- Count the number of interface types implemented by Typ - - Collect_Interfaces (Typ, Typ_Ifaces); - - Num_Ifaces := 0; - AI := First_Elmt (Typ_Ifaces); - while Present (AI) loop - Num_Ifaces := Num_Ifaces + 1; - Next_Elmt (AI); - end loop; - - if Num_Ifaces = 0 then - Iface_Table_Node := Make_Null (Loc); - - -- Generate the Interface_Table object - - else - declare - TSD_Ifaces_List : constant List_Id := New_List; - Iface : Entity_Id; - ITable : Node_Id; - - begin - AI := First_Elmt (Typ_Ifaces); - while Present (AI) loop - Iface := Node (AI); - - Append_To (TSD_Ifaces_List, - Make_Aggregate (Loc, - Expressions => New_List ( - - -- Iface_Tag - - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Iface, Loc), - Attribute_Name => Name_Tag), - - -- OSD - - Make_OSD (Iface)))); - - Next_Elmt (AI); - end loop; - - ITable := Make_Temporary (Loc, 'I'); - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => ITable, - Aliased_Present => True, - Constant_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Interface_Data), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint - (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Num_Ifaces)))), - - Expression => Make_Aggregate (Loc, - Expressions => New_List ( - Make_Integer_Literal (Loc, Num_Ifaces), - Make_Aggregate (Loc, - Expressions => TSD_Ifaces_List))))); - - Iface_Table_Node := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (ITable, Loc), - Attribute_Name => Name_Unchecked_Access); - end; - end if; - - Append_To (TSD_Aggr_List, Iface_Table_Node); - end if; - - -- Generate the Select Specific Data table for synchronized types that - -- implement synchronized interfaces. The size of the table is - -- constrained by the number of non-predefined primitive operations. - - if RTE_Record_Component_Available (RE_SSD) then - if Ada_Version >= Ada_2005 - and then Has_DT (Typ) - and then Is_Concurrent_Record_Type (Typ) - and then Has_Interfaces (Typ) - and then Nb_Prim > 0 - and then not Is_Abstract_Type (Typ) - and then not Is_Controlled (Typ) - and then not Restriction_Active (No_Dispatching_Calls) - and then not Restriction_Active (No_Select_Statements) - then - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => SSD, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of ( - RTE (RE_Select_Specific_Data), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Nb_Prim)))))); - - -- This table is initialized by Make_Select_Specific_Data_Table, - -- which calls Set_Entry_Index and Set_Prim_Op_Kind. - - Append_To (TSD_Aggr_List, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (SSD, Loc), - Attribute_Name => Name_Unchecked_Access)); - else - Append_To (TSD_Aggr_List, Make_Null (Loc)); - end if; - end if; - - -- Initialize the table of ancestor tags. In case of interface types - -- this table is not needed. - - TSD_Tags_List := New_List; - - -- Fill position 0 with Typ'Tag - - Append_To (TSD_Tags_List, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Tag)); - - -- Fill the rest of the table with the tags of the ancestors - - declare - Current_Typ : Entity_Id; - Parent_Typ : Entity_Id; - Pos : Nat; - - begin - Pos := 1; - Current_Typ := Typ; - - loop - Parent_Typ := Etype (Current_Typ); - - if Is_Private_Type (Parent_Typ) then - Parent_Typ := Full_View (Base_Type (Parent_Typ)); - end if; - - exit when Parent_Typ = Current_Typ; - - Append_To (TSD_Tags_List, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Parent_Typ, Loc), - Attribute_Name => Name_Tag)); - - Pos := Pos + 1; - Current_Typ := Parent_Typ; - end loop; - - pragma Assert (Pos = I_Depth + 1); - end; - - Append_To (TSD_Aggr_List, - Make_Aggregate (Loc, - Expressions => TSD_Tags_List)); - - -- Build the TSD object - - Append_To (Result, - Make_Object_Declaration (Loc, - Defining_Identifier => TSD, - Aliased_Present => True, - Constant_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of ( - RTE (RE_Type_Specific_Data), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, I_Depth)))), - - Expression => Make_Aggregate (Loc, - Expressions => TSD_Aggr_List))); - - -- Generate: - -- Check_TSD (TSD => TSD'Unrestricted_Access); - - if Ada_Version >= Ada_2005 - and then Is_Library_Level_Entity (Typ) - and then RTE_Available (RE_Check_TSD) - and then not Duplicated_Tag_Checks_Suppressed (Typ) - then - Append_To (Result, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Check_TSD), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (TSD, Loc), - Attribute_Name => Name_Unrestricted_Access)))); - end if; - - -- Generate: - -- Register_TSD (TSD'Unrestricted_Access); - - Append_To (Result, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Register_TSD), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (TSD, Loc), - Attribute_Name => Name_Unrestricted_Access)))); - - -- Populate the two auxiliary tables used for dispatching asynchronous, - -- conditional and timed selects for synchronized types that implement - -- a limited interface. Skip this step in Ravenscar profile or when - -- general dispatching is forbidden. - - if Ada_Version >= Ada_2005 - and then Is_Concurrent_Record_Type (Typ) - and then Has_Interfaces (Typ) - and then not Restriction_Active (No_Dispatching_Calls) - and then not Restriction_Active (No_Select_Statements) - then - Append_List_To (Result, - Make_Select_Specific_Data_Table (Typ)); - end if; - - return Result; - end Make_VM_TSD; - ------------------------------------- -- Make_Select_Specific_Data_Table -- ------------------------------------- @@ -7646,7 +7082,6 @@ 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 a1cc11068eb..4ec53e127f7 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -346,10 +346,6 @@ 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/exp_intr.adb b/gcc/ada/exp_intr.adb index 8002fef8bc9..282662ba2ca 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -55,7 +55,6 @@ with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; @@ -394,7 +393,8 @@ package body Exp_Intr is Analyze_And_Resolve (N, Etype (Act_Constr)); -- Do not generate a run-time check on the built object if tag - -- checks are suppressed for the result type or VM_Target /= No_VM + -- checks are suppressed for the result type or tagged type expansion + -- is disabled. if Tag_Checks_Suppressed (Etype (Result_Typ)) or else not Tagged_Type_Expansion @@ -1072,14 +1072,6 @@ package body Exp_Intr is Exception_Handlers => New_List ( Build_Exception_Handler (Finalizer_Data))))); - -- For .NET/JVM, detach the object from the containing finalization - -- collection before finalizing it. - - if VM_Target /= No_VM and then Is_Controlled (Desig_T) then - Prepend_To (Final_Code, - Make_Detach_Call (New_Copy_Tree (Arg))); - end if; - -- If aborts are allowed, then the finalization code must be -- protected by an abort defer/undefer pair. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 4cbb20bcf02..3ac68ec3bc9 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -605,12 +605,6 @@ package body Exp_Util is elsif No_Pool_Assigned (Ptr_Typ) then return; - - -- Access-to-controlled types are not supported on .NET/JVM since - -- these targets cannot support pools and address arithmetic. - - elsif VM_Target /= No_VM then - return; end if; -- The allocation / deallocation of a controlled object must be @@ -1314,7 +1308,7 @@ package body Exp_Util is Expr := Make_Function_Call (Loc, Name => New_Occurrence_Of (Defining_Entity (Fun), Loc)); - if not In_Init_Proc and then VM_Target = No_VM then + if not In_Init_Proc then Set_Uses_Sec_Stack (Defining_Entity (Fun)); end if; end if; @@ -5309,12 +5303,6 @@ package body Exp_Util is T : constant Entity_Id := Etype (N); begin - -- Objects are never unaligned on VMs - - if VM_Target /= No_VM then - return False; - end if; - -- If renamed object, apply test to underlying object if Is_Entity_Name (N) @@ -5833,21 +5821,6 @@ package body Exp_Util is end if; end Is_Volatile_Reference; - -------------------------- - -- Is_VM_By_Copy_Actual -- - -------------------------- - - function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is - begin - return VM_Target /= No_VM - and then (Nkind (N) = N_Slice - or else - (Nkind (N) = N_Identifier - and then Present (Renamed_Object (Entity (N))) - and then Nkind (Renamed_Object (Entity (N))) = - N_Slice)); - end Is_VM_By_Copy_Actual; - -------------------- -- Kill_Dead_Code -- -------------------- @@ -6652,7 +6625,7 @@ package body Exp_Util is EQ_Typ : Entity_Id := Empty; begin - -- A class-wide equivalent type is not needed when VM_Target + -- A class-wide equivalent type is not needed on VM targets -- because the VM back-ends handle the class-wide object -- initialization itself (and doesn't need or want the -- additional intermediate type to handle the assignment). @@ -6853,13 +6826,10 @@ package body Exp_Util is if Restriction_Active (No_Finalization) then return False; - -- C++, CIL and Java types are not considered controlled. It is assumed - -- that the non-Ada side will handle their clean up. + -- C++ types are not considered controlled. It is assumed that the + -- non-Ada side will handle their clean up. - elsif Convention (T) = Convention_CIL - or else Convention (T) = Convention_CPP - or else Convention (T) = Convention_Java - then + elsif Convention (T) = Convention_CPP then return False; -- Never needs finalization if Disable_Controlled set @@ -8927,7 +8897,7 @@ package body Exp_Util is -- locate here if this node corresponds to a previous invocation of -- Remove_Side_Effects to avoid a never ending loop in the frontend. - elsif VM_Target /= No_VM + elsif not Tagged_Type_Expansion and then not Comes_From_Source (N) and then Nkind (Parent (N)) = N_Object_Renaming_Declaration and then Is_Class_Wide_Type (Typ) diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index a7b942a7569..913c71b97c5 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -719,10 +719,6 @@ package Exp_Util is -- or has Volatile_Components set. A slice of a volatile variable is -- also volatile. - function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean; - -- Returns True if we are compiling on VM targets and N is a node that - -- requires pass-by-copy in these targets. - procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False); -- N represents a node for a section of code that is known to be dead. Any -- exception handler references and warning messages relating to this code diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index b2705672cd1..4dcb037de0b 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2923,7 +2923,6 @@ package body Freeze is and then ((Has_Non_Null_Base_Init_Proc (Etype (E)) and then not No_Initialization (Declaration_Node (E)) - and then not Is_Value_Type (Etype (E)) and then not Initialization_Suppressed (Etype (E))) or else (Needs_Simple_Initialization (Etype (E)) @@ -3126,7 +3125,6 @@ package body Freeze is and then Convention (F_Type) = Convention_Ada and then not Has_Warnings_Off (F_Type) and then not Has_Size_Clause (F_Type) - and then VM_Target = No_VM then Error_Msg_N ("& is an 8-bit Ada Boolean?x?", Formal); @@ -3173,11 +3171,6 @@ package body Freeze is and then Is_Array_Type (F_Type) and then not Is_Constrained (F_Type) and then Warn_On_Export_Import - - -- Exclude VM case, since both .NET and JVM can handle - -- unconstrained arrays without a problem. - - and then VM_Target = No_VM then Error_Msg_Qual_Level := 1; @@ -3295,7 +3288,6 @@ package body Freeze is elsif Root_Type (R_Type) = Standard_Boolean and then Convention (R_Type) = Convention_Ada - and then VM_Target = No_VM and then not Has_Warnings_Off (E) and then not Has_Warnings_Off (R_Type) and then not Has_Size_Clause (R_Type) @@ -3356,11 +3348,6 @@ package body Freeze is and then not Is_Imported (E) - -- Exclude VM case, since both .NET and JVM can handle return - -- of unconstrained arrays without a problem. - - and then VM_Target = No_VM - -- Check that general warning is enabled, and that it is not -- suppressed for this particular case. @@ -5604,7 +5591,6 @@ package body Freeze is while Present (Formal) loop if Ekind (Etype (Formal)) = E_Incomplete_Type and then No (Full_View (Etype (Formal))) - and then not Is_Value_Type (Etype (Formal)) then if Is_Tagged_Type (Etype (Formal)) then null; @@ -7677,11 +7663,6 @@ package body Freeze is -- Warnings (Off) on specific entities here, probably so???) and then Warn_On_Export_Import - - -- Exclude the VM case, since return of unconstrained arrays - -- is properly handled in both the JVM and .NET cases. - - and then VM_Target = No_VM then Error_Msg_N ("?x?foreign convention function& should not return " & diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index b3c85f1f8bc..723096ccc1f 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -64,7 +64,6 @@ with Sinfo; use Sinfo; with Sinput; use Sinput; with Sinput.L; use Sinput.L; with SCIL_LL; use SCIL_LL; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Types; use Types; @@ -459,14 +458,9 @@ begin end if; end if; - -- Qualify all entity names in inner packages, package bodies, etc., - -- except when compiling for the VM back-ends, which depend on having - -- unqualified names in certain cases and handles the generation of - -- qualified names when needed. + -- Qualify all entity names in inner packages, package bodies, etc. - if VM_Target = No_VM then - Exp_Dbug.Qualify_All_Entity_Names; - end if; + Exp_Dbug.Qualify_All_Entity_Names; -- SCIL backend requirement. Check that SCIL nodes associated with -- dispatching calls reference subprogram calls. diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 662065ed0ee..6b2046ddcd9 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -599,10 +599,9 @@ procedure Gnat1drv is if Debug_Flag_Dot_LL then Back_End_Handles_Limited_Types := True; - -- If no debug flag, usage off for AAMP, VM, SCIL cases + -- If no debug flag, usage off for AAMP, SCIL cases elsif AAMP_On_Target - or else VM_Target /= No_VM or else Generate_SCIL then Back_End_Handles_Limited_Types := False; @@ -633,20 +632,16 @@ procedure Gnat1drv is -- back end some day, it would not be true for this test, but it -- would be non-GCC, so this is a bit troublesome ??? - Front_End_Inlining := VM_Target /= No_VM or else AAMP_On_Target; + Front_End_Inlining := AAMP_On_Target; end if; -- Set back end inlining indication Back_End_Inlining := - -- No back end inlining available for VM targets - - VM_Target = No_VM - -- No back end inlining available on AAMP - and then not AAMP_On_Target + not AAMP_On_Target -- No back end inlining in GNATprove mode, since it just confuses -- the formal verification process. @@ -868,7 +863,7 @@ procedure Gnat1drv is -- back end for component layout where possible) but only for non-GCC -- back ends, as this is done a priori for GCC back ends. - if VM_Target /= No_VM or else AAMP_On_Target then + if AAMP_On_Target then Sem_Ch13.Validate_Independence; end if; @@ -1273,15 +1268,11 @@ begin -- Annotation is suppressed for targets where front-end layout is -- enabled, because the front end determines representations. - -- Annotation is also suppressed in the case of compiling for a VM, - -- since representations are largely symbolic there. - if Back_End_Mode = Declarations_Only and then (not (Back_Annotate_Rep_Info or Generate_SCIL or GNATprove_Mode) or else Main_Kind = N_Subunit - or else Frontend_Layout_On_Target - or else VM_Target /= No_VM) + or else Frontend_Layout_On_Target) then Post_Compilation_Validation_Checks; Errout.Finalize (Last_Call => True); diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 190aadfb206..c90397de880 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2015, 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- -- @@ -1601,12 +1601,6 @@ begin Osint.Add_Default_Search_Dirs; Targparm.Get_Target_Parameters; - case VM_Target is - when JVM_Target => Gcc := new String'("jvm-gnatcompile"); - when CLI_Target => Gcc := new String'("dotnet-gnatcompile"); - when No_VM => null; - end case; - -- Compile the bind file with the following switches: -- -gnatA stops reading gnat.adc, since we don't know what @@ -1651,15 +1645,7 @@ begin end if; if Linker_Path = null then - if VM_Target = CLI_Target then - Linker_Path := System.OS_Lib.Locate_Exec_On_Path ("dotnet-ld"); - - if Linker_Path = null then - Exit_With_Error ("Couldn't locate dotnet-ld"); - end if; - else - Linker_Path := Gcc_Path; - end if; + Linker_Path := Gcc_Path; end if; Write_Header; @@ -1986,7 +1972,7 @@ begin J := J + 1; end loop; - if Linker_Path = Gcc_Path and then VM_Target = No_VM then + if Linker_Path = Gcc_Path then -- For systems where the default is to link statically with -- libgcc, if gcc is not called with -shared-libgcc, call it @@ -2091,10 +2077,7 @@ begin Delete (Binder_Ali_File.all & ASCII.NUL); Delete (Binder_Spec_Src_File.all & ASCII.NUL); Delete (Binder_Body_Src_File.all & ASCII.NUL); - - if VM_Target = No_VM then - Delete (Binder_Obj_File.all & ASCII.NUL); - end if; + Delete (Binder_Obj_File.all & ASCII.NUL); end if; Exit_Program (E_Success); diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 5a3dcc4d155..dfa1a5bc757 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -454,16 +454,7 @@ package body Lib.Writ is not Has_No_Elaboration_Code (Parent (Declaration_Node (Body_Entity (Uent)))))) then - if Convention (Uent) = Convention_CIL then - - -- Special case for generic CIL packages which never have - -- elaboration code - - Write_Info_Str (" NE"); - - else - Write_Info_Str (" EE"); - end if; + Write_Info_Str (" EE"); end if; if Has_No_Elaboration_Code (Unode) then diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index d3324e70c79..67e44e0d245 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -671,12 +671,7 @@ package body Make is -- Compiler, Binder & Linker Data and Subprograms -- ---------------------------------------------------- - Gcc : String_Access := Program_Name ("gcc", "gnatmake"); - Original_Gcc : constant String_Access := Gcc; - -- Original_Gcc is used to check if Gcc has been modified by a switch - -- --GCC=, so that for VM platforms, it is not modified again, as it can - -- result in incorrect error messages if the compiler cannot be found. - + Gcc : String_Access := Program_Name ("gcc", "gnatmake"); Gnatbind : String_Access := Program_Name ("gnatbind", "gnatmake"); Gnatlink : String_Access := Program_Name ("gnatlink", "gnatmake"); -- Default compiler, binder, linker programs @@ -4861,12 +4856,10 @@ package body Make is end if; -- If the objects were up-to-date check if the executable file is also - -- up-to-date. For now always bind and link on the JVM since there is - -- currently no simple way to check whether objects are up to date wrt - -- the executable. Same in CodePeer mode where there is no executable. + -- up-to-date. For now always bind and link in CodePeer mode where there + -- is no executable. - if Targparm.VM_Target /= JVM_Target - and then not CodePeer_Mode + if not CodePeer_Mode and then First_Compiled_File = No_File then Executable_Stamp := File_Stamp (Executable); @@ -5812,8 +5805,8 @@ package body Make is Finish_Program (Project_Tree, E_Success); else - -- Call Get_Target_Parameters to ensure that VM_Target and - -- AAMP_On_Target get set before calling Usage. + -- Call Get_Target_Parameters to ensure that AAMP_On_Target gets + -- set before calling Usage. Targparm.Get_Target_Parameters; @@ -6027,39 +6020,6 @@ package body Make is Make_Failed ("*** make failed."); end; - -- Special processing for VM targets - - if Targparm.VM_Target /= No_VM then - - -- Set proper processing commands - - case Targparm.VM_Target is - when Targparm.JVM_Target => - - -- Do not check for an object file (".o") when compiling - -- to JVM machine since ".class" files are generated - -- instead. - - Check_Object_Consistency := False; - - -- Do not modify Gcc is --GCC= was specified - - if Gcc = Original_Gcc then - Gcc := new String'("jvm-gnatcompile"); - end if; - - when Targparm.CLI_Target => - -- Do not modify Gcc is --GCC= was specified - - if Gcc = Original_Gcc then - Gcc := new String'("dotnet-gnatcompile"); - end if; - - when Targparm.No_VM => - raise Program_Error; - end case; - end if; - Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all); Gnatbind_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all); Gnatlink_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all); diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 825929afa42..645c8f0015a 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1302,7 +1302,6 @@ begin Pragma_Check_Float_Overflow | Pragma_Check_Name | Pragma_Check_Policy | - Pragma_CIL_Constructor | Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning | Pragma_Contract_Cases | @@ -1376,8 +1375,6 @@ begin Pragma_Interrupt_State | Pragma_Interrupt_Priority | Pragma_Invariant | - Pragma_Java_Constructor | - Pragma_Java_Interface | Pragma_Keep_Names | Pragma_License | Pragma_Link_With | diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 3915c30e7ed..51b8b67d983 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2015, 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- -- @@ -726,16 +726,12 @@ package body Repinfo is Write_Line ("Assembler"); when Convention_C => Write_Line ("C"); - when Convention_CIL => - Write_Line ("CIL"); when Convention_COBOL => Write_Line ("COBOL"); when Convention_CPP => Write_Line ("C++"); when Convention_Fortran => Write_Line ("Fortran"); - when Convention_Java => - Write_Line ("Java"); when Convention_Stdcall => Write_Line ("Stdcall"); when Convention_Stubbed => diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index bc4674a6052..af2b6757875 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -550,7 +550,6 @@ package Rtsfind is RE_Set_Deadline, -- Ada.Dispatching.EDF RE_Code_Loc, -- Ada.Exceptions - RE_Current_Target_Exception, -- Ada.Exceptions (JGNAT use only) RE_Exception_Id, -- Ada.Exceptions RE_Exception_Identity, -- Ada.Exceptions RE_Exception_Information, -- Ada.Exceptions @@ -1596,7 +1595,6 @@ package Rtsfind is RE_Get_Current_Excep, -- System.Soft_Links RE_Get_GNAT_Exception, -- System.Soft_Links RE_Save_Library_Occurrence, -- System.Soft_Links - RE_Update_Exception, -- System.Soft_Links RE_Bits_1, -- System.Unsigned_Types RE_Bits_2, -- System.Unsigned_Types @@ -1783,7 +1781,6 @@ package Rtsfind is RE_Set_Deadline => Ada_Dispatching_EDF, RE_Code_Loc => Ada_Exceptions, - RE_Current_Target_Exception => Ada_Exceptions, -- of JGNAT RE_Exception_Id => Ada_Exceptions, RE_Exception_Identity => Ada_Exceptions, RE_Exception_Information => Ada_Exceptions, @@ -2833,7 +2830,6 @@ package Rtsfind is RE_Get_Current_Excep => System_Soft_Links, RE_Get_GNAT_Exception => System_Soft_Links, RE_Save_Library_Occurrence => System_Soft_Links, - RE_Update_Exception => System_Soft_Links, RE_Bits_1 => System_Unsigned_Types, RE_Bits_2 => System_Unsigned_Types, diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb index 2bbc2aa0b36..b3efac83c47 100644 --- a/gcc/ada/s-soflin.adb +++ b/gcc/ada/s-soflin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -303,13 +303,4 @@ package body System.Soft_Links is null; end Task_Unlock_NT; - ------------------------- - -- Update_Exception_NT -- - ------------------------- - - procedure Update_Exception_NT (X : EO := Current_Target_Exception) is - begin - Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X); - end Update_Exception_NT; - end System.Soft_Links; diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads index f850cd2ffb0..cba89366014 100644 --- a/gcc/ada/s-soflin.ads +++ b/gcc/ada/s-soflin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -143,12 +143,6 @@ package System.Soft_Links is -- Handle task abort (non-tasking case, does nothing). Currently, no port -- makes use of this, but we retain the interface for possible future use. - procedure Update_Exception_NT (X : EO := Current_Target_Exception); - -- Handle exception setting. This routine is provided for targets that - -- have built-in exception handling such as the Java Virtual Machine. - -- Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on - -- how this routine is used. - function Check_Abort_Status_NT return Integer; -- Returns Boolean'Pos (True) iff abort signal should raise -- Standard'Abort_Signal. @@ -177,9 +171,6 @@ package System.Soft_Links is Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access; -- Handle task abort (task/non-task case as appropriate) - Update_Exception : Special_EO_Call := Update_Exception_NT'Access; - -- Handle exception setting and tasking polling when appropriate - Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access; -- Called when Abort_Signal is delivered to the process. Checks to -- see if signal should result in raising Standard'Abort_Signal. diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index 871ab5abcce..dddad762e34 100644 --- a/gcc/ada/s-tasini.adb +++ b/gcc/ada/s-tasini.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -58,7 +58,6 @@ package body System.Tasking.Initialization is package STPO renames System.Task_Primitives.Operations; package SSL renames System.Soft_Links; - package AE renames Ada.Exceptions; use Parameters; use Task_Primitives.Operations; @@ -94,10 +93,6 @@ package body System.Tasking.Initialization is function Get_Current_Excep return SSL.EOA; -- Task-safe version of SSL.Get_Current_Excep - procedure Update_Exception - (X : AE.Exception_Occurrence := SSL.Current_Target_Exception); - -- Handle exception setting and check for pending actions - function Task_Name return String; -- Returns current task's name @@ -371,7 +366,6 @@ package body System.Tasking.Initialization is SSL.Unlock_Task := Task_Unlock'Access; SSL.Check_Abort_Status := Check_Abort_Status'Access; SSL.Task_Name := Task_Name'Access; - SSL.Update_Exception := Update_Exception'Access; SSL.Get_Current_Excep := Get_Current_Excep'Access; -- Initialize the tasking soft links (if not done yet) that are common @@ -709,50 +703,6 @@ package body System.Tasking.Initialization is end if; end Abort_Undefer; - ---------------------- - -- Update_Exception -- - ---------------------- - - -- Call only when holding no locks - - procedure Update_Exception - (X : AE.Exception_Occurrence := SSL.Current_Target_Exception) - is - Self_Id : constant Task_Id := Self; - use Ada.Exceptions; - - begin - Save_Occurrence (Self_Id.Common.Compiler_Data.Current_Excep, X); - - if Self_Id.Deferral_Level = 0 then - if Self_Id.Pending_Action then - Self_Id.Pending_Action := False; - Self_Id.Deferral_Level := Self_Id.Deferral_Level + 1; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_Id); - Self_Id.Pending_Action := False; - Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Self_Id.Deferral_Level := Self_Id.Deferral_Level - 1; - - if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then - if not Self_Id.Aborting then - Self_Id.Aborting := True; - raise Standard'Abort_Signal; - end if; - end if; - end if; - end if; - end Update_Exception; - -------------------------- -- Wakeup_Entry_Caller -- -------------------------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index f05ad7fdb79..71df079f69c 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4924,49 +4924,36 @@ package body Sem_Ch13 is -- will be used to represent the biased subtype that reflects -- the biased representation of components. We need the subtype -- to get proper conversions on referencing elements of the - -- array. Note: component size clauses are ignored in VM mode. - - if VM_Target = No_VM then - if Biased then - New_Ctyp := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name (Chars (U_Ent), 'C', 0, 'T')); - - Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => New_Ctyp, - Subtype_Indication => - New_Occurrence_Of (Component_Type (Btype), Loc)); - - Set_Parent (Decl, N); - Analyze (Decl, Suppress => All_Checks); - - Set_Has_Delayed_Freeze (New_Ctyp, False); - Set_Esize (New_Ctyp, Csize); - Set_RM_Size (New_Ctyp, Csize); - Init_Alignment (New_Ctyp); - Set_Is_Itype (New_Ctyp, True); - Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); - - Set_Component_Type (Btype, New_Ctyp); - Set_Biased (New_Ctyp, N, "component size clause"); - end if; + -- array. - Set_Component_Size (Btype, Csize); + if Biased then + New_Ctyp := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (U_Ent), 'C', 0, 'T')); - -- For VM case, we ignore component size clauses + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => New_Ctyp, + Subtype_Indication => + New_Occurrence_Of (Component_Type (Btype), Loc)); - else - -- Give a warning unless we are in GNAT mode, in which case - -- the warning is suppressed since it is not useful. + Set_Parent (Decl, N); + Analyze (Decl, Suppress => All_Checks); - if not GNAT_Mode then - Error_Msg_N - ("component size ignored in this configuration??", N); - end if; + Set_Has_Delayed_Freeze (New_Ctyp, False); + Set_Esize (New_Ctyp, Csize); + Set_RM_Size (New_Ctyp, Csize); + Init_Alignment (New_Ctyp); + Set_Is_Itype (New_Ctyp, True); + Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); + + Set_Component_Type (Btype, New_Ctyp); + Set_Biased (New_Ctyp, N, "component size clause"); end if; + Set_Component_Size (Btype, Csize); + -- Deal with warning on overridden size if Warn_On_Overridden_Size @@ -5142,12 +5129,6 @@ package body Sem_Ch13 is ("static string required for tag name!", Nam); end if; - if VM_Target /= No_VM then - Error_Msg_Name_1 := Attr; - Error_Msg_N - ("% attribute unsupported in this configuration", Nam); - end if; - if not Is_Library_Level_Entity (U_Ent) then Error_Msg_NE ("??non-unique external tag supplied for &", N, U_Ent); @@ -5463,16 +5444,6 @@ package body Sem_Ch13 is ("size cannot be given for unconstrained array", Nam); elsif Size /= No_Uint then - if VM_Target /= No_VM and then not GNAT_Mode then - - -- Size clause is not handled properly on VM targets. - -- Display a warning unless we are in GNAT mode, in which - -- case this is useless. - - Error_Msg_N - ("size clauses are ignored in this configuration??", N); - end if; - if Is_Type (U_Ent) then Etyp := U_Ent; else @@ -11356,7 +11327,7 @@ package body Sem_Ch13 is Address_Clause_Checks.Init; Unchecked_Conversions.Init; - if VM_Target /= No_VM or else AAMP_On_Target then + if AAMP_On_Target then Independence_Checks.Init; end if; end Initialize; @@ -12412,17 +12383,7 @@ package body Sem_Ch13 is and then Known_Component_Size (T2) and then Component_Size (T1) = Component_Size (T2) then - if VM_Target = No_VM then - return True; - - -- In VM targets the representation of arrays with aliased - -- components differs from arrays with non-aliased components - - else - return Has_Aliased_Components (Base_Type (T1)) - = - Has_Aliased_Components (Base_Type (T2)); - end if; + return True; end if; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9fec59564bf..fc85a5abfb8 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3002,10 +3002,9 @@ package body Sem_Ch3 is -- Check runtime support for synchronized interfaces - if VM_Target = No_VM - and then (Is_Task_Interface (T) - or else Is_Protected_Interface (T) - or else Is_Synchronized_Interface (T)) + if (Is_Task_Interface (T) + or else Is_Protected_Interface (T) + or else Is_Synchronized_Interface (T)) and then not RTE_Available (RE_Select_Specific_Data) then Error_Msg_CRT ("synchronized interfaces", T); @@ -10061,7 +10060,6 @@ package body Sem_Ch3 is and then not Is_TSS (Subp, TSS_Stream_Input) and then not Is_TSS (Subp, TSS_Stream_Output) and then not Is_Abstract_Type (T) - and then Convention (T) /= Convention_CIL and then not Is_Predefined_Interface_Primitive (Subp) -- Ada 2005 (AI-251): Do not consider hidden entities associated diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index aaa1fcd1453..d2d5f25f3f3 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -473,7 +473,6 @@ package body Sem_Ch5 is elsif Is_Limited_Type (T1) and then not Assignment_OK (Lhs) and then not Assignment_OK (Original_Node (Lhs)) - and then not Is_Value_Type (T1) then -- CPP constructors can only be called in declarations diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 4ae437ec76d..e942477d3d1 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -83,7 +83,6 @@ with Snames; use Snames; with Stringt; use Stringt; with Style; with Stylesw; use Stylesw; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; @@ -2036,11 +2035,6 @@ package body Sem_Ch6 is end if; if Ekind (Typ) = E_Incomplete_Type - and then Is_Value_Type (Typ) - then - null; - - elsif Ekind (Typ) = E_Incomplete_Type or else (Is_Class_Wide_Type (Typ) and then Ekind (Root_Type (Typ)) = E_Incomplete_Type) then @@ -6931,11 +6925,9 @@ package body Sem_Ch6 is -- Add BIP_Storage_Pool, in case BIP_Alloc_Form indicates to -- use a user-defined pool. This formal is not added on - -- .NET/JVM/ZFP as those targets do not support pools. + -- ZFP as those targets do not support pools. - if VM_Target = No_VM - and then RTE_Available (RE_Root_Storage_Pool_Ptr) - then + if RTE_Available (RE_Root_Storage_Pool_Ptr) then Discard := Add_Extra_Formal (E, RTE (RE_Root_Storage_Pool_Ptr), @@ -10077,11 +10069,6 @@ package body Sem_Ch6 is end if; end if; - -- Special handling of Value_Type for CIL case - - elsif Is_Value_Type (Formal_Type) then - null; - elsif not Nkind_In (Parent (T), N_Access_Function_Definition, N_Access_Procedure_Definition) then diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index a12649e0cf1..b2c6d821d51 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -68,7 +68,6 @@ with Sinfo.CN; use Sinfo.CN; with Snames; use Snames; with Style; use Style; with Table; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -3909,15 +3908,14 @@ package body Sem_Ch8 is -- type is still not frozen). We exclude from this processing generic -- formal subprograms found in instantiations. - -- We must exclude VM targets and restricted run-time libraries because + -- We must exclude restricted run-time libraries because -- entity AST_Handler is defined in package System.Aux_Dec which is not -- available in those platforms. Note that we cannot use the function -- Restricted_Profile (instead of Configurable_Run_Time_Mode) because -- the ZFP run-time library is not defined as a profile, and we do not -- want to deal with AST_Handler in ZFP mode. - if VM_Target = No_VM - and then not Configurable_Run_Time_Mode + if not Configurable_Run_Time_Mode and then not Present (Corresponding_Formal_Spec (N)) and then Etype (Nam) /= RTE (RE_AST_Handler) then @@ -5606,8 +5604,6 @@ package body Sem_Ch8 is end case; end if; end if; - - Check_Nested_Access (E); end if; Set_Entity_Or_Discriminal (N, E); @@ -6602,13 +6598,9 @@ package body Sem_Ch8 is -- Do not build the subtype when referencing components of -- dispatch table wrappers. Required to avoid generating - -- elaboration code with HI runtimes. JVM and .NET use a - -- modified version of Ada.Tags which does not contain RE_ - -- Dispatch_Table_Wrapper and RE_No_Dispatch_Table_Wrapper. - -- Avoid raising RE_Not_Available exception in those cases. + -- elaboration code with HI runtimes. - elsif VM_Target = No_VM - and then RTU_Loaded (Ada_Tags) + elsif RTU_Loaded (Ada_Tags) and then ((RTE_Available (RE_Dispatch_Table_Wrapper) and then Scope (Selector) = diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index ff112317080..35877e530e1 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -57,7 +57,6 @@ with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; with Style; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -2367,12 +2366,6 @@ package body Sem_Ch9 is Generate_Reference (Entry_Id, Entry_Name); if Present (First_Formal (Entry_Id)) then - if VM_Target = JVM_Target then - Error_Msg_N - ("arguments unsupported in requeue statement", - First_Formal (Entry_Id)); - return; - end if; -- Ada 2012 (AI05-0030): Perform type conformance after skipping -- the first parameter of Entry_Id since it is the interface diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index d61976e7cbe..74a315dd3f2 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -50,7 +50,6 @@ 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; @@ -1148,7 +1147,7 @@ package body Sem_Disp is -- No code required to register primitives in VM -- targets - elsif VM_Target /= No_VM then + elsif not Tagged_Type_Expansion then null; else @@ -1309,7 +1308,7 @@ package body Sem_Disp is 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 + and then Tagged_Type_Expansion then Insert_Actions_After (Subp_Body, Register_Primitive (Sloc (Subp_Body), Prim => Prim)); @@ -2546,7 +2545,7 @@ package body Sem_Disp is Next_Actual (Arg); end loop; - -- Expansion of dispatching calls is suppressed when VM_Target, because + -- Expansion of dispatching calls is suppressed on VM targets, because -- the VM back-ends directly handle the generation of dispatching calls -- and would have to undo any expansion to an indirect call. diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index d8a4f3e4cca..9f97836477c 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -52,7 +52,6 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with Targparm; use Targparm; with Tbuild; use Tbuild; package body Sem_Eval is @@ -6238,12 +6237,6 @@ package body Sem_Eval is and then Is_Known_Valid (Typ) and then Esize (Etype (N)) <= Esize (Typ) and then not Has_Biased_Representation (Etype (N)) - - -- This check cannot be disabled under VM targets because in some - -- unusual cases the backend of the native compiler raises a run-time - -- exception but the virtual machines do not raise any exception. - - and then VM_Target = No_VM then return In_Range; diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb index 2347bff46a0..cfe9f9536c1 100644 --- a/gcc/ada/sem_mech.adb +++ b/gcc/ada/sem_mech.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2015, 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- -- @@ -181,13 +181,11 @@ package body Sem_Mech is -- C -- ------- - -- Note: Assembler, C++, Java, Stdcall also use C conventions + -- Note: Assembler, C++, Stdcall also use C conventions when Convention_Assembler | Convention_C | - Convention_CIL | Convention_CPP | - Convention_Java | Convention_Stdcall => -- The following values are passed by copy diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 690856163b6..94eac815bdb 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -7738,21 +7738,6 @@ package body Sem_Prag is end if; end loop; - -- When the convention is Java or CIL, we also allow Import to - -- be given for packages, generic packages, exceptions, record - -- components, and access to subprograms. - - elsif (C = Convention_Java or else C = Convention_CIL) - and then - (Is_Package_Or_Generic_Package (Def_Id) - or else Ekind (Def_Id) = E_Exception - or else Ekind (Def_Id) = E_Access_Subprogram_Type - or else Nkind (Parent (Def_Id)) = N_Component_Declaration) - then - Set_Imported (Def_Id); - Set_Is_Public (Def_Id); - Process_Interface_Name (Def_Id, Arg3, Arg4); - -- Import a CPP class elsif C = Convention_CPP @@ -8254,23 +8239,17 @@ package body Sem_Prag is Link_Nam : Node_Id; String_Val : String_Id; - procedure Check_Form_Of_Interface_Name - (SN : Node_Id; - Ext_Name_Case : Boolean); + procedure Check_Form_Of_Interface_Name (SN : Node_Id); -- SN is a string literal node for an interface name. This routine -- performs some minimal checks that the name is reasonable. In -- particular that no spaces or other obviously incorrect characters -- appear. This is only a warning, since any characters are allowed. - -- Ext_Name_Case is True for an External_Name, False for a Link_Name. ---------------------------------- -- Check_Form_Of_Interface_Name -- ---------------------------------- - procedure Check_Form_Of_Interface_Name - (SN : Node_Id; - Ext_Name_Case : Boolean) - is + procedure Check_Form_Of_Interface_Name (SN : Node_Id) is S : constant String_Id := Strval (Expr_Value_S (SN)); SL : constant Nat := String_Length (S); C : Char_Code; @@ -8288,21 +8267,12 @@ package body Sem_Prag is if not In_Character_Range (C) - -- For all cases except CLI target, - -- commas, spaces and slashes are dubious (in CLI, we use - -- commas and backslashes in external names to specify - -- assembly version and public key, while slashes and spaces - -- can be used in names to mark nested classes and - -- valuetypes). - - or else ((not Ext_Name_Case or else VM_Target /= CLI_Target) - and then (Get_Character (C) = ',' - or else - Get_Character (C) = '\')) - or else (VM_Target /= CLI_Target - and then (Get_Character (C) = ' ' - or else - Get_Character (C) = '/')) + -- Commas, spaces and (back)slashes are dubious + + or else Get_Character (C) = ',' + or else Get_Character (C) = '\' + or else Get_Character (C) = ' ' + or else Get_Character (C) = '/' then Error_Msg ("??interface name contains illegal character", @@ -8316,18 +8286,6 @@ package body Sem_Prag is begin if No (Link_Arg) then if No (Ext_Arg) then - if VM_Target = CLI_Target - and then Ekind (Subprogram_Def) = E_Package - and then Nkind (Parent (Subprogram_Def)) = - N_Package_Specification - and then Present (Generic_Parent (Parent (Subprogram_Def))) - then - Set_Interface_Name - (Subprogram_Def, - Interface_Name - (Generic_Parent (Parent (Subprogram_Def)))); - end if; - return; elsif Chars (Ext_Arg) = Name_Link_Name then @@ -8351,7 +8309,7 @@ package body Sem_Prag is if Present (Ext_Nam) then Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String); - Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True); + Check_Form_Of_Interface_Name (Ext_Nam); -- Verify that external name is not the name of a local entity, -- which would hide the imported one and could lead to run-time @@ -8396,7 +8354,7 @@ package body Sem_Prag is if Present (Link_Nam) then Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String); - Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False); + Check_Form_Of_Interface_Name (Link_Nam); end if; -- If there is no link name, just set the external name @@ -8412,11 +8370,7 @@ package body Sem_Prag is else Start_String; - - if VM_Target = No_VM then - Store_String_Char (Get_Char_Code ('*')); - end if; - + Store_String_Char (Get_Char_Code ('*')); String_Val := Strval (Expr_Value_S (Link_Nam)); Store_String_Chars (String_Val); Link_Nam := @@ -8435,16 +8389,7 @@ package body Sem_Prag is (Get_Base_Subprogram (Subprogram_Def), Link_Nam); end if; - -- We allow duplicated export names in CIL/Java, as they are always - -- enclosed in a namespace that differentiates them, and overloaded - -- entities are supported by the VM. - - if Convention (Subprogram_Def) /= Convention_CIL - and then - Convention (Subprogram_Def) /= Convention_Java - then - Check_Duplicated_Export_Name (Link_Nam); - end if; + Check_Duplicated_Export_Name (Link_Nam); end Process_Interface_Name; ----------------------------------------- @@ -9012,7 +8957,7 @@ package body Sem_Prag is begin -- For GCC back ends the validation is done a priori - if VM_Target = No_VM and then not AAMP_On_Target then + if not AAMP_On_Target then return; end if; @@ -11936,14 +11881,6 @@ package body Sem_Prag is end if; end Check_Policy; - --------------------- - -- CIL_Constructor -- - --------------------- - - -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME); - - -- Processing for this pragma is shared with Java_Constructor - ------------- -- Comment -- ------------- @@ -15774,328 +15711,6 @@ package body Sem_Prag is end if; end Invariant; - ---------------------- - -- Java_Constructor -- - ---------------------- - - -- pragma Java_Constructor ([Entity =>] LOCAL_NAME); - - -- Also handles pragma CIL_Constructor - - when Pragma_CIL_Constructor | Pragma_Java_Constructor => - Java_Constructor : declare - Convention : Convention_Id; - Def_Id : Entity_Id; - Hom_Id : Entity_Id; - Id : Entity_Id; - This_Formal : Entity_Id; - - begin - GNAT_Pragma; - Check_Arg_Count (1); - Check_Optional_Identifier (Arg1, Name_Entity); - Check_Arg_Is_Local_Name (Arg1); - - Id := Get_Pragma_Arg (Arg1); - Find_Program_Unit_Name (Id); - - -- If we did not find the name, we are done - - if Etype (Id) = Any_Type then - return; - end if; - - -- Check wrong use of pragma in wrong VM target - - if VM_Target = No_VM then - return; - - elsif VM_Target = CLI_Target - and then Prag_Id = Pragma_Java_Constructor - then - Error_Pragma ("must use pragma 'C'I'L_'Constructor"); - - elsif VM_Target = JVM_Target - and then Prag_Id = Pragma_CIL_Constructor - then - Error_Pragma ("must use pragma 'Java_'Constructor"); - end if; - - case Prag_Id is - when Pragma_CIL_Constructor => Convention := Convention_CIL; - when Pragma_Java_Constructor => Convention := Convention_Java; - when others => null; - end case; - - Hom_Id := Entity (Id); - - -- Loop through homonyms - - loop - Def_Id := Get_Base_Subprogram (Hom_Id); - - -- The constructor is required to be a function - - if Ekind (Def_Id) /= E_Function then - if VM_Target = JVM_Target then - Error_Pragma_Arg - ("pragma% requires function returning a 'Java access " - & "type", Def_Id); - else - Error_Pragma_Arg - ("pragma% requires function returning a 'C'I'L access " - & "type", Def_Id); - end if; - end if; - - -- Check arguments: For tagged type the first formal must be - -- named "this" and its type must be a named access type - -- designating a class-wide tagged type that has convention - -- CIL/Java. The first formal must also have a null default - -- value. For example: - - -- type Typ is tagged ... - -- type Ref is access all Typ; - -- pragma Convention (CIL, Typ); - - -- function New_Typ (This : Ref) return Ref; - -- function New_Typ (This : Ref; I : Integer) return Ref; - -- pragma Cil_Constructor (New_Typ); - - -- Reason: The first formal must NOT be a primitive of the - -- tagged type. - - -- This rule also applies to constructors of delegates used - -- to interface with standard target libraries. For example: - - -- type Delegate is access procedure ... - -- pragma Import (CIL, Delegate, ...); - - -- function new_Delegate - -- (This : Delegate := null; ... ) return Delegate; - - -- For value-types this rule does not apply. - - if not Is_Value_Type (Etype (Def_Id)) then - if No (First_Formal (Def_Id)) then - Error_Msg_Name_1 := Pname; - Error_Msg_N ("% function must have parameters", Def_Id); - return; - end if; - - -- In the JRE library we have several occurrences in which - -- the "this" parameter is not the first formal. - - This_Formal := First_Formal (Def_Id); - - -- In the JRE library we have several occurrences in which - -- the "this" parameter is not the first formal. Search for - -- it. - - if VM_Target = JVM_Target then - while Present (This_Formal) - and then Get_Name_String (Chars (This_Formal)) /= "this" - loop - Next_Formal (This_Formal); - end loop; - - if No (This_Formal) then - This_Formal := First_Formal (Def_Id); - end if; - end if; - - -- Warning: The first parameter should be named "this". - -- We temporarily allow it because we have the following - -- case in the Java runtime (file s-osinte.ads) ??? - - -- function new_Thread - -- (Self_Id : System.Address) return Thread_Id; - -- pragma Java_Constructor (new_Thread); - - if VM_Target = JVM_Target - and then Get_Name_String (Chars (First_Formal (Def_Id))) - = "self_id" - and then Etype (First_Formal (Def_Id)) = RTE (RE_Address) - then - null; - - elsif Get_Name_String (Chars (This_Formal)) /= "this" then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("first formal of % function must be named `this`", - Parent (This_Formal)); - - elsif not Is_Access_Type (Etype (This_Formal)) then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("first formal of % function must be an access type", - Parameter_Type (Parent (This_Formal))); - - -- For delegates the type of the first formal must be a - -- named access-to-subprogram type (see previous example) - - elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type - and then Ekind (Etype (This_Formal)) - /= E_Access_Subprogram_Type - then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("first formal of % function must be a named access " - & "to subprogram type", - Parameter_Type (Parent (This_Formal))); - - -- Warning: We should reject anonymous access types because - -- the constructor must not be handled as a primitive of the - -- tagged type. We temporarily allow it because this profile - -- is currently generated by cil2ada??? - - elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type - and then not Ekind_In (Etype (This_Formal), - E_Access_Type, - E_General_Access_Type, - E_Anonymous_Access_Type) - then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("first formal of % function must be a named access " - & "type", Parameter_Type (Parent (This_Formal))); - - elsif Atree.Convention - (Designated_Type (Etype (This_Formal))) /= Convention - then - Error_Msg_Name_1 := Pname; - - if Convention = Convention_Java then - Error_Msg_N - ("pragma% requires convention 'Cil in designated " - & "type", Parameter_Type (Parent (This_Formal))); - else - Error_Msg_N - ("pragma% requires convention 'Java in designated " - & "type", Parameter_Type (Parent (This_Formal))); - end if; - - elsif No (Expression (Parent (This_Formal))) - or else Nkind (Expression (Parent (This_Formal))) /= N_Null - then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("pragma% requires first formal with default `null`", - Parameter_Type (Parent (This_Formal))); - end if; - end if; - - -- Check result type: the constructor must be a function - -- returning: - -- * a value type (only allowed in the CIL compiler) - -- * an access-to-subprogram type with convention Java/CIL - -- * an access-type designating a type that has convention - -- Java/CIL. - - if Is_Value_Type (Etype (Def_Id)) then - null; - - -- Access-to-subprogram type with convention Java/CIL - - elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then - if Atree.Convention (Etype (Def_Id)) /= Convention then - if Convention = Convention_Java then - Error_Pragma_Arg - ("pragma% requires function returning a 'Java " - & "access type", Arg1); - else - pragma Assert (Convention = Convention_CIL); - Error_Pragma_Arg - ("pragma% requires function returning a 'C'I'L " - & "access type", Arg1); - end if; - end if; - - elsif Is_Access_Type (Etype (Def_Id)) then - if not Ekind_In (Etype (Def_Id), E_Access_Type, - E_General_Access_Type) - or else - Atree.Convention - (Designated_Type (Etype (Def_Id))) /= Convention - then - Error_Msg_Name_1 := Pname; - - if Convention = Convention_Java then - Error_Pragma_Arg - ("pragma% requires function returning a named " - & "'Java access type", Arg1); - else - Error_Pragma_Arg - ("pragma% requires function returning a named " - & "'C'I'L access type", Arg1); - end if; - end if; - end if; - - Set_Is_Constructor (Def_Id); - Set_Convention (Def_Id, Convention); - Set_Is_Imported (Def_Id); - - exit when From_Aspect_Specification (N); - Hom_Id := Homonym (Hom_Id); - - exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope; - end loop; - end Java_Constructor; - - ---------------------- - -- Java_Interface -- - ---------------------- - - -- pragma Java_Interface ([Entity =>] LOCAL_NAME); - - when Pragma_Java_Interface => Java_Interface : declare - Arg : Node_Id; - Typ : Entity_Id; - - begin - GNAT_Pragma; - Check_Arg_Count (1); - Check_Optional_Identifier (Arg1, Name_Entity); - Check_Arg_Is_Local_Name (Arg1); - - Arg := Get_Pragma_Arg (Arg1); - Analyze (Arg); - - if Etype (Arg) = Any_Type then - return; - end if; - - if not Is_Entity_Name (Arg) - or else not Is_Type (Entity (Arg)) - then - Error_Pragma_Arg ("pragma% requires a type mark", Arg1); - end if; - - Typ := Underlying_Type (Entity (Arg)); - - -- For now simply check some of the semantic constraints on the - -- type. This currently leaves out some restrictions on interface - -- types, namely that the parent type must be java.lang.Object.Typ - -- and that all primitives of the type should be declared - -- abstract. ??? - - if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then - Error_Pragma_Arg - ("pragma% requires an abstract tagged type", Arg1); - - elsif not Has_Discriminants (Typ) - or else Ekind (Etype (First_Discriminant (Typ))) - /= E_Anonymous_Access_Type - or else - not Is_Class_Wide_Type - (Designated_Type (Etype (First_Discriminant (Typ)))) - then - Error_Pragma_Arg - ("type must have a class-wide access discriminant", Arg1); - end if; - end Java_Interface; - ---------------- -- Keep_Names -- ---------------- @@ -17634,18 +17249,6 @@ package body Sem_Prag is if CodePeer_Mode then null; - -- Don't attempt any packing for VM targets. We possibly - -- could deal with some cases of array bit-packing, but we - -- don't bother, since this is not a typical kind of - -- representation in the VM context anyway (and would not - -- for example work nicely with the debugger). - - elsif VM_Target /= No_VM then - if not GNAT_Mode then - Error_Pragma - ("??pragma% ignored in this configuration"); - end if; - -- Normal case where we do the pack action else @@ -17662,23 +17265,9 @@ package body Sem_Prag is else pragma Assert (Is_Record_Type (Typ)); if not Rep_Item_Too_Late (Typ, N) then - - -- Ignore pack request with warning in VM mode (skip warning - -- if we are compiling GNAT run time library). - - if VM_Target /= No_VM then - if not GNAT_Mode then - Error_Pragma - ("??pragma% ignored in this configuration"); - end if; - - -- Normal case of pack request active - - else - Set_Is_Packed (Base_Type (Typ)); - Set_Has_Pragma_Pack (Base_Type (Typ)); - Set_Has_Non_Standard_Rep (Base_Type (Typ)); - end if; + Set_Is_Packed (Base_Type (Typ)); + Set_Has_Pragma_Pack (Base_Type (Typ)); + Set_Has_Non_Standard_Rep (Base_Type (Typ)); end if; end if; end Pack; @@ -26619,7 +26208,6 @@ package body Sem_Prag is Pragma_Check_Float_Overflow => 0, Pragma_Check_Name => 0, Pragma_Check_Policy => 0, - Pragma_CIL_Constructor => 0, Pragma_CPP_Class => 0, Pragma_CPP_Constructor => 0, Pragma_CPP_Virtual => 0, @@ -26698,8 +26286,6 @@ package body Sem_Prag is Pragma_Interrupt_Priority => -1, Pragma_Interrupt_State => -1, Pragma_Invariant => -1, - Pragma_Java_Constructor => -1, - Pragma_Java_Interface => -1, Pragma_Keep_Names => 0, Pragma_License => 0, Pragma_Link_With => -1, @@ -27380,12 +26966,11 @@ package body Sem_Prag is begin -- If first character is asterisk, this is a link name, and we leave it -- completely unmodified. We also ignore null strings (the latter case - -- happens only in error cases) and no encoding should occur for Java or - -- AAMP interface names. + -- happens only in error cases) and no encoding should occur for AAMP + -- interface names. if Len = 0 or else Get_String_Char (Str, 1) = Get_Char_Code ('*') - or else VM_Target /= No_VM or else AAMP_On_Target then Set_Interface_Name (E, S); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 785121adf24..06833fd9957 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -1728,18 +1728,6 @@ package body Sem_Type is end if; end if; - -- Check for overloaded CIL convention stuff because the CIL libraries - -- do sick things like Console.Write_Line where it matches two different - -- overloads, so just pick the first ??? - - if Convention (Nam1) = Convention_CIL - and then Convention (Nam2) = Convention_CIL - and then Ekind (Nam1) = Ekind (Nam2) - and then Ekind_In (Nam1, E_Procedure, E_Function) - then - return It2; - end if; - -- If the context is universal, the predefined operator is preferred. -- This includes bounds in numeric type declarations, and expressions -- in type conversions. If no interpretation yields a universal type, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 2e7064b0ef0..3295ea3d09f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3051,48 +3051,6 @@ package body Sem_Util is end loop Outer; end Check_Later_Vs_Basic_Declarations; - ------------------------- - -- Check_Nested_Access -- - ------------------------- - - procedure Check_Nested_Access (Ent : Entity_Id) is - Scop : constant Entity_Id := Current_Scope; - Current_Subp : Entity_Id; - Enclosing : Entity_Id; - - begin - -- Currently only enabled for VM back-ends for efficiency - - if VM_Target /= No_VM - and then Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter) - and then Scope (Ent) /= Empty - and then not Is_Library_Level_Entity (Ent) - - -- Comment the exclusion of imported entities ??? - - and then not Is_Imported (Ent) - then - -- Get current subprogram that is relevant - - if Is_Subprogram (Scop) - or else Is_Generic_Subprogram (Scop) - or else Is_Entry (Scop) - then - Current_Subp := Scop; - else - Current_Subp := Current_Subprogram; - end if; - - Enclosing := Enclosing_Subprogram (Ent); - - -- Set flag if uplevel reference - - if Enclosing /= Empty and then Enclosing /= Current_Subp then - Set_Has_Uplevel_Reference (Ent, True); - end if; - end if; - end Check_Nested_Access; - --------------------------- -- Check_No_Hidden_State -- --------------------------- @@ -11108,54 +11066,6 @@ package body Sem_Util is end case; end Is_Declaration; - ----------------- - -- Is_Delegate -- - ----------------- - - function Is_Delegate (T : Entity_Id) return Boolean is - Desig_Type : Entity_Id; - - begin - if VM_Target /= CLI_Target then - return False; - end if; - - -- Access-to-subprograms are delegates in CIL - - if Ekind (T) = E_Access_Subprogram_Type then - return True; - end if; - - if not Is_Access_Type (T) then - - -- A delegate is a managed pointer. If no designated type is defined - -- it means that it's not a delegate. - - return False; - end if; - - Desig_Type := Etype (Directly_Designated_Type (T)); - - if not Is_Tagged_Type (Desig_Type) then - return False; - end if; - - -- Test if the type is inherited from [mscorlib]System.Delegate - - while Etype (Desig_Type) /= Desig_Type loop - if Chars (Scope (Desig_Type)) /= No_Name - and then Is_Imported (Scope (Desig_Type)) - and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" - then - return True; - end if; - - Desig_Type := Etype (Desig_Type); - end loop; - - return False; - end Is_Delegate; - ---------------------------------------------- -- Is_Dependent_Component_Of_Mutable_Object -- ---------------------------------------------- @@ -13252,18 +13162,6 @@ package body Sem_Util is return T = Universal_Integer or else T = Universal_Real; end Is_Universal_Numeric_Type; - ------------------- - -- Is_Value_Type -- - ------------------- - - function Is_Value_Type (T : Entity_Id) return Boolean is - begin - return VM_Target = CLI_Target - and then Nkind (T) in N_Has_Chars - and then Chars (T) /= No_Name - and then Get_Name_String (Chars (T)) = "valuetype"; - end Is_Value_Type; - ---------------------------- -- Is_Variable_Size_Array -- ---------------------------- @@ -15856,8 +15754,6 @@ package body Sem_Util is end; end if; end if; - - Check_Nested_Access (Ent); end if; Kill_Checks (Ent); @@ -17023,7 +16919,7 @@ package body Sem_Util is -- type temporaries need finalization. elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then - return not Is_Value_Type (Typ); + return True; -- Record type @@ -17235,7 +17131,7 @@ package body Sem_Util is -- since they can't be called via dispatching. elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then - return not Is_Value_Type (Typ); + return True; -- Untagged definite subtypes are known size. This includes all -- elementary [sub]types. Tasks are known size even if they have diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 0ea54daa369..caa35401ee8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -308,11 +308,6 @@ package Sem_Util is -- remains in the Examiner (JB01-005). Note that the Examiner does not -- count package declarations in later declarative items. - procedure Check_Nested_Access (Ent : Entity_Id); - -- Check whether Ent denotes an entity declared in an uplevel scope, which - -- is accessed inside a nested procedure, and set Has_Uplevel_Reference - -- flag accordingly. This is currently only enabled for if on a VM target. - procedure Check_No_Hidden_State (Id : Entity_Id); -- Determine whether object or state Id introduces a hidden state. If this -- is the case, emit an error. @@ -1256,11 +1251,6 @@ package Sem_Util is function Is_Declaration (N : Node_Id) return Boolean; -- Determine whether arbitrary node N denotes a declaration - function Is_Delegate (T : Entity_Id) return Boolean; - -- Returns true if type T represents a delegate. A Delegate is the CIL - -- object used to represent access-to-subprogram types. This is only - -- relevant to CIL, will always return false for other targets. - function Is_Dependent_Component_Of_Mutable_Object (Object : Node_Id) return Boolean; -- Returns True if Object is the name of a subcomponent that depends on @@ -1528,12 +1518,6 @@ package Sem_Util is pragma Inline (Is_Universal_Numeric_Type); -- True if T is Universal_Integer or Universal_Real - function Is_Value_Type (T : Entity_Id) return Boolean; - -- Returns true if type T represents a value type. This is only relevant to - -- CIL, will always return false for other targets. A value type is a CIL - -- object that is accessed directly, as opposed to the other CIL objects - -- that are accessed through managed pointers. - function Is_Variable_Size_Array (E : Entity_Id) return Boolean; -- Returns true if E has variable size components diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 203313d11e6..968d87def2a 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -8098,10 +8098,10 @@ package Sinfo is -- For the case of the standard gigi backend, this means that all -- checks are done in the front end. - -- However, in the case of specialized back-ends, notably the JVM - -- backend for JGNAT, additional requirements and restrictions apply - -- to unchecked conversion, and these are most conveniently performed - -- in the specialized back-end. + -- However, in the case of specialized back-ends, in particular the JVM + -- backend in the past, additional requirements and restrictions may + -- apply to unchecked conversion, and these are most conveniently + -- performed in the specialized back-end. -- To accommodate this requirement, for such back ends, the following -- special node is generated recording an unchecked conversion that diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index 6e1acd9c22a..3de2b82cc6b 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -152,12 +152,10 @@ package body Snames is Convention_Ada_Pass_By_Reference; when Name_Assembler => return Convention_Assembler; when Name_C => return Convention_C; - when Name_CIL => return Convention_CIL; when Name_COBOL => return Convention_COBOL; when Name_CPP => return Convention_CPP; when Name_Fortran => return Convention_Fortran; when Name_Intrinsic => return Convention_Intrinsic; - when Name_Java => return Convention_Java; when Name_Stdcall => return Convention_Stdcall; when Name_Stubbed => return Convention_Stubbed; @@ -188,13 +186,11 @@ package body Snames is return Name_Ada_Pass_By_Reference; when Convention_Assembler => return Name_Assembler; when Convention_C => return Name_C; - when Convention_CIL => return Name_CIL; when Convention_COBOL => return Name_COBOL; when Convention_CPP => return Name_CPP; when Convention_Entry => return Name_Entry; when Convention_Fortran => return Name_Fortran; when Convention_Intrinsic => return Name_Intrinsic; - when Convention_Java => return Name_Java; when Convention_Protected => return Name_Protected; when Convention_Stdcall => return Name_Stdcall; when Convention_Stubbed => return Name_Stubbed; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index b76e6295059..de46bdb9316 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -464,7 +464,6 @@ package Snames is Name_Atomic_Components : constant Name_Id := N + $; Name_Attach_Handler : constant Name_Id := N + $; Name_Check : constant Name_Id := N + $; -- GNAT - Name_CIL_Constructor : constant Name_Id := N + $; -- GNAT Name_Comment : constant Name_Id := N + $; -- GNAT Name_Common_Object : constant Name_Id := N + $; -- GNAT Name_Complete_Representation : constant Name_Id := N + $; -- GNAT @@ -533,8 +532,6 @@ package Snames is -- Is_Pragma_Id correctly recognize and process Interrupt_Priority. Name_Invariant : constant Name_Id := N + $; -- GNAT - Name_Java_Constructor : constant Name_Id := N + $; -- GNAT - Name_Java_Interface : constant Name_Id := N + $; -- GNAT Name_Keep_Names : constant Name_Id := N + $; -- GNAT Name_Link_With : constant Name_Id := N + $; -- GNAT Name_Linker_Alias : constant Name_Id := N + $; -- GNAT @@ -651,12 +648,10 @@ package Snames is Name_Ada_Pass_By_Copy : constant Name_Id := N + $; Name_Ada_Pass_By_Reference : constant Name_Id := N + $; Name_Assembler : constant Name_Id := N + $; - Name_CIL : constant Name_Id := N + $; Name_COBOL : constant Name_Id := N + $; Name_CPP : constant Name_Id := N + $; Name_Fortran : constant Name_Id := N + $; Name_Intrinsic : constant Name_Id := N + $; - Name_Java : constant Name_Id := N + $; Name_Stdcall : constant Name_Id := N + $; Name_Stubbed : constant Name_Id := N + $; Last_Convention_Name : constant Name_Id := N + $; @@ -1682,11 +1677,9 @@ package Snames is Convention_Assembler, -- also Asm, Assembly Convention_C, -- also Default, External - Convention_CIL, Convention_COBOL, Convention_CPP, Convention_Fortran, - Convention_Java, Convention_Stdcall); -- also DLL, Win32 -- Note: Convention C_Pass_By_Copy is allowed only for record types @@ -1816,7 +1809,6 @@ package Snames is Pragma_Atomic_Components, Pragma_Attach_Handler, Pragma_Check, - Pragma_CIL_Constructor, Pragma_Comment, Pragma_Common_Object, Pragma_Complete_Representation, @@ -1866,8 +1858,6 @@ package Snames is Pragma_Interface_Name, Pragma_Interrupt_Handler, Pragma_Invariant, - Pragma_Java_Constructor, - Pragma_Java_Interface, Pragma_Keep_Names, Pragma_Link_With, Pragma_Linker_Alias, diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 645193e2459..42696cf0ba2 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -44,14 +44,12 @@ package body Targparm is BDC, -- Backend_Divide_Checks BOC, -- Backend_Overflow_Checks CLA, -- Command_Line_Args - CLI, -- CLI (.NET) CRT, -- Configurable_Run_Times D32, -- Duration_32_Bits DEN, -- Denorm EXS, -- Exit_Status_Supported FEL, -- Frontend_Layout FFO, -- Fractional_Fixed_Ops - JVM, -- JVM MOV, -- Machine_Overflows MRN, -- Machine_Rounds PAS, -- Preallocated_Stacks @@ -79,14 +77,12 @@ package body Targparm is BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks"; BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks"; CLA_Str : aliased constant Source_Buffer := "Command_Line_Args"; - CLI_Str : aliased constant Source_Buffer := "CLI"; CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time"; D32_Str : aliased constant Source_Buffer := "Duration_32_Bits"; DEN_Str : aliased constant Source_Buffer := "Denorm"; EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported"; FEL_Str : aliased constant Source_Buffer := "Frontend_Layout"; FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops"; - JVM_Str : aliased constant Source_Buffer := "JVM"; MOV_Str : aliased constant Source_Buffer := "Machine_Overflows"; MRN_Str : aliased constant Source_Buffer := "Machine_Rounds"; PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks"; @@ -114,14 +110,12 @@ package body Targparm is BDC_Str'Access, BOC_Str'Access, CLA_Str'Access, - CLI_Str'Access, CRT_Str'Access, D32_Str'Access, DEN_Str'Access, EXS_Str'Access, FEL_Str'Access, FFO_Str'Access, - JVM_Str'Access, MOV_Str'Access, MRN_Str'Access, PAS_Str'Access, @@ -794,33 +788,12 @@ package body Targparm is when BDC => Backend_Divide_Checks_On_Target := Result; when BOC => Backend_Overflow_Checks_On_Target := Result; when CLA => Command_Line_Args_On_Target := Result; - when CLI => - if Result then - VM_Target := CLI_Target; - Tagged_Type_Expansion := False; - end if; - -- This is wrong, this processing should be done in - -- Gnat1drv.Adjust_Global_Switches. It is not the - -- right level for targparm to know about tagged - -- type extension??? - when CRT => Configurable_Run_Time_On_Target := Result; when D32 => Duration_32_Bits_On_Target := Result; when DEN => Denorm_On_Target := Result; when EXS => Exit_Status_Supported_On_Target := Result; when FEL => Frontend_Layout_On_Target := Result; when FFO => Fractional_Fixed_Ops_On_Target := Result; - - when JVM => - if Result then - VM_Target := JVM_Target; - Tagged_Type_Expansion := False; - end if; - -- This is wrong, this processing should be done in - -- Gnat1drv.Adjust_Global_Switches. It is not the - -- right level for targparm to know about tagged - -- type extension??? - when MOV => Machine_Overflows_On_Target := Result; when MRN => Machine_Rounds_On_Target := Result; when PAS => Preallocated_Stacks_On_Target := Result; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index a1b766153ee..21780d1b12c 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -203,13 +203,6 @@ package Targparm is AAMP_On_Target : Boolean := False; -- Set to True if target is AAMP - type Virtual_Machine_Kind is (No_VM, JVM_Target, CLI_Target); - VM_Target : Virtual_Machine_Kind := No_VM; - -- Kind of virtual machine targetted - -- No_VM: no virtual machine, default case of a standard processor - -- JVM_Target: Java Virtual Machine - -- CLI_Target: CLI/.NET Virtual Machine - ------------------------------- -- Backend Arithmetic Checks -- ------------------------------- diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index ed3eac1d43c..dc37f152e76 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -827,9 +827,8 @@ package Types is -- To add a new code, you need to do the following: -- 1. Assign a new number to the reason. Do not renumber existing codes, - -- since this causes compatibility/bootstrap issues, and problems in - -- the CIL/JVM backends. So always add the new code at the end of the - -- list. + -- since this causes compatibility/bootstrap issues, so always add the + -- new code at the end of the list. -- 2. Update the contents of the array Kind diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 803c44d7a51..b18d542f009 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -91,9 +91,9 @@ begin Write_Eol; - -- Common GCC switches not available for JVM, .NET, and AAMP targets + -- Common GCC switches not available for AAMP targets - if VM_Target = No_VM and then not AAMP_On_Target then + if not AAMP_On_Target then Write_Switch_Char ("fstack-check ", ""); Write_Line ("Generate stack checking code"); |