+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
-- 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
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"");");
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
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;");
-- 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
" ""__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, " &
"""__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.
-- 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
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;
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;
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);
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;
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_");
-- 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;
-- 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;
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
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;
-- 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
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;
end if;
end if;
- if Bind_Main_Program and then VM_Target = No_VM then
+ if Bind_Main_Program then
WBI ("");
Gen_Adainit;
- if Bind_Main_Program and then VM_Target = No_VM then
+ if Bind_Main_Program then
Gen_Main;
end if;
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_" &
-- 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;
-- 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;
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.
-- --
-- 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- --
with Sinput; use Sinput;
with Sprint; use Sprint;
with Sdefault; use Sdefault;
-with Targparm; use Targparm;
with Treepr; use Treepr;
with Types; use Types;
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
-- 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
-- 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.
-- 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
-- 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
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);
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);
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));
-- 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
-- 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
-- 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
-- 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,
-- 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
-- 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)
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;
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);
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);
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);
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 :=
-- 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)
-- 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
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
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
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');
-- 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);
-- 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).
-- 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
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
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
-- 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 :=
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;
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;
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
-- 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;
-- 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;
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,
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
-- _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
-- 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;
-- 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.
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;
-- 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
-- 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
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.
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.
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));
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
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;
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.
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;
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.
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));
-- 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;
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)
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);
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
-- 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
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);
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:
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));
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.
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);
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));
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.
-- 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;
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
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
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)));
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
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);
-- 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
-- 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 =>
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
-- 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
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
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
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).
(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
-- Local variables
- Curr_S : constant Entity_Id := Current_Scope;
Remote : constant Boolean := Is_Remote_Call (Call_Node);
Actual : Node_Id;
Formal : Entity_Id;
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
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;
-- 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.
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 :=
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,
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
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;
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)
-- 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,
-- 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;
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;
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;
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;
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.
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
-- 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
-- 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');
Data.Abort_Id := Empty;
end if;
- -- .NET/JVM or library-level finalizers
+ -- Library-level finalizers
else
Data.Abort_Id := Empty;
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;
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));
--
-- 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');
end if;
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 --
----------------------
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
(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));
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
-- 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:
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
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 :=
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 (
-- 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
with Stand; use Stand;
with Stringt; use Stringt;
with Table;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Urealp; use Urealp;
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;
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
return Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Typ)
- and then VM_Target = No_VM
-- If the type is derived from a CPP class we cannot statically
-- build the dispatch tables because we must inherit primitives
end;
if 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
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;
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 --
-------------------------------------
begin
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
- pragma Assert (VM_Target = No_VM);
-- Do not register in the dispatch table eliminated primitives
-- 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;
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;
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
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.
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
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;
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)
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 --
--------------------
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).
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
-- 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)
-- 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
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))
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);
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;
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)
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.
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;
-- 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 " &
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;
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.
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;
-- 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.
-- 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;
-- 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);
-- --
-- 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- --
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
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;
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
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);
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
-- 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
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);
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;
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);
Pragma_Check_Float_Overflow |
Pragma_Check_Name |
Pragma_Check_Policy |
- Pragma_CIL_Constructor |
Pragma_Compile_Time_Error |
Pragma_Compile_Time_Warning |
Pragma_Contract_Cases |
Pragma_Interrupt_State |
Pragma_Interrupt_Priority |
Pragma_Invariant |
- Pragma_Java_Constructor |
- Pragma_Java_Interface |
Pragma_Keep_Names |
Pragma_License |
Pragma_Link_With |
-- --
-- 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- --
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 =>
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
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
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,
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,
-- --
-- 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- --
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;
-- --
-- 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- --
-- 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.
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.
-- --
-- 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- --
package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
- package AE renames Ada.Exceptions;
use Parameters;
use Task_Primitives.Operations;
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
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
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 --
--------------------------
-- 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
("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);
("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
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;
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;
-- 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);
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
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
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;
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
-- 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),
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
with Snames; use Snames;
with Style; use Style;
with Table;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- 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
end case;
end if;
end if;
-
- Check_Nested_Access (E);
end if;
Set_Entity_Or_Discriminal (N, E);
-- 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) =
with Stand; use Stand;
with Sinfo; use Sinfo;
with Style;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
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
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;
-- No code required to register primitives in VM
-- targets
- elsif VM_Target /= No_VM then
+ elsif not Tagged_Type_Expansion then
null;
else
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));
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.
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
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;
-- --
-- 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- --
-- 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
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
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;
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",
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
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
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
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 :=
(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;
-----------------------------------------
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;
end if;
end Check_Policy;
- ---------------------
- -- CIL_Constructor --
- ---------------------
-
- -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
-
- -- Processing for this pragma is shared with Java_Constructor
-
-------------
-- Comment --
-------------
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 --
----------------
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
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;
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,
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,
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);
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,
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 --
---------------------------
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 --
----------------------------------------------
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 --
----------------------------
end;
end if;
end if;
-
- Check_Nested_Access (Ent);
end if;
Kill_Checks (Ent);
-- 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
-- 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
-- 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.
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
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
-- 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
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;
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;
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
-- 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
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 + $;
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
Pragma_Atomic_Components,
Pragma_Attach_Handler,
Pragma_Check,
- Pragma_CIL_Constructor,
Pragma_Comment,
Pragma_Common_Object,
Pragma_Complete_Representation,
Pragma_Interface_Name,
Pragma_Interrupt_Handler,
Pragma_Invariant,
- Pragma_Java_Constructor,
- Pragma_Java_Interface,
Pragma_Keep_Names,
Pragma_Link_With,
Pragma_Linker_Alias,
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
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";
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,
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;
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 --
-------------------------------
-- 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
-- --
-- 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- --
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");
projects / gcc.git / commitdiff