bindgen.adb (Gen_Adainit_Ada): If the main program is a CIL function...
2008-04-08 Jerome Lambourg <lambourg@adacore.com> Arnaud Charlet <charlet@adacore.com> * bindgen.adb (Gen_Adainit_Ada): If the main program is a CIL function, then use __gnat_set_exit_status to report the returned status code. * comperr.adb (Compiler_Abort): Convert most bug boxes into clean error messages on .NET, since some constructs of the language are not properly supported. * gnatlink.adb (Gnatlink): In case the command line is too long for the .NET linker, gnatlink now concatenate all .il files and pass this to ilasm. From-SVN: r134066
This commit is contained in:
parent
77e5104283
commit
c96597bfe5
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -618,17 +618,27 @@ package body Bindgen is
|
||||||
"""__gnat_initialize_stack_limit"");");
|
"""__gnat_initialize_stack_limit"");");
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
-- Special processing when main program is CIL function/procedure
|
||||||
|
|
||||||
if VM_Target = CLI_Target
|
if VM_Target = CLI_Target
|
||||||
and then Bind_Main_Program
|
and then Bind_Main_Program
|
||||||
and then not No_Main_Subprogram
|
and then not No_Main_Subprogram
|
||||||
then
|
then
|
||||||
WBI ("");
|
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
|
if ALIs.Table (ALIs.First).Main_Program = Func then
|
||||||
WBI (" Result : Integer;");
|
WBI (" Result : Integer;");
|
||||||
|
WBI (" procedure Set_Exit_Status (Code : Integer);");
|
||||||
|
WBI (" pragma Import (C, Set_Exit_Status, " &
|
||||||
|
"""__gnat_set_exit_status"");");
|
||||||
WBI ("");
|
WBI ("");
|
||||||
WBI (" function Ada_Main_Program return Integer;");
|
WBI (" function Ada_Main_Program return Integer;");
|
||||||
|
|
||||||
|
-- Procedure case
|
||||||
|
|
||||||
else
|
else
|
||||||
WBI (" procedure Ada_Main_Program;");
|
WBI (" procedure Ada_Main_Program;");
|
||||||
end if;
|
end if;
|
||||||
|
@ -797,12 +807,20 @@ package body Bindgen is
|
||||||
WBI ("");
|
WBI ("");
|
||||||
Gen_Elab_Calls_Ada;
|
Gen_Elab_Calls_Ada;
|
||||||
|
|
||||||
|
-- Case of main program is CIL function or procedure
|
||||||
|
|
||||||
if VM_Target = CLI_Target
|
if VM_Target = CLI_Target
|
||||||
and then Bind_Main_Program
|
and then Bind_Main_Program
|
||||||
and then not No_Main_Subprogram
|
and then not No_Main_Subprogram
|
||||||
then
|
then
|
||||||
|
-- For function case, use Set_Exit_Status to set result
|
||||||
|
|
||||||
if ALIs.Table (ALIs.First).Main_Program = Func then
|
if ALIs.Table (ALIs.First).Main_Program = Func then
|
||||||
WBI (" Result := Ada_Main_Program;");
|
WBI (" Result := Ada_Main_Program;");
|
||||||
|
WBI (" Set_Exit_Status (Result);");
|
||||||
|
|
||||||
|
-- Procedure case
|
||||||
|
|
||||||
else
|
else
|
||||||
WBI (" Ada_Main_Program;");
|
WBI (" Ada_Main_Program;");
|
||||||
end if;
|
end if;
|
||||||
|
@ -2270,7 +2288,7 @@ package body Bindgen is
|
||||||
|
|
||||||
if VM_Target = No_VM then
|
if VM_Target = No_VM then
|
||||||
Set_Main_Program_Name;
|
Set_Main_Program_Name;
|
||||||
Set_String (""" & Ascii.NUL;");
|
Set_String (""" & ASCII.NUL;");
|
||||||
else
|
else
|
||||||
Set_String (Name_Buffer (1 .. Name_Len - 2) & """;");
|
Set_String (Name_Buffer (1 .. Name_Len - 2) & """;");
|
||||||
end if;
|
end if;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -39,6 +39,7 @@ with Output; use Output;
|
||||||
with Sinput; use Sinput;
|
with Sinput; use Sinput;
|
||||||
with Sprint; use Sprint;
|
with Sprint; use Sprint;
|
||||||
with Sdefault; use Sdefault;
|
with Sdefault; use Sdefault;
|
||||||
|
with Targparm; use Targparm;
|
||||||
with Treepr; use Treepr;
|
with Treepr; use Treepr;
|
||||||
with Types; use Types;
|
with Types; use Types;
|
||||||
|
|
||||||
|
@ -112,6 +113,31 @@ package body Comperr is
|
||||||
|
|
||||||
Abort_In_Progress := True;
|
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.
|
||||||
|
|
||||||
|
-- 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
|
||||||
|
and then Serious_Errors_Detected = 0
|
||||||
|
and then not Debug_Flag_K
|
||||||
|
and then Sloc (Current_Error_Node) > No_Location
|
||||||
|
then
|
||||||
|
Error_Msg_N
|
||||||
|
("unsupported construct in this context",
|
||||||
|
Current_Error_Node);
|
||||||
|
end if;
|
||||||
|
|
||||||
-- If any errors have already occurred, then we guess that the abort
|
-- If any errors have already occurred, then we guess that the abort
|
||||||
-- may well be caused by previous errors, and we don't make too much
|
-- may well be caused by previous errors, and we don't make too much
|
||||||
-- fuss about it, since we want to let programmer fix the errors first.
|
-- fuss about it, since we want to let programmer fix the errors first.
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1996-2007, Free Software Foundation, Inc. --
|
-- Copyright (C) 1996-2008, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -139,7 +139,7 @@ procedure Gnatlink is
|
||||||
|
|
||||||
Gcc : String_Access := Program_Name ("gcc");
|
Gcc : String_Access := Program_Name ("gcc");
|
||||||
|
|
||||||
Read_Mode : constant String := "r" & ASCII.Nul;
|
Read_Mode : constant String := "r" & ASCII.NUL;
|
||||||
|
|
||||||
Begin_Info : String := "-- BEGIN Object file/option list";
|
Begin_Info : String := "-- BEGIN Object file/option list";
|
||||||
End_Info : String := "-- END Object file/option list ";
|
End_Info : String := "-- END Object file/option list ";
|
||||||
|
@ -147,7 +147,6 @@ procedure Gnatlink is
|
||||||
|
|
||||||
Gcc_Path : String_Access;
|
Gcc_Path : String_Access;
|
||||||
Linker_Path : String_Access;
|
Linker_Path : String_Access;
|
||||||
|
|
||||||
Output_File_Name : String_Access;
|
Output_File_Name : String_Access;
|
||||||
Ali_File_Name : String_Access;
|
Ali_File_Name : String_Access;
|
||||||
Binder_Spec_Src_File : String_Access;
|
Binder_Spec_Src_File : String_Access;
|
||||||
|
@ -160,6 +159,10 @@ procedure Gnatlink is
|
||||||
-- Temporary file used by linker to pass list of object files on
|
-- Temporary file used by linker to pass list of object files on
|
||||||
-- certain systems with limitations on size of arguments.
|
-- certain systems with limitations on size of arguments.
|
||||||
|
|
||||||
|
Lname : String_Access := null;
|
||||||
|
-- File used by linker for CLI target, used to concatenate all .il files
|
||||||
|
-- when the command line passed to ilasm is too long
|
||||||
|
|
||||||
Debug_Flag_Present : Boolean := False;
|
Debug_Flag_Present : Boolean := False;
|
||||||
Verbose_Mode : Boolean := False;
|
Verbose_Mode : Boolean := False;
|
||||||
Very_Verbose_Mode : Boolean := False;
|
Very_Verbose_Mode : Boolean := False;
|
||||||
|
@ -953,7 +956,42 @@ procedure Gnatlink is
|
||||||
-- to read from a file instead of the command line is only triggered if
|
-- to read from a file instead of the command line is only triggered if
|
||||||
-- a conservative threshold is passed.
|
-- a conservative threshold is passed.
|
||||||
|
|
||||||
if Object_List_File_Required
|
if VM_Target = CLI_Target
|
||||||
|
and then Link_Bytes > Link_Max
|
||||||
|
then
|
||||||
|
Lname := new String'("l~" & Base_Name (Ali_File_Name.all) & ".il");
|
||||||
|
|
||||||
|
for J in Objs_Begin .. Objs_End loop
|
||||||
|
Copy_File (Linker_Objects.Table (J).all, Lname.all,
|
||||||
|
Success => Closing_Status,
|
||||||
|
Mode => Append);
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
-- Add the special objects list file option together with the name
|
||||||
|
-- of the temporary file to the objects file table.
|
||||||
|
|
||||||
|
Linker_Objects.Table (Objs_Begin) :=
|
||||||
|
new String'(Value (Object_File_Option_Ptr) & Lname.all);
|
||||||
|
|
||||||
|
-- The slots containing these object file names are then removed
|
||||||
|
-- from the objects table so they do not appear in the link. They
|
||||||
|
-- are removed by moving up the linker options and non-Ada object
|
||||||
|
-- files appearing after the Ada object list in the table.
|
||||||
|
|
||||||
|
declare
|
||||||
|
N : Integer;
|
||||||
|
|
||||||
|
begin
|
||||||
|
N := Objs_End - Objs_Begin + 1;
|
||||||
|
|
||||||
|
for J in Objs_End + 1 .. Linker_Objects.Last loop
|
||||||
|
Linker_Objects.Table (J - N + 1) := Linker_Objects.Table (J);
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
Linker_Objects.Set_Last (Linker_Objects.Last - N + 1);
|
||||||
|
end;
|
||||||
|
|
||||||
|
elsif Object_List_File_Required
|
||||||
or else (Object_List_File_Supported
|
or else (Object_List_File_Supported
|
||||||
and then Link_Bytes > Link_Max)
|
and then Link_Bytes > Link_Max)
|
||||||
then
|
then
|
||||||
|
@ -2015,6 +2053,10 @@ begin
|
||||||
Delete (Tname);
|
Delete (Tname);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
if Lname /= null then
|
||||||
|
Delete (Lname.all & ASCII.NUL);
|
||||||
|
end if;
|
||||||
|
|
||||||
if not Success then
|
if not Success then
|
||||||
Error_Msg ("error when calling " & Linker_Path.all);
|
Error_Msg ("error when calling " & Linker_Path.all);
|
||||||
Exit_Program (E_Fatal);
|
Exit_Program (E_Fatal);
|
||||||
|
|
Loading…
Reference in New Issue