Skip to content

R
riscv-gcc-1
Commit 2b9fbec9 by Arnaud Charlet
Options

[multiple changes] 

2014-08-01  Robert Dewar  <dewar@adacore.com>

	* sem_case.adb (Dup_Choice): Improve message for integer constants.

2014-08-01  Arnaud Charlet  <charlet@adacore.com>

	* gnatlink.adb: Remove special handling of VMS, RTX and JVM.

2014-08-01  Pascal Obry  <obry@adacore.com>

	* adaint.h (GNAT_OPEN): Defines as open64 where supported.
	* adaint.c (GNAT_OPEN): Uses new macro where needed.

From-SVN: r213410
parent 0494285a
Showing with 263 additions and 446 deletions
gcc/ada/ChangeLog
2014-08-01 Robert Dewar <dewar@adacore.com>
* sem_case.adb (Dup_Choice): Improve message for integer constants.
2014-08-01 Arnaud Charlet <charlet@adacore.com>
* gnatlink.adb: Remove special handling of VMS, RTX and JVM.
2014-08-01 Pascal Obry <obry@adacore.com>
* adaint.h (GNAT_OPEN): Defines as open64 where supported.
* adaint.c (GNAT_OPEN): Uses new macro where needed.
2014-07-31 Eric Botcazou <ebotcazou@adacore.com> 2014-07-31 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/utils.c (lookup_and_insert_pad_type): New function * gcc-interface/utils.c (lookup_and_insert_pad_type): New function
......
gcc/ada/adaint.c
...@@ -1007,7 +1007,7 @@ __gnat_open_read (char *path, int fmode) ...@@ -1007,7 +1007,7 @@ __gnat_open_read (char *path, int fmode)
fd = _topen (wpath, O_RDONLY | o_fmode, 0444); fd = _topen (wpath, O_RDONLY | o_fmode, 0444);
} }
#else #else
fd = open (path, O_RDONLY | o_fmode); fd = GNAT_OPEN (path, O_RDONLY | o_fmode);
#endif #endif
return fd < 0 ? -1 : fd; return fd < 0 ? -1 : fd;
...@@ -1048,7 +1048,7 @@ __gnat_open_rw (char *path, int fmode) ...@@ -1048,7 +1048,7 @@ __gnat_open_rw (char *path, int fmode)
fd = _topen (wpath, O_RDWR | o_fmode, PERM); fd = _topen (wpath, O_RDWR | o_fmode, PERM);
} }
#else #else
fd = open (path, O_RDWR | o_fmode, PERM); fd = GNAT_OPEN (path, O_RDWR | o_fmode, PERM);
#endif #endif
return fd < 0 ? -1 : fd; return fd < 0 ? -1 : fd;
...@@ -1074,7 +1074,7 @@ __gnat_open_create (char *path, int fmode) ...@@ -1074,7 +1074,7 @@ __gnat_open_create (char *path, int fmode)
fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM); fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
} }
#else #else
fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM); fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
#endif #endif
return fd < 0 ? -1 : fd; return fd < 0 ? -1 : fd;
...@@ -1096,7 +1096,7 @@ __gnat_create_output_file (char *path) ...@@ -1096,7 +1096,7 @@ __gnat_create_output_file (char *path)
fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM); fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
} }
#else #else
fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM); fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
#endif #endif
return fd < 0 ? -1 : fd; return fd < 0 ? -1 : fd;
...@@ -1118,7 +1118,7 @@ __gnat_create_output_file_new (char *path) ...@@ -1118,7 +1118,7 @@ __gnat_create_output_file_new (char *path)
fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM); fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM);
} }
#else #else
fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM); fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM);
#endif #endif
return fd < 0 ? -1 : fd; return fd < 0 ? -1 : fd;
...@@ -1144,7 +1144,7 @@ __gnat_open_append (char *path, int fmode) ...@@ -1144,7 +1144,7 @@ __gnat_open_append (char *path, int fmode)
fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM); fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
} }
#else #else
fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM); fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
#endif #endif
return fd < 0 ? -1 : fd; return fd < 0 ? -1 : fd;
...@@ -1172,7 +1172,7 @@ __gnat_open_new (char *path, int fmode) ...@@ -1172,7 +1172,7 @@ __gnat_open_new (char *path, int fmode)
fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM); fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
} }
#else #else
fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM); fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
#endif #endif
return fd < 0 ? -1 : fd; return fd < 0 ? -1 : fd;
...@@ -1213,7 +1213,7 @@ __gnat_open_new_temp (char *path, int fmode) ...@@ -1213,7 +1213,7 @@ __gnat_open_new_temp (char *path, int fmode)
fmode ? "rfm=stmlf" : "rfm=udf", "ctx=rec", "rat=none", fmode ? "rfm=stmlf" : "rfm=udf", "ctx=rec", "rat=none",
"shr=del,get,put,upd", "mbc=16", "deq=64", "fop=tef"); "shr=del,get,put,upd", "mbc=16", "deq=64", "fop=tef");
#else #else
fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM); fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
#endif #endif
return fd < 0 ? -1 : fd; return fd < 0 ? -1 : fd;
......
gcc/ada/adaint.h
...@@ -53,12 +53,14 @@ extern "C" { ...@@ -53,12 +53,14 @@ extern "C" {
#if defined (__GLIBC__) || defined (sun) #if defined (__GLIBC__) || defined (sun)
#define GNAT_FOPEN fopen64 #define GNAT_FOPEN fopen64
#define GNAT_OPEN open64
#define GNAT_STAT stat64 #define GNAT_STAT stat64
#define GNAT_FSTAT fstat64 #define GNAT_FSTAT fstat64
#define GNAT_LSTAT lstat64 #define GNAT_LSTAT lstat64
#define GNAT_STRUCT_STAT struct stat64 #define GNAT_STRUCT_STAT struct stat64
#else #else
#define GNAT_FOPEN fopen #define GNAT_FOPEN fopen
#define GNAT_OPEN open
#define GNAT_STAT stat #define GNAT_STAT stat
#define GNAT_FSTAT fstat #define GNAT_FSTAT fstat
#define GNAT_LSTAT lstat #define GNAT_LSTAT lstat
......
gcc/ada/gnatlink.adb
...@@ -28,7 +28,6 @@ ...@@ -28,7 +28,6 @@
with ALI; use ALI; with ALI; use ALI;
with Csets; with Csets;
with Gnatvsn; use Gnatvsn; with Gnatvsn; use Gnatvsn;
with Hostparm;
with Indepsw; use Indepsw; with Indepsw; use Indepsw;
with Namet; use Namet; with Namet; use Namet;
with Opt; with Opt;
...@@ -228,12 +227,6 @@ procedure Gnatlink is ...@@ -228,12 +227,6 @@ procedure Gnatlink is
procedure Process_Binder_File (Name : String); procedure Process_Binder_File (Name : String);
-- Reads the binder file and extracts linker arguments -- Reads the binder file and extracts linker arguments
function To_Lower (A : Character) return Character;
-- Fold a character to lower case;
procedure To_Lower (A : in out String);
-- Fold a string to lower case;
procedure Usage; procedure Usage;
-- Display usage -- Display usage
...@@ -794,10 +787,6 @@ procedure Gnatlink is ...@@ -794,10 +787,6 @@ procedure Gnatlink is
function Index (S, Pattern : String) return Natural; function Index (S, Pattern : String) return Natural;
-- Return the last occurrence of Pattern in S, or 0 if none -- Return the last occurrence of Pattern in S, or 0 if none
function Is_Option_Present (Opt : String) return Boolean;
-- Return true if the option Opt is already present in
-- Linker_Options table.
procedure Store_File_Context; procedure Store_File_Context;
-- Store current file context, Fd position and current line data. -- Store current file context, Fd position and current line data.
-- The file context is stored into the rollback data above (RB_*). -- The file context is stored into the rollback data above (RB_*).
...@@ -856,23 +845,6 @@ procedure Gnatlink is ...@@ -856,23 +845,6 @@ procedure Gnatlink is
return 0; return 0;
end Index; end Index;
-----------------------
-- Is_Option_Present --
-----------------------
function Is_Option_Present (Opt : String) return Boolean is
begin
for I in 1 .. Linker_Options.Last loop
if Linker_Options.Table (I).all = Opt then
return True;
end if;
end loop;
return False;
end Is_Option_Present;
--------------------------- ---------------------------
-- Rollback_File_Context -- -- Rollback_File_Context --
--------------------------- ---------------------------
...@@ -1098,13 +1070,7 @@ procedure Gnatlink is ...@@ -1098,13 +1070,7 @@ procedure Gnatlink is
-- Add binder options only if not already set on the command line. -- Add binder options only if not already set on the command line.
-- This rule is a way to control the linker options order. -- This rule is a way to control the linker options order.
-- The following test needs comments, why is it VMS specific. else
-- The above comment looks out of date ???
elsif not
(OpenVMS_On_Target
and then Is_Option_Present (Next_Line (Nfirst .. Nlast)))
then
if Nlast > Nfirst + 2 and then if Nlast > Nfirst + 2 and then
Next_Line (Nfirst .. Nfirst + 1) = "-L" Next_Line (Nfirst .. Nfirst + 1) = "-L"
then then
...@@ -1126,8 +1092,7 @@ procedure Gnatlink is ...@@ -1126,8 +1092,7 @@ procedure Gnatlink is
Linker_Options.Table (Linker_Options.Last) := Linker_Options.Table (Linker_Options.Last) :=
new String'(Next_Line (Nfirst .. Nlast)); new String'(Next_Line (Nfirst .. Nlast));
elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat" elsif Next_Line (Nfirst .. Nlast) = "-lgnarl"
or else Next_Line (Nfirst .. Nlast) = "-lgnarl"
or else Next_Line (Nfirst .. Nlast) = "-lgnat" or else Next_Line (Nfirst .. Nlast) = "-lgnat"
or else or else
Next_Line Next_Line
...@@ -1417,31 +1382,6 @@ procedure Gnatlink is ...@@ -1417,31 +1382,6 @@ procedure Gnatlink is
Status := fclose (Fd); Status := fclose (Fd);
end Process_Binder_File; end Process_Binder_File;
--------------
-- To_Lower --
--------------
function To_Lower (A : Character) return Character is
A_Val : constant Natural := Character'Pos (A);
begin
if A in 'A' .. 'Z'
or else A_Val in 16#C0# .. 16#D6#
or else A_Val in 16#D8# .. 16#DE#
then
return Character'Val (A_Val + 16#20#);
else
return A;
end if;
end To_Lower;
procedure To_Lower (A : in out String) is
begin
for J in A'Range loop
A (J) := To_Lower (A (J));
end loop;
end To_Lower;
----------- -----------
-- Usage -- -- Usage --
----------- -----------
...@@ -1507,45 +1447,33 @@ procedure Gnatlink is ...@@ -1507,45 +1447,33 @@ procedure Gnatlink is
begin begin
-- Add the directory where gnatlink is invoked in front of the path, if -- Add the directory where gnatlink is invoked in front of the path, if
-- gnatlink is invoked with directory information. Only do this if the -- gnatlink is invoked with directory information.
-- platform is not VMS, where the notion of path does not really exist.
if not Hostparm.OpenVMS then declare
declare Command : constant String := Command_Name;
Command : constant String := Command_Name; begin
for Index in reverse Command'Range loop
begin if Command (Index) = Directory_Separator then
for Index in reverse Command'Range loop declare
if Command (Index) = Directory_Separator then Absolute_Dir : constant String :=
declare Normalize_Pathname
Absolute_Dir : constant String := (Command (Command'First .. Index));
Normalize_Pathname
(Command (Command'First .. Index));
PATH : constant String := PATH : constant String :=
Absolute_Dir & Absolute_Dir &
Path_Separator & Path_Separator &
Getenv ("PATH").all; Getenv ("PATH").all;
begin begin
Setenv ("PATH", PATH); Setenv ("PATH", PATH);
end; end;
exit; exit;
end if; end if;
end loop; end loop;
end; end;
end if;
Base_Command_Name := new String'(Base_Name (Command_Name)); Base_Command_Name := new String'(Base_Name (Command_Name));
-- Fold to lower case "GNATLINK" on VMS to be consistent with output
-- from other GNAT utilities.
if Hostparm.OpenVMS then
To_Lower (Base_Command_Name.all);
end if;
Process_Args; Process_Args;
if Argument_Count = 0 if Argument_Count = 0
...@@ -1676,13 +1604,11 @@ begin ...@@ -1676,13 +1604,11 @@ begin
Osint.Add_Default_Search_Dirs; Osint.Add_Default_Search_Dirs;
Targparm.Get_Target_Parameters; Targparm.Get_Target_Parameters;
if VM_Target /= No_VM then case VM_Target is
case VM_Target is when JVM_Target => Gcc := new String'("jvm-gnatcompile");
when JVM_Target => Gcc := new String'("jvm-gnatcompile"); when CLI_Target => Gcc := new String'("dotnet-gnatcompile");
when CLI_Target => Gcc := new String'("dotnet-gnatcompile"); when No_VM => null;
when No_VM => raise Program_Error; end case;
end case;
end if;
-- Compile the bind file with the following switches: -- Compile the bind file with the following switches:
...@@ -1734,17 +1660,6 @@ begin ...@@ -1734,17 +1660,6 @@ begin
if Linker_Path = null then if Linker_Path = null then
Exit_With_Error ("Couldn't locate dotnet-ld"); Exit_With_Error ("Couldn't locate dotnet-ld");
end if; end if;
elsif RTX_RTSS_Kernel_Module_On_Target then
-- Use Microsoft linker for RTSS modules
Linker_Path := System.OS_Lib.Locate_Exec_On_Path ("link");
if Linker_Path = null then
Exit_With_Error ("Couldn't locate link");
end if;
else else
Linker_Path := Gcc_Path; Linker_Path := Gcc_Path;
end if; end if;
...@@ -1760,19 +1675,12 @@ begin ...@@ -1760,19 +1675,12 @@ begin
& Get_Target_Debuggable_Suffix.all); & Get_Target_Debuggable_Suffix.all);
end if; end if;
if RTX_RTSS_Kernel_Module_On_Target then Linker_Options.Increment_Last;
Linker_Options.Increment_Last; Linker_Options.Table (Linker_Options.Last) := new String'("-o");
Linker_Options.Table (Linker_Options.Last) :=
new String'("/OUT:" & Output_File_Name.all);
else
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) := new String'("-o");
Linker_Options.Increment_Last; Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) := Linker_Options.Table (Linker_Options.Last) :=
new String'(Output_File_Name.all); new String'(Output_File_Name.all);
end if;
Check_Existing_Executable (Output_File_Name.all); Check_Existing_Executable (Output_File_Name.all);
...@@ -1828,11 +1736,10 @@ begin ...@@ -1828,11 +1736,10 @@ begin
end loop; end loop;
-- For now we detect windows by an output executable name ending with -- For now we detect windows by an output executable name ending with
-- the suffix .exe (excluding VMS which might use that same name). -- the suffix .exe.
if FN'Length > 5 if FN'Length > 5
and then FN (FN'Last - 3 .. FN'Last) = ".exe" and then FN (FN'Last - 3 .. FN'Last) = ".exe"
and then not OpenVMS_On_Target
then then
Check_File_Name ("install"); Check_File_Name ("install");
Check_File_Name ("setup"); Check_File_Name ("setup");
...@@ -1880,11 +1787,7 @@ begin ...@@ -1880,11 +1787,7 @@ begin
begin begin
-- Set prefix -- Set prefix
if OpenVMS_On_Target then Bind_File_Prefix := new String'("b~");
Bind_File_Prefix := new String'("b__");
else
Bind_File_Prefix := new String'("b~");
end if;
-- If the length of the binder file becomes too long due to -- If the length of the binder file becomes too long due to
-- the addition of the "b?" prefix, then truncate it. -- the addition of the "b?" prefix, then truncate it.
...@@ -1979,359 +1882,209 @@ begin ...@@ -1979,359 +1882,209 @@ begin
-- the actual link at run time. We might consider packing all class files -- the actual link at run time. We might consider packing all class files
-- in a .zip file during this step. -- in a .zip file during this step.
if VM_Target /= JVM_Target then Link_Step : declare
Link_Step : declare Num_Args : Natural :=
Num_Args : Natural := (Linker_Options.Last - Linker_Options.First + 1) +
(Linker_Options.Last - Linker_Options.First + 1) + (Gcc_Linker_Options.Last - Gcc_Linker_Options.First + 1) +
(Gcc_Linker_Options.Last - Gcc_Linker_Options.First + 1) + (Linker_Objects.Last - Linker_Objects.First + 1);
(Linker_Objects.Last - Linker_Objects.First + 1); Stack_Op : Boolean := False;
Stack_Op : Boolean := False;
IDENT_Op : Boolean := False;
begin begin
if AAMP_On_Target then if AAMP_On_Target then
-- Remove extraneous flags not relevant for AAMP -- Remove extraneous flags not relevant for AAMP
for J in reverse Linker_Options.First .. Linker_Options.Last loop for J in reverse Linker_Options.First .. Linker_Options.Last loop
if Linker_Options.Table (J)'Length = 0 if Linker_Options.Table (J)'Length = 0
or else Linker_Options.Table (J) (1 .. 3) = "-Wl" or else Linker_Options.Table (J) (1 .. 3) = "-Wl"
or else Linker_Options.Table (J) (1 .. 3) = "-sh" or else Linker_Options.Table (J) (1 .. 3) = "-sh"
or else Linker_Options.Table (J) (1 .. 2) = "-O" or else Linker_Options.Table (J) (1 .. 2) = "-O"
or else Linker_Options.Table (J) (1 .. 2) = "-g" or else Linker_Options.Table (J) (1 .. 2) = "-g"
then then
Linker_Options.Table (J .. Linker_Options.Last - 1) := Linker_Options.Table (J .. Linker_Options.Last - 1) :=
Linker_Options.Table (J + 1 .. Linker_Options.Last); Linker_Options.Table (J + 1 .. Linker_Options.Last);
Linker_Options.Decrement_Last; Linker_Options.Decrement_Last;
Num_Args := Num_Args - 1; Num_Args := Num_Args - 1;
end if; end if;
end loop; end loop;
end if;
elsif RTX_RTSS_Kernel_Module_On_Target then -- Remove duplicate stack size setting from the Linker_Options table.
-- The stack setting option "-Xlinker --stack=R,C" can be found
-- in one line when set by a pragma Linker_Options or in two lines
-- ("-Xlinker" then "--stack=R,C") when set on the command line. We
-- also check for the "-Wl,--stack=R" style option.
-- Remove irrelevant flags for Microsoft linker, adapt some others -- We must remove the second stack setting option instance because
-- the one on the command line will always be the first one. And any
-- subsequent stack setting option will overwrite the previous one.
-- This is done especially for GNAT/NT where we set the stack size
-- for tasking programs by a pragma in the NT specific tasking
-- package System.Task_Primitives.Operations.
for J in reverse Linker_Options.First .. Linker_Options.Last loop -- Note: This is not a FOR loop that runs from Linker_Options.First
-- to Linker_Options.Last, since operations within the loop can
-- modify the length of the table.
-- Remove flags that are not accepted Clean_Link_Option_Set : declare
J : Natural;
Shared_Libgcc_Seen : Boolean := False;
if Linker_Options.Table (J)'Length = 0 begin
or else Linker_Options.Table (J) (1 .. 2) = "-l" J := Linker_Options.First;
or else Linker_Options.Table (J) (1 .. 3) = "-Wl" while J <= Linker_Options.Last loop
or else Linker_Options.Table (J) (1 .. 3) = "-sh" if Linker_Options.Table (J).all = "-Xlinker"
or else Linker_Options.Table (J) (1 .. 2) = "-O" and then J < Linker_Options.Last
or else Linker_Options.Table (J) (1 .. 8) = "-Xlinker" and then Linker_Options.Table (J + 1)'Length > 8
or else Linker_Options.Table (J) (1 .. 9) = "-mthreads" and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack="
then then
Linker_Options.Table (J .. Linker_Options.Last - 1) := if Stack_Op then
Linker_Options.Table (J + 1 .. Linker_Options.Last); Linker_Options.Table (J .. Linker_Options.Last - 2) :=
Linker_Options.Table (J + 2 .. Linker_Options.Last);
Linker_Options.Decrement_Last; Linker_Options.Decrement_Last;
Num_Args := Num_Args - 1; Linker_Options.Decrement_Last;
Num_Args := Num_Args - 2;
-- Replace "-L" by its counterpart "/LIBPATH:" and UNIX "/" by
-- Windows "\".
elsif Linker_Options.Table (J) (1 .. 2) = "-L" then
declare
Libpath_Option : constant String_Access := new String'
("/LIBPATH:" &
Linker_Options.Table
(J) (3 .. Linker_Options.Table (J).all'Last));
begin
for Index in 10 .. Libpath_Option'Last loop
if Libpath_Option (Index) = '/' then
Libpath_Option (Index) := '\';
end if;
end loop;
Linker_Options.Table (J) := Libpath_Option;
end;
-- Replace "-g" by "/DEBUG"
elsif Linker_Options.Table (J) (1 .. 2) = "-g" then
Linker_Options.Table (J) := new String'("/DEBUG");
-- Replace "-o" by "/OUT:" else
Stack_Op := True;
end if;
end if;
elsif Linker_Options.Table (J) (1 .. 2) = "-o" then -- Remove duplicate -shared-libgcc switch
Linker_Options.Table (J + 1) := new String'
("/OUT:" & Linker_Options.Table (J + 1).all);
if Linker_Options.Table (J).all = Shared_Libgcc_String then
if Shared_Libgcc_Seen then
Linker_Options.Table (J .. Linker_Options.Last - 1) := Linker_Options.Table (J .. Linker_Options.Last - 1) :=
Linker_Options.Table (J + 1 .. Linker_Options.Last); Linker_Options.Table (J + 1 .. Linker_Options.Last);
Linker_Options.Decrement_Last; Linker_Options.Decrement_Last;
Num_Args := Num_Args - 1; Num_Args := Num_Args - 1;
-- Replace "--stack=" by "/STACK:" else
Shared_Libgcc_Seen := True;
elsif Linker_Options.Table (J) (1 .. 8) = "--stack=" then
Linker_Options.Table (J) := new String'
("/STACK:" &
Linker_Options.Table (J)
(9 .. Linker_Options.Table (J).all'Last));
-- Replace "-v" by its counterpart "/VERBOSE"
elsif Linker_Options.Table (J) (1 .. 2) = "-v" then
Linker_Options.Table (J) := new String'("/VERBOSE");
end if;
end loop;
-- Add some required flags to create RTSS modules
declare
Flags_For_Linker : constant array (1 .. 17) of String_Access :=
(new String'("/NODEFAULTLIB"),
new String'("/INCREMENTAL:NO"),
new String'("/NOLOGO"),
new String'("/DRIVER"),
new String'("/ALIGN:0x20"),
new String'("/SUBSYSTEM:NATIVE"),
new String'("/ENTRY:_RtapiProcessEntryCRT@8"),
new String'("/RELEASE"),
new String'("startupCRT.obj"),
new String'("rtxlibcmt.lib"),
new String'("oldnames.lib"),
new String'("rtapi_rtss.lib"),
new String'("Rtx_Rtss.lib"),
new String'("libkernel32.a"),
new String'("libws2_32.a"),
new String'("libmswsock.a"),
new String'("libadvapi32.a"));
-- These flags need to be passed to Microsoft linker. They
-- come from the RTX documentation.
Gcc_Lib_Path : constant String_Access := new String'
("/LIBPATH:" & Include_Dir_Default_Prefix & "\..\");
-- Place to look for gcc related libraries, such as libgcc
begin
-- Replace UNIX "/" by Windows "\" in the path
for Index in 10 .. Gcc_Lib_Path.all'Last loop
if Gcc_Lib_Path (Index) = '/' then
Gcc_Lib_Path (Index) := '\';
end if;
end loop;
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) := Gcc_Lib_Path;
Num_Args := Num_Args + 1;
for Index in Flags_For_Linker'Range loop
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) :=
Flags_For_Linker (Index);
Num_Args := Num_Args + 1;
end loop;
end;
end if;
-- Remove duplicate stack size setting from the Linker_Options table.
-- The stack setting option "-Xlinker --stack=R,C" can be found
-- in one line when set by a pragma Linker_Options or in two lines
-- ("-Xlinker" then "--stack=R,C") when set on the command line. We
-- also check for the "-Wl,--stack=R" style option.
-- We must remove the second stack setting option instance because
-- the one on the command line will always be the first one. And any
-- subsequent stack setting option will overwrite the previous one.
-- This is done especially for GNAT/NT where we set the stack size
-- for tasking programs by a pragma in the NT specific tasking
-- package System.Task_Primitives.Operations.
-- Note: This is not a FOR loop that runs from Linker_Options.First
-- to Linker_Options.Last, since operations within the loop can
-- modify the length of the table.
Clean_Link_Option_Set : declare
J : Natural;
Shared_Libgcc_Seen : Boolean := False;
begin
J := Linker_Options.First;
while J <= Linker_Options.Last loop
if Linker_Options.Table (J).all = "-Xlinker"
and then J < Linker_Options.Last
and then Linker_Options.Table (J + 1)'Length > 8
and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack="
then
if Stack_Op then
Linker_Options.Table (J .. Linker_Options.Last - 2) :=
Linker_Options.Table (J + 2 .. Linker_Options.Last);
Linker_Options.Decrement_Last;
Linker_Options.Decrement_Last;
Num_Args := Num_Args - 2;
else
Stack_Op := True;
end if;
end if;
-- Remove duplicate -shared-libgcc switch
if Linker_Options.Table (J).all = Shared_Libgcc_String then
if Shared_Libgcc_Seen then
Linker_Options.Table (J .. Linker_Options.Last - 1) :=
Linker_Options.Table (J + 1 .. Linker_Options.Last);
Linker_Options.Decrement_Last;
Num_Args := Num_Args - 1;
else
Shared_Libgcc_Seen := True;
end if;
end if;
-- Here we just check for a canonical form that matches the
-- pragma Linker_Options set in the NT runtime.
if (Linker_Options.Table (J)'Length > 17
and then Linker_Options.Table (J) (1 .. 17) =
"-Xlinker --stack=")
or else
(Linker_Options.Table (J)'Length > 12
and then Linker_Options.Table (J) (1 .. 12) =
"-Wl,--stack=")
then
if Stack_Op then
Linker_Options.Table (J .. Linker_Options.Last - 1) :=
Linker_Options.Table (J + 1 .. Linker_Options.Last);
Linker_Options.Decrement_Last;
Num_Args := Num_Args - 1;
else
Stack_Op := True;
end if;
end if; end if;
end if;
-- Remove duplicate IDENTIFICATION directives (VMS) -- Here we just check for a canonical form that matches the
-- pragma Linker_Options set in the NT runtime.
if Linker_Options.Table (J)'Length > 29 if (Linker_Options.Table (J)'Length > 17
and then Linker_Options.Table (J) (1 .. 30) = and then Linker_Options.Table (J) (1 .. 17) =
"--for-linker=--identification=" "-Xlinker --stack=")
then or else
if IDENT_Op then (Linker_Options.Table (J)'Length > 12
Linker_Options.Table (J .. Linker_Options.Last - 1) := and then Linker_Options.Table (J) (1 .. 12) =
Linker_Options.Table (J + 1 .. Linker_Options.Last); "-Wl,--stack=")
Linker_Options.Decrement_Last; then
Num_Args := Num_Args - 1; if Stack_Op then
Linker_Options.Table (J .. Linker_Options.Last - 1) :=
Linker_Options.Table (J + 1 .. Linker_Options.Last);
Linker_Options.Decrement_Last;
Num_Args := Num_Args - 1;
else else
IDENT_Op := True; Stack_Op := True;
end if;
end if; end if;
end if;
J := J + 1; J := J + 1;
end loop; end loop;
if Linker_Path = Gcc_Path and then VM_Target = No_VM then
-- For systems where the default is to link statically with
-- libgcc, if gcc is not called with -shared-libgcc, call it
-- with -static-libgcc, as there are some platforms where one
-- of these two switches is compulsory to link.
if Shared_Libgcc_Default = 'T'
and then not Shared_Libgcc_Seen
then
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) := Static_Libgcc;
Num_Args := Num_Args + 1;
end if;
elsif RTX_RTSS_Kernel_Module_On_Target then if Linker_Path = Gcc_Path and then VM_Target = No_VM then
-- Force the use of the static libgcc for RTSS modules -- For systems where the default is to link statically with
-- libgcc, if gcc is not called with -shared-libgcc, call it
-- with -static-libgcc, as there are some platforms where one
-- of these two switches is compulsory to link.
if Shared_Libgcc_Default = 'T'
and then not Shared_Libgcc_Seen
then
Linker_Options.Increment_Last; Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) := Linker_Options.Table (Linker_Options.Last) := Static_Libgcc;
new String'("libgcc.a");
Num_Args := Num_Args + 1; Num_Args := Num_Args + 1;
end if; end if;
end if;
end Clean_Link_Option_Set;
end Clean_Link_Option_Set; -- Prepare arguments for call to linker
-- Prepare arguments for call to linker Call_Linker : declare
Success : Boolean;
Args : Argument_List (1 .. Num_Args + 1);
Index : Integer := Args'First;
Call_Linker : declare begin
Success : Boolean; Args (Index) := Binder_Obj_File;
Args : Argument_List (1 .. Num_Args + 1);
Index : Integer := Args'First;
begin -- Add the object files and any -largs libraries
Args (Index) := Binder_Obj_File;
for J in Linker_Objects.First .. Linker_Objects.Last loop
Index := Index + 1;
Args (Index) := Linker_Objects.Table (J);
end loop;
-- Add the object files and any -largs libraries -- Add the linker options from the binder file
for J in Linker_Objects.First .. Linker_Objects.Last loop for J in Linker_Options.First .. Linker_Options.Last loop
Index := Index + 1; Index := Index + 1;
Args (Index) := Linker_Objects.Table (J); Args (Index) := Linker_Options.Table (J);
end loop; end loop;
-- Add the linker options from the binder file -- Finally add the libraries from the --GCC= switch
for J in Linker_Options.First .. Linker_Options.Last loop for J in Gcc_Linker_Options.First .. Gcc_Linker_Options.Last loop
Index := Index + 1; Index := Index + 1;
Args (Index) := Linker_Options.Table (J); Args (Index) := Gcc_Linker_Options.Table (J);
end loop; end loop;
-- Finally add the libraries from the --GCC= switch if Verbose_Mode then
Write_Str (Linker_Path.all);
for J in Gcc_Linker_Options.First .. Gcc_Linker_Options.Last loop for J in Args'Range loop
Index := Index + 1; Write_Str (" ");
Args (Index) := Gcc_Linker_Options.Table (J); Write_Str (Args (J).all);
end loop; end loop;
if Verbose_Mode then Write_Eol;
Write_Str (Linker_Path.all);
for J in Args'Range loop -- If we are on very verbose mode (-v -v) and a response file
Write_Str (" "); -- is used we display its content.
Write_Str (Args (J).all);
end loop;
if Very_Verbose_Mode and then Tname_FD /= Invalid_FD then
Write_Eol;
Write_Str ("Response file (" &
Tname (Tname'First .. Tname'Last - 1) &
") content : ");
Write_Eol; Write_Eol;
-- If we are on very verbose mode (-v -v) and a response file for J in
-- is used we display its content. Response_File_Objects.First .. Response_File_Objects.Last
loop
if Very_Verbose_Mode and then Tname_FD /= Invalid_FD then Write_Str (Response_File_Objects.Table (J).all);
Write_Eol;
Write_Str ("Response file (" &
Tname (Tname'First .. Tname'Last - 1) &
") content : ");
Write_Eol; Write_Eol;
end loop;
for J in Write_Eol;
Response_File_Objects.First .. Response_File_Objects.Last
loop
Write_Str (Response_File_Objects.Table (J).all);
Write_Eol;
end loop;
Write_Eol;
end if;
end if; end if;
end if;
System.OS_Lib.Spawn (Linker_Path.all, Args, Success); System.OS_Lib.Spawn (Linker_Path.all, Args, Success);
if Success then
-- Delete the temporary file used in conjunction with linking if Success then
-- if one was created. See Process_Bind_File for details.
if Tname_FD /= Invalid_FD then -- Delete the temporary file used in conjunction with linking
Delete (Tname); -- if one was created. See Process_Bind_File for details.
end if;
else if Tname_FD /= Invalid_FD then
Error_Msg ("error when calling " & Linker_Path.all); Delete (Tname);
Exit_Program (E_Fatal);
end if; end if;
end Call_Linker;
end Link_Step; else
end if; Error_Msg ("error when calling " & Linker_Path.all);
Exit_Program (E_Fatal);
end if;
end Call_Linker;
end Link_Step;
-- Only keep the binder output file and it's associated object -- Only keep the binder output file and it's associated object
-- file if compiling with the -g option. These files are only -- file if compiling with the -g option. These files are only
......
gcc/ada/sem_case.adb
...@@ -456,12 +456,33 @@ package body Sem_Case is ...@@ -456,12 +456,33 @@ package body Sem_Case is
return; return;
end if; end if;
-- Case of only one value that is missing -- Case of only one value that is duplicated
if Lo = Hi then if Lo = Hi then
-- Integer type
if Is_Integer_Type (Bounds_Type) then if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Lo;
Error_Msg_N ("duplication of choice value: ^#!", C); -- We have an integer value, Lo, but if the given choice
-- placement is a constant with that value, then use the
-- name of that constant instead in the message:
if Nkind (C) = N_Identifier
and then Compile_Time_Known_Value (C)
and then Expr_Value (C) = Lo
then
Error_Msg_N ("duplication of choice value: &#!", C);
-- Not that special case, so just output the integer value
else
Error_Msg_Uint_1 := Lo;
Error_Msg_N ("duplication of choice value: ^#!", C);
end if;
-- Enumeration type
else else
Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
Error_Msg_N ("duplication of choice value: %#!", C); Error_Msg_N ("duplication of choice value: %#!", C);
...@@ -470,10 +491,38 @@ package body Sem_Case is ...@@ -470,10 +491,38 @@ package body Sem_Case is
-- More than one choice value, so print range of values -- More than one choice value, so print range of values
else else
-- Integer type
if Is_Integer_Type (Bounds_Type) then if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Lo;
Error_Msg_Uint_2 := Hi; -- Similar to the above, if C is a range of known values which
Error_Msg_N ("duplication of choice values: ^ .. ^#!", C); -- match Lo and Hi, then use the names. We have to go to the
-- original nodes, since the values will have been rewritten
-- to their integer values.
if Nkind (C) = N_Range
and then Nkind (Original_Node (Low_Bound (C))) = N_Identifier
and then Nkind (Original_Node (High_Bound (C))) = N_Identifier
and then Compile_Time_Known_Value (Low_Bound (C))
and then Compile_Time_Known_Value (High_Bound (C))
and then Expr_Value (Low_Bound (C)) = Lo
and then Expr_Value (High_Bound (C)) = Hi
then
Error_Msg_Node_2 := Original_Node (High_Bound (C));
Error_Msg_N
("duplication of choice values: & .. &#!",
Original_Node (Low_Bound (C)));
-- Not that special case, output integer values
else
Error_Msg_Uint_1 := Lo;
Error_Msg_Uint_2 := Hi;
Error_Msg_N ("duplication of choice values: ^ .. ^#!", C);
end if;
-- Enumeration type
else else
Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type); Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment